gdb/guile/scm-frame.c

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