gdb/guile/scm-frame.c

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