gdb/guile/scm-frame.c

   1 /* Scheme interface to stack frames.
   2
   3    Copyright (C) 2008-2024 Free Software Foundation, Inc.
   4
   5    This file is part of GDB.
   6
   7    This program is free software; you can redistribute it and/or modify
   8    it under the terms of the GNU General Public License as published by
   9    the Free Software Foundation; either version 3 of the License, or
  10    (at your option) any later version.
  11
  12    This program is distributed in the hope that it will be useful,
  13    but WITHOUT ANY WARRANTY; without even the implied warranty of
  14    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15    GNU General Public License for more details.
  16
  17    You should have received a copy of the GNU General Public License
  18    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  19
  20 /* See README file in this directory for implementation notes, coding
  21    conventions, et.al.  */
  22
  23 #include "defs.h"
  24 #include "block.h"
  25 #include "frame.h"
  26 #include "inferior.h"
  27 #include "objfiles.h"
  28 #include "symfile.h"
  29 #include "symtab.h"
  30 #include "stack.h"
  31 #include "user-regs.h"
  32 #include "value.h"
  33 #include "guile-internal.h"
  34
  35 /* The <gdb:frame> smob.  */
  36
  37 struct frame_smob
  38 {
  39   /* This always appears first.  */
  40   eqable_gdb_smob base;
  41
  42   struct frame_id frame_id;
  43   struct gdbarch *gdbarch;
  44
  45   /* Frames are tracked by inferior.
  46      We need some place to put the eq?-able hash table, and this feels as
  47      good a place as any.  Frames in one inferior shouldn't be considered
  48      equal to frames in a different inferior.  The frame becomes invalid if
  49      this becomes NULL (the inferior has been deleted from gdb).
  50      It's easier to relax restrictions than impose them after the fact.
  51      N.B. It is an outstanding question whether a frame survives reruns of
  52      the inferior.  Intuitively the answer is "No", but currently a frame
  53      also survives, e.g., multiple invocations of the same function from
  54      the same point.  Even different threads can have the same frame, e.g.,
  55      if a thread dies and a new thread gets the same stack.  */
  56   struct inferior *inferior;
  57
  58   /* Marks that the FRAME_ID member actually holds the ID of the frame next
  59      to this, and not this frame's ID itself.  This is a hack to permit Scheme
  60      frame objects which represent invalid frames (i.e., the last frame_info
  61      in a corrupt stack).  The problem arises from the fact that this code
  62      relies on FRAME_ID to uniquely identify a frame, which is not always true
  63      for the last "frame" in a corrupt stack (it can have a null ID, or the
  64      same ID as the  previous frame).  Whenever get_prev_frame returns NULL, we
  65      record the frame_id of the next frame and set FRAME_ID_IS_NEXT to 1.  */
  66   int frame_id_is_next;
  67 };
  68
  69 static const char frame_smob_name[] = "gdb:frame";
  70
  71 /* The tag Guile knows the frame smob by.  */
  72 static scm_t_bits frame_smob_tag;
  73
  74 /* Keywords used in argument passing.  */
  75 static SCM block_keyword;
  76
  77 /* This is called when an inferior is about to be freed.
  78    Invalidate the frame as further actions on the frame could result
  79    in bad data.  All access to the frame should be gated by
  80    frscm_get_frame_smob_arg_unsafe which will raise an exception on
  81    invalid frames.  */
  82 struct frscm_deleter
  83 {
  84   /* Helper function for frscm_del_inferior_frames to mark the frame
  85      as invalid.  */
  86
  87   static int
  88   frscm_mark_frame_invalid (void **slot, void *info)
  89   {
  90     frame_smob *f_smob = (frame_smob *) *slot;
  91
  92     f_smob->inferior = NULL;
  93     return 1;
  94   }
  95
  96   void operator() (htab_t htab)
  97   {
  98     gdb_assert (htab != nullptr);
  99     htab_traverse_noresize (htab, frscm_mark_frame_invalid, NULL);
 100     htab_delete (htab);
 101   }
 102 };
 103
 104 static const registry<inferior>::key<htab, frscm_deleter>
 105     frscm_inferior_data_key;
 106 \f
 107 /* Administrivia for frame smobs.  */
 108
 109 /* Helper function to hash a frame_smob.  */
 110
 111 static hashval_t
 112 frscm_hash_frame_smob (const void *p)
 113 {
 114   const frame_smob *f_smob = (const frame_smob *) p;
 115   const struct frame_id *fid = &f_smob->frame_id;
 116   hashval_t hash = htab_hash_pointer (f_smob->inferior);
 117
 118   if (fid->stack_status == FID_STACK_VALID)
 119     hash = iterative_hash (&fid->stack_addr, sizeof (fid->stack_addr), hash);
 120   if (fid->code_addr_p)
 121     hash = iterative_hash (&fid->code_addr, sizeof (fid->code_addr), hash);
 122   if (fid->special_addr_p)
 123     hash = iterative_hash (&fid->special_addr, sizeof (fid->special_addr),
 124                            hash);
 125
 126   return hash;
 127 }
 128
 129 /* Helper function to compute equality of frame_smobs.  */
 130
 131 static int
 132 frscm_eq_frame_smob (const void *ap, const void *bp)
 133 {
 134   const frame_smob *a = (const frame_smob *) ap;
 135   const frame_smob *b = (const frame_smob *) bp;
 136
 137   return (a->frame_id == b->frame_id
 138           && a->inferior == b->inferior
 139           && a->inferior != NULL);
 140 }
 141
 142 /* Return the frame -> SCM mapping table.
 143    It is created if necessary.  */
 144
 145 static htab_t
 146 frscm_inferior_frame_map (struct inferior *inferior)
 147 {
 148   htab_t htab = frscm_inferior_data_key.get (inferior);
 149
 150   if (htab == NULL)
 151     {
 152       htab = gdbscm_create_eqable_gsmob_ptr_map (frscm_hash_frame_smob,
 153                                                  frscm_eq_frame_smob);
 154       frscm_inferior_data_key.set (inferior, htab);
 155     }
 156
 157   return htab;
 158 }
 159
 160 /* The smob "free" function for <gdb:frame>.  */
 161
 162 static size_t
 163 frscm_free_frame_smob (SCM self)
 164 {
 165   frame_smob *f_smob = (frame_smob *) SCM_SMOB_DATA (self);
 166
 167   if (f_smob->inferior != NULL)
 168     {
 169       htab_t htab = frscm_inferior_frame_map (f_smob->inferior);
 170
 171       gdbscm_clear_eqable_gsmob_ptr_slot (htab, &f_smob->base);
 172     }
 173
 174   /* Not necessary, done to catch bugs.  */
 175   f_smob->inferior = NULL;
 176
 177   return 0;
 178 }
 179
 180 /* The smob "print" function for <gdb:frame>.  */
 181
 182 static int
 183 frscm_print_frame_smob (SCM self, SCM port, scm_print_state *pstate)
 184 {
 185   frame_smob *f_smob = (frame_smob *) SCM_SMOB_DATA (self);
 186
 187   gdbscm_printf (port, "#<%s %s>",
 188                  frame_smob_name,
 189                  f_smob->frame_id.to_string ().c_str ());
 190   scm_remember_upto_here_1 (self);
 191
 192   /* Non-zero means success.  */
 193   return 1;
 194 }
 195
 196 /* Low level routine to create a <gdb:frame> object.  */
 197
 198 static SCM
 199 frscm_make_frame_smob (void)
 200 {
 201   frame_smob *f_smob = (frame_smob *)
 202     scm_gc_malloc (sizeof (frame_smob), frame_smob_name);
 203   SCM f_scm;
 204
 205   f_smob->frame_id = null_frame_id;
 206   f_smob->gdbarch = NULL;
 207   f_smob->inferior = NULL;
 208   f_smob->frame_id_is_next = 0;
 209   f_scm = scm_new_smob (frame_smob_tag, (scm_t_bits) f_smob);
 210   gdbscm_init_eqable_gsmob (&f_smob->base, f_scm);
 211
 212   return f_scm;
 213 }
 214
 215 /* Return non-zero if SCM is a <gdb:frame> object.  */
 216
 217 int
 218 frscm_is_frame (SCM scm)
 219 {
 220   return SCM_SMOB_PREDICATE (frame_smob_tag, scm);
 221 }
 222
 223 /* (frame? object) -> boolean */
 224
 225 static SCM
 226 gdbscm_frame_p (SCM scm)
 227 {
 228   return scm_from_bool (frscm_is_frame (scm));
 229 }
 230
 231 /* Create a new <gdb:frame> object that encapsulates FRAME.
 232    Returns a <gdb:exception> object if there is an error.  */
 233
 234 static SCM
 235 frscm_scm_from_frame (struct frame_info *frame, struct inferior *inferior)
 236 {
 237   frame_smob *f_smob, f_smob_for_lookup;
 238   SCM f_scm;
 239   htab_t htab;
 240   eqable_gdb_smob **slot;
 241   struct frame_id frame_id = null_frame_id;
 242   struct gdbarch *gdbarch = NULL;
 243   int frame_id_is_next = 0;
 244
 245   /* If we've already created a gsmob for this frame, return it.
 246      This makes frames eq?-able.  */
 247   htab = frscm_inferior_frame_map (inferior);
 248   f_smob_for_lookup.frame_id = get_frame_id (frame_info_ptr (frame));
 249   f_smob_for_lookup.inferior = inferior;
 250   slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &f_smob_for_lookup.base);
 251   if (*slot != NULL)
 252     return (*slot)->containing_scm;
 253
 254   try
 255     {
 256       frame_info_ptr frame_ptr (frame);
 257
 258       /* Try to get the previous frame, to determine if this is the last frame
 259          in a corrupt stack.  If so, we need to store the frame_id of the next
 260          frame and not of this one (which is possibly invalid).  */
 261       if (get_prev_frame (frame_ptr) == NULL
 262           && get_frame_unwind_stop_reason (frame_ptr) != UNWIND_NO_REASON
 263           && get_next_frame (frame_ptr) != NULL)
 264         {
 265           frame_id = get_frame_id (get_next_frame (frame_ptr));
 266           frame_id_is_next = 1;
 267         }
 268       else
 269         {
 270           frame_id = get_frame_id (frame_ptr);
 271           frame_id_is_next = 0;
 272         }
 273       gdbarch = get_frame_arch (frame_ptr);
 274     }
 275   catch (const gdb_exception &except)
 276     {
 277       return gdbscm_scm_from_gdb_exception (unpack (except));
 278     }
 279
 280   f_scm = frscm_make_frame_smob ();
 281   f_smob = (frame_smob *) SCM_SMOB_DATA (f_scm);
 282   f_smob->frame_id = frame_id;
 283   f_smob->gdbarch = gdbarch;
 284   f_smob->inferior = inferior;
 285   f_smob->frame_id_is_next = frame_id_is_next;
 286
 287   gdbscm_fill_eqable_gsmob_ptr_slot (slot, &f_smob->base);
 288
 289   return f_scm;
 290 }
 291
 292 /* Create a new <gdb:frame> object that encapsulates FRAME.
 293    A Scheme exception is thrown if there is an error.  */
 294
 295 static SCM
 296 frscm_scm_from_frame_unsafe (struct frame_info *frame,
 297                              struct inferior *inferior)
 298 {
 299   SCM f_scm = frscm_scm_from_frame (frame, inferior);
 300
 301   if (gdbscm_is_exception (f_scm))
 302     gdbscm_throw (f_scm);
 303
 304   return f_scm;
 305 }
 306
 307 /* Returns the <gdb:frame> object in SELF.
 308    Throws an exception if SELF is not a <gdb:frame> object.  */
 309
 310 static SCM
 311 frscm_get_frame_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 312 {
 313   SCM_ASSERT_TYPE (frscm_is_frame (self), self, arg_pos, func_name,
 314                    frame_smob_name);
 315
 316   return self;
 317 }
 318
 319 /* There is no gdbscm_scm_to_frame function because translating
 320    a frame SCM object to a struct frame_info * can throw a GDB error.
 321    Thus code working with frames has to handle both Scheme errors (e.g., the
 322    object is not a frame) and GDB errors (e.g., the frame lookup failed).
 323
 324    To help keep things clear we split what would be gdbscm_scm_to_frame
 325    into two:
 326
 327    frscm_get_frame_smob_arg_unsafe
 328      - throws a Scheme error if object is not a frame,
 329        or if the inferior is gone or is no longer current
 330
 331    frscm_frame_smob_to_frame
 332      - may throw a gdb error if the conversion fails
 333      - it's not clear when it will and won't throw a GDB error,
 334        but for robustness' sake we assume that whenever we call out to GDB
 335        a GDB error may get thrown (and thus the call must be wrapped in a
 336        TRY_CATCH)  */
 337
 338 /* Returns the frame_smob for the object wrapped by FRAME_SCM.
 339    A Scheme error is thrown if FRAME_SCM is not a frame.  */
 340
 341 frame_smob *
 342 frscm_get_frame_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 343 {
 344   SCM f_scm = frscm_get_frame_arg_unsafe (self, arg_pos, func_name);
 345   frame_smob *f_smob = (frame_smob *) SCM_SMOB_DATA (f_scm);
 346
 347   if (f_smob->inferior == NULL)
 348     {
 349       gdbscm_invalid_object_error (func_name, arg_pos, self,
 350                                    _("inferior"));
 351     }
 352   if (f_smob->inferior != current_inferior ())
 353     scm_misc_error (func_name, _("inferior has changed"), SCM_EOL);
 354
 355   return f_smob;
 356 }
 357
 358 /* Returns the frame_info object wrapped by F_SMOB.
 359    If the frame doesn't exist anymore (the frame id doesn't
 360    correspond to any frame in the inferior), returns NULL.
 361    This function calls GDB routines, so don't assume a GDB error will
 362    not be thrown.  */
 363
 364 struct frame_info_ptr
 365 frscm_frame_smob_to_frame (frame_smob *f_smob)
 366 {
 367   frame_info_ptr frame = frame_find_by_id (f_smob->frame_id);
 368   if (frame == NULL)
 369     return NULL;
 370
 371   if (f_smob->frame_id_is_next)
 372     frame = get_prev_frame (frame);
 373
 374   return frame;
 375 }
 376
 377 \f
 378 /* Frame methods.  */
 379
 380 /* (frame-valid? <gdb:frame>) -> bool
 381    Returns #t if the frame corresponding to the frame_id of this
 382    object still exists in the inferior.  */
 383
 384 static SCM
 385 gdbscm_frame_valid_p (SCM self)
 386 {
 387   frame_smob *f_smob;
 388   bool result = false;
 389
 390   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 391
 392   gdbscm_gdb_exception exc {};
 393   try
 394     {
 395       frame_info_ptr frame = frscm_frame_smob_to_frame (f_smob);
 396       result = frame != nullptr;
 397     }
 398   catch (const gdb_exception &except)
 399     {
 400       exc = unpack (except);
 401     }
 402
 403   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 404   return scm_from_bool (result);
 405 }
 406
 407 /* (frame-name <gdb:frame>) -> string
 408    Returns the name of the function corresponding to this frame,
 409    or #f if there is no function.  */
 410
 411 static SCM
 412 gdbscm_frame_name (SCM self)
 413 {
 414   frame_smob *f_smob;
 415   gdb::unique_xmalloc_ptr<char> name;
 416   enum language lang = language_minimal;
 417   bool found = false;
 418   SCM result;
 419
 420   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 421
 422   gdbscm_gdb_exception exc {};
 423   try
 424     {
 425       frame_info_ptr frame = frscm_frame_smob_to_frame (f_smob);
 426       if (frame != NULL)
 427         {
 428           found = true;
 429           name = find_frame_funname (frame, &lang, NULL);
 430         }
 431     }
 432   catch (const gdb_exception &except)
 433     {
 434       exc = unpack (except);
 435     }
 436
 437   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 438   if (!found)
 439     {
 440       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 441                                    _("<gdb:frame>"));
 442     }
 443
 444   if (name != NULL)
 445     result = gdbscm_scm_from_c_string (name.get ());
 446   else
 447     result = SCM_BOOL_F;
 448
 449   return result;
 450 }
 451
 452 /* (frame-type <gdb:frame>) -> integer
 453    Returns the frame type, namely one of the gdb:*_FRAME constants.  */
 454
 455 static SCM
 456 gdbscm_frame_type (SCM self)
 457 {
 458   frame_smob *f_smob;
 459   enum frame_type type = NORMAL_FRAME;
 460   bool found = false;
 461
 462   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 463
 464   gdbscm_gdb_exception exc {};
 465   try
 466     {
 467       frame_info_ptr frame = frscm_frame_smob_to_frame (f_smob);
 468       if (frame != NULL)
 469         {
 470           found = true;
 471           type = get_frame_type (frame);
 472         }
 473     }
 474   catch (const gdb_exception &except)
 475     {
 476       exc = unpack (except);
 477     }
 478
 479   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 480   if (!found)
 481     {
 482       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 483                                    _("<gdb:frame>"));
 484     }
 485
 486   return scm_from_int (type);
 487 }
 488
 489 /* (frame-arch <gdb:frame>) -> <gdb:architecture>
 490    Returns the frame's architecture as a gdb:architecture object.  */
 491
 492 static SCM
 493 gdbscm_frame_arch (SCM self)
 494 {
 495   frame_smob *f_smob;
 496   bool found = false;
 497
 498   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 499
 500   gdbscm_gdb_exception exc {};
 501   try
 502     {
 503       frame_info_ptr frame = frscm_frame_smob_to_frame (f_smob);
 504       found = frame != nullptr;
 505     }
 506   catch (const gdb_exception &except)
 507     {
 508       exc = unpack (except);
 509     }
 510
 511   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 512   if (!found)
 513     {
 514       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 515                                    _("<gdb:frame>"));
 516     }
 517
 518   return arscm_scm_from_arch (f_smob->gdbarch);
 519 }
 520
 521 /* (frame-unwind-stop-reason <gdb:frame>) -> integer
 522    Returns one of the gdb:FRAME_UNWIND_* constants.  */
 523
 524 static SCM
 525 gdbscm_frame_unwind_stop_reason (SCM self)
 526 {
 527   frame_smob *f_smob;
 528   bool found = false;
 529   enum unwind_stop_reason stop_reason = UNWIND_NO_REASON;
 530
 531   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 532
 533   gdbscm_gdb_exception exc {};
 534   try
 535     {
 536       frame_info_ptr frame = frscm_frame_smob_to_frame (f_smob);
 537       if (frame != nullptr)
 538         {
 539           found = true;
 540           stop_reason = get_frame_unwind_stop_reason (frame);
 541         }
 542     }
 543   catch (const gdb_exception &except)
 544     {
 545       exc = unpack (except);
 546     }
 547
 548   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 549   if (!found)
 550     {
 551       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 552                                    _("<gdb:frame>"));
 553     }
 554
 555   return scm_from_int (stop_reason);
 556 }
 557
 558 /* (frame-pc <gdb:frame>) -> integer
 559    Returns the frame's resume address.  */
 560
 561 static SCM
 562 gdbscm_frame_pc (SCM self)
 563 {
 564   frame_smob *f_smob;
 565   CORE_ADDR pc = 0;
 566   bool found = false;
 567
 568   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 569
 570   gdbscm_gdb_exception exc {};
 571   try
 572     {
 573       frame_info_ptr frame = frscm_frame_smob_to_frame (f_smob);
 574       if (frame != NULL)
 575         {
 576           pc = get_frame_pc (frame);
 577           found = true;
 578         }
 579     }
 580   catch (const gdb_exception &except)
 581     {
 582       exc = unpack (except);
 583     }
 584
 585   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 586   if (!found)
 587     {
 588       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 589                                    _("<gdb:frame>"));
 590     }
 591
 592   return gdbscm_scm_from_ulongest (pc);
 593 }
 594
 595 /* (frame-block <gdb:frame>) -> <gdb:block>
 596    Returns the frame's code block, or #f if one cannot be found.  */
 597
 598 static SCM
 599 gdbscm_frame_block (SCM self)
 600 {
 601   frame_smob *f_smob;
 602   const struct block *block = NULL, *fn_block;
 603   bool found = false;
 604
 605   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 606
 607   gdbscm_gdb_exception exc {};
 608   try
 609     {
 610       frame_info_ptr frame = frscm_frame_smob_to_frame (f_smob);
 611       if (frame != NULL)
 612         {
 613           found = true;
 614           block = get_frame_block (frame, NULL);
 615         }
 616     }
 617   catch (const gdb_exception &except)
 618     {
 619       exc = unpack (except);
 620     }
 621
 622   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 623   if (!found)
 624     {
 625       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 626                                    _("<gdb:frame>"));
 627     }
 628
 629   for (fn_block = block;
 630        fn_block != NULL && fn_block->function () == NULL;
 631        fn_block = fn_block->superblock ())
 632     continue;
 633
 634   if (block == NULL || fn_block == NULL || fn_block->function () == NULL)
 635     {
 636       scm_misc_error (FUNC_NAME, _("cannot find block for frame"),
 637                       scm_list_1 (self));
 638     }
 639
 640   if (block != NULL)
 641     {
 642       return bkscm_scm_from_block
 643         (block, fn_block->function ()->objfile ());
 644     }
 645
 646   return SCM_BOOL_F;
 647 }
 648
 649 /* (frame-function <gdb:frame>) -> <gdb:symbol>
 650    Returns the symbol for the function corresponding to this frame,
 651    or #f if there isn't one.  */
 652
 653 static SCM
 654 gdbscm_frame_function (SCM self)
 655 {
 656   frame_smob *f_smob;
 657   struct symbol *sym = NULL;
 658   bool found = false;
 659
 660   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 661
 662   gdbscm_gdb_exception exc {};
 663   try
 664     {
 665       frame_info_ptr frame = frscm_frame_smob_to_frame (f_smob);
 666       if (frame != NULL)
 667         {
 668           found = true;
 669           sym = find_pc_function (get_frame_address_in_block (frame));
 670         }
 671     }
 672   catch (const gdb_exception &except)
 673     {
 674       exc = unpack (except);
 675     }
 676
 677   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 678   if (!found)
 679     {
 680       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 681                                    _("<gdb:frame>"));
 682     }
 683
 684   if (sym != NULL)
 685     return syscm_scm_from_symbol (sym);
 686
 687   return SCM_BOOL_F;
 688 }
 689
 690 /* (frame-older <gdb:frame>) -> <gdb:frame>
 691    Returns the frame immediately older (outer) to this frame,
 692    or #f if there isn't one.  */
 693
 694 static SCM
 695 gdbscm_frame_older (SCM self)
 696 {
 697   frame_smob *f_smob;
 698   struct frame_info *prev = NULL;
 699   bool found = false;
 700
 701   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 702
 703   gdbscm_gdb_exception exc {};
 704   try
 705     {
 706       frame_info_ptr frame = frscm_frame_smob_to_frame (f_smob);
 707       if (frame != NULL)
 708         {
 709           found = true;
 710           prev = get_prev_frame (frame).get ();
 711         }
 712     }
 713   catch (const gdb_exception &except)
 714     {
 715       exc = unpack (except);
 716     }
 717
 718   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 719   if (!found)
 720     {
 721       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 722                                    _("<gdb:frame>"));
 723     }
 724
 725   if (prev != NULL)
 726     return frscm_scm_from_frame_unsafe (prev, f_smob->inferior);
 727
 728   return SCM_BOOL_F;
 729 }
 730
 731 /* (frame-newer <gdb:frame>) -> <gdb:frame>
 732    Returns the frame immediately newer (inner) to this frame,
 733    or #f if there isn't one.  */
 734
 735 static SCM
 736 gdbscm_frame_newer (SCM self)
 737 {
 738   frame_smob *f_smob;
 739   struct frame_info *next = NULL;
 740   bool found = false;
 741
 742   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 743
 744   gdbscm_gdb_exception exc {};
 745   try
 746     {
 747       frame_info_ptr frame = frscm_frame_smob_to_frame (f_smob);
 748       if (frame != NULL)
 749         {
 750           found = true;
 751           next = get_next_frame (frame).get ();
 752         }
 753     }
 754   catch (const gdb_exception &except)
 755     {
 756       exc = unpack (except);
 757     }
 758
 759   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 760   if (!found)
 761     {
 762       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 763                                    _("<gdb:frame>"));
 764     }
 765
 766   if (next != NULL)
 767     return frscm_scm_from_frame_unsafe (next, f_smob->inferior);
 768
 769   return SCM_BOOL_F;
 770 }
 771
 772 /* (frame-sal <gdb:frame>) -> <gdb:sal>
 773    Returns the frame's symtab and line.  */
 774
 775 static SCM
 776 gdbscm_frame_sal (SCM self)
 777 {
 778   frame_smob *f_smob;
 779   struct symtab_and_line sal;
 780   bool found = false;
 781
 782   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 783
 784   gdbscm_gdb_exception exc {};
 785   try
 786     {
 787       frame_info_ptr frame = frscm_frame_smob_to_frame (f_smob);
 788       if (frame != NULL)
 789         {
 790           found = true;
 791           sal = find_frame_sal (frame);
 792         }
 793     }
 794   catch (const gdb_exception &except)
 795     {
 796       exc = unpack (except);
 797     }
 798
 799   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 800   if (!found)
 801     {
 802       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 803                                    _("<gdb:frame>"));
 804     }
 805
 806   return stscm_scm_from_sal (sal);
 807 }
 808
 809 /* (frame-read-register <gdb:frame> string) -> <gdb:value>
 810    The register argument must be a string.  */
 811
 812 static SCM
 813 gdbscm_frame_read_register (SCM self, SCM register_scm)
 814 {
 815   char *register_str;
 816   struct value *value = NULL;
 817   bool found = false;
 818   frame_smob *f_smob;
 819
 820   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 821   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, NULL, "s",
 822                               register_scm, &register_str);
 823
 824   gdbscm_gdb_exception except {};
 825
 826   try
 827     {
 828       int regnum;
 829
 830       frame_info_ptr frame = frscm_frame_smob_to_frame (f_smob);
 831       if (frame)
 832         {
 833           found = true;
 834           regnum = user_reg_map_name_to_regnum (get_frame_arch (frame),
 835                                                 register_str,
 836                                                 strlen (register_str));
 837           if (regnum >= 0)
 838             value = value_of_register (regnum,
 839                                        get_next_frame_sentinel_okay (frame));
 840         }
 841     }
 842   catch (const gdb_exception &ex)
 843     {
 844       except = unpack (ex);
 845     }
 846
 847   xfree (register_str);
 848   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 849
 850   if (!found)
 851     {
 852       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 853                                    _("<gdb:frame>"));
 854     }
 855
 856   if (value == NULL)
 857     {
 858       gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, register_scm,
 859                                  _("unknown register"));
 860     }
 861
 862   return vlscm_scm_from_value (value);
 863 }
 864
 865 /* (frame-read-var <gdb:frame> <gdb:symbol>) -> <gdb:value>
 866    (frame-read-var <gdb:frame> string [#:block <gdb:block>]) -> <gdb:value>
 867    If the optional block argument is provided start the search from that block,
 868    otherwise search from the frame's current block (determined by examining
 869    the resume address of the frame).  The variable argument must be a string
 870    or an instance of a <gdb:symbol>.  The block argument must be an instance of
 871    <gdb:block>.  */
 872
 873 static SCM
 874 gdbscm_frame_read_var (SCM self, SCM symbol_scm, SCM rest)
 875 {
 876   SCM keywords[] = { block_keyword, SCM_BOOL_F };
 877   frame_smob *f_smob;
 878   int block_arg_pos = -1;
 879   SCM block_scm = SCM_UNDEFINED;
 880   struct frame_info *frame = NULL;
 881   struct symbol *var = NULL;
 882   const struct block *block = NULL;
 883   struct value *value = NULL;
 884
 885   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 886
 887   gdbscm_gdb_exception exc {};
 888   try
 889     {
 890       frame = frscm_frame_smob_to_frame (f_smob).get ();
 891     }
 892   catch (const gdb_exception &except)
 893     {
 894       exc = unpack (except);
 895     }
 896
 897   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 898   if (frame == NULL)
 899     {
 900       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 901                                    _("<gdb:frame>"));
 902     }
 903
 904   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG3, keywords, "#O",
 905                               rest, &block_arg_pos, &block_scm);
 906
 907   if (syscm_is_symbol (symbol_scm))
 908     {
 909       var = syscm_get_valid_symbol_arg_unsafe (symbol_scm, SCM_ARG2,
 910                                                FUNC_NAME);
 911       SCM_ASSERT (SCM_UNBNDP (block_scm), block_scm, SCM_ARG3, FUNC_NAME);
 912     }
 913   else if (scm_is_string (symbol_scm))
 914     {
 915       gdbscm_gdb_exception except {};
 916
 917       if (! SCM_UNBNDP (block_scm))
 918         {
 919           SCM except_scm;
 920
 921           gdb_assert (block_arg_pos > 0);
 922           block = bkscm_scm_to_block (block_scm, block_arg_pos, FUNC_NAME,
 923                                       &except_scm);
 924           if (block == NULL)
 925             gdbscm_throw (except_scm);
 926         }
 927
 928       {
 929         gdb::unique_xmalloc_ptr<char> var_name
 930           (gdbscm_scm_to_c_string (symbol_scm));
 931         /* N.B. Between here and the end of the scope, don't do anything
 932            to cause a Scheme exception.  */
 933
 934         try
 935           {
 936             struct block_symbol lookup_sym;
 937
 938             if (block == NULL)
 939               block = get_frame_block (frame_info_ptr (frame), NULL);
 940             lookup_sym = lookup_symbol (var_name.get (), block, VAR_DOMAIN,
 941                                         NULL);
 942             var = lookup_sym.symbol;
 943             block = lookup_sym.block;
 944           }
 945         catch (const gdb_exception &ex)
 946           {
 947             except = unpack (ex);
 948           }
 949       }
 950
 951       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 952
 953       if (var == NULL)
 954         gdbscm_out_of_range_error (FUNC_NAME, 0, symbol_scm,
 955                                    _("variable not found"));
 956     }
 957   else
 958     {
 959       /* Use SCM_ASSERT_TYPE for more consistent error messages.  */
 960       SCM_ASSERT_TYPE (0, symbol_scm, SCM_ARG1, FUNC_NAME,
 961                        _("gdb:symbol or string"));
 962     }
 963
 964   try
 965     {
 966       value = read_var_value (var, block, frame_info_ptr (frame));
 967     }
 968   catch (const gdb_exception &except)
 969     {
 970       exc = unpack (except);
 971     }
 972
 973   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 974   return vlscm_scm_from_value (value);
 975 }
 976
 977 /* (frame-select <gdb:frame>) -> unspecified
 978    Select this frame.  */
 979
 980 static SCM
 981 gdbscm_frame_select (SCM self)
 982 {
 983   frame_smob *f_smob;
 984   bool found = false;
 985
 986   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 987
 988   gdbscm_gdb_exception exc {};
 989   try
 990     {
 991       frame_info_ptr frame = frscm_frame_smob_to_frame (f_smob);
 992       if (frame != NULL)
 993         {
 994           found = true;
 995           select_frame (frame);
 996         }
 997     }
 998   catch (const gdb_exception &except)
 999     {
1000       exc = unpack (except);
1001     }
1002
1003   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
1004   if (!found)
1005     {
1006       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
1007                                    _("<gdb:frame>"));
1008     }
1009
1010   return SCM_UNSPECIFIED;
1011 }
1012
1013 /* (newest-frame) -> <gdb:frame>
1014    Returns the newest frame.  */
1015
1016 static SCM
1017 gdbscm_newest_frame (void)
1018 {
1019   struct frame_info *frame = NULL;
1020
1021   gdbscm_gdb_exception exc {};
1022   try
1023     {
1024       frame = get_current_frame ().get ();
1025     }
1026   catch (const gdb_exception &except)
1027     {
1028       exc = unpack (except);
1029     }
1030
1031   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
1032   return frscm_scm_from_frame_unsafe (frame, current_inferior ());
1033 }
1034
1035 /* (selected-frame) -> <gdb:frame>
1036    Returns the selected frame.  */
1037
1038 static SCM
1039 gdbscm_selected_frame (void)
1040 {
1041   struct frame_info *frame = NULL;
1042
1043   gdbscm_gdb_exception exc {};
1044   try
1045     {
1046       frame = get_selected_frame (_("No frame is currently selected")).get ();
1047     }
1048   catch (const gdb_exception &except)
1049     {
1050       exc = unpack (except);
1051     }
1052
1053   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
1054   return frscm_scm_from_frame_unsafe (frame, current_inferior ());
1055 }
1056
1057 /* (unwind-stop-reason-string integer) -> string
1058    Return a string explaining the unwind stop reason.  */
1059
1060 static SCM
1061 gdbscm_unwind_stop_reason_string (SCM reason_scm)
1062 {
1063   int reason;
1064   const char *str;
1065
1066   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "i",
1067                               reason_scm, &reason);
1068
1069   if (reason < UNWIND_FIRST || reason > UNWIND_LAST)
1070     scm_out_of_range (FUNC_NAME, reason_scm);
1071
1072   str = unwind_stop_reason_to_string ((enum unwind_stop_reason) reason);
1073   return gdbscm_scm_from_c_string (str);
1074 }
1075 \f
1076 /* Initialize the Scheme frame support.  */
1077
1078 static const scheme_integer_constant frame_integer_constants[] =
1079 {
1080 #define ENTRY(X) { #X, X }
1081
1082   ENTRY (NORMAL_FRAME),
1083   ENTRY (DUMMY_FRAME),
1084   ENTRY (INLINE_FRAME),
1085   ENTRY (TAILCALL_FRAME),
1086   ENTRY (SIGTRAMP_FRAME),
1087   ENTRY (ARCH_FRAME),
1088   ENTRY (SENTINEL_FRAME),
1089
1090 #undef ENTRY
1091
1092 #define SET(name, description) \
1093   { "FRAME_" #name, name },
1094 #include "unwind_stop_reasons.def"
1095 #undef SET
1096
1097   END_INTEGER_CONSTANTS
1098 };
1099
1100 static const scheme_function frame_functions[] =
1101 {
1102   { "frame?", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_p),
1103     "\
1104 Return #t if the object is a <gdb:frame> object." },
1105
1106   { "frame-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_valid_p),
1107     "\
1108 Return #t if the object is a valid <gdb:frame> object.\n\
1109 Frames become invalid when the inferior returns to its caller." },
1110
1111   { "frame-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_name),
1112     "\
1113 Return the name of the function corresponding to this frame,\n\
1114 or #f if there is no function." },
1115
1116   { "frame-arch", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_arch),
1117     "\
1118 Return the frame's architecture as a <gdb:arch> object." },
1119
1120   { "frame-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_type),
1121     "\
1122 Return the frame type, namely one of the gdb:*_FRAME constants." },
1123
1124   { "frame-unwind-stop-reason", 1, 0, 0,
1125     as_a_scm_t_subr (gdbscm_frame_unwind_stop_reason),
1126     "\
1127 Return one of the gdb:FRAME_UNWIND_* constants explaining why\n\
1128 it's not possible to find frames older than this." },
1129
1130   { "frame-pc", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_pc),
1131     "\
1132 Return the frame's resume address." },
1133
1134   { "frame-block", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_block),
1135     "\
1136 Return the frame's code block, or #f if one cannot be found." },
1137
1138   { "frame-function", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_function),
1139     "\
1140 Return the <gdb:symbol> for the function corresponding to this frame,\n\
1141 or #f if there isn't one." },
1142
1143   { "frame-older", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_older),
1144     "\
1145 Return the frame immediately older (outer) to this frame,\n\
1146 or #f if there isn't one." },
1147
1148   { "frame-newer", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_newer),
1149     "\
1150 Return the frame immediately newer (inner) to this frame,\n\
1151 or #f if there isn't one." },
1152
1153   { "frame-sal", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_sal),
1154     "\
1155 Return the frame's symtab-and-line <gdb:sal> object." },
1156
1157   { "frame-read-var", 2, 0, 1, as_a_scm_t_subr (gdbscm_frame_read_var),
1158     "\
1159 Return the value of the symbol in the frame.\n\
1160 \n\
1161   Arguments: <gdb:frame> <gdb:symbol>\n\
1162          Or: <gdb:frame> string [#:block <gdb:block>]" },
1163
1164   { "frame-read-register", 2, 0, 0,
1165     as_a_scm_t_subr (gdbscm_frame_read_register),
1166     "\
1167 Return the value of the register in the frame.\n\
1168 \n\
1169   Arguments: <gdb:frame> string" },
1170
1171   { "frame-select", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_select),
1172     "\
1173 Select this frame." },
1174
1175   { "newest-frame", 0, 0, 0, as_a_scm_t_subr (gdbscm_newest_frame),
1176     "\
1177 Return the newest frame." },
1178
1179   { "selected-frame", 0, 0, 0, as_a_scm_t_subr (gdbscm_selected_frame),
1180     "\
1181 Return the selected frame." },
1182
1183   { "unwind-stop-reason-string", 1, 0, 0,
1184     as_a_scm_t_subr (gdbscm_unwind_stop_reason_string),
1185     "\
1186 Return a string explaining the unwind stop reason.\n\
1187 \n\
1188   Arguments: integer (the result of frame-unwind-stop-reason)" },
1189
1190   END_FUNCTIONS
1191 };
1192
1193 void
1194 gdbscm_initialize_frames (void)
1195 {
1196   frame_smob_tag
1197     = gdbscm_make_smob_type (frame_smob_name, sizeof (frame_smob));
1198   scm_set_smob_free (frame_smob_tag, frscm_free_frame_smob);
1199   scm_set_smob_print (frame_smob_tag, frscm_print_frame_smob);
1200
1201   gdbscm_define_integer_constants (frame_integer_constants, 1);
1202   gdbscm_define_functions (frame_functions, 1);
1203
1204   block_keyword = scm_from_latin1_keyword ("block");
1205 }