gdb/guile/scm-frame.c

   1 /* Scheme interface to stack frames.
   2
   3    Copyright (C) 2008-2019 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 (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   try
 400     {
 401       frame = frscm_frame_smob_to_frame (f_smob);
 402     }
 403   catch (const gdb_exception &except)
 404     {
 405       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 406     }
 407
 408   return scm_from_bool (frame != NULL);
 409 }
 410
 411 /* (frame-name <gdb:frame>) -> string
 412    Returns the name of the function corresponding to this frame,
 413    or #f if there is no function.  */
 414
 415 static SCM
 416 gdbscm_frame_name (SCM self)
 417 {
 418   frame_smob *f_smob;
 419   gdb::unique_xmalloc_ptr<char> name;
 420   enum language lang = language_minimal;
 421   struct frame_info *frame = NULL;
 422   SCM result;
 423
 424   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 425
 426   try
 427     {
 428       frame = frscm_frame_smob_to_frame (f_smob);
 429       if (frame != NULL)
 430         name = find_frame_funname (frame, &lang, NULL);
 431     }
 432   catch (const gdb_exception &except)
 433     {
 434       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 435     }
 436
 437   if (frame == NULL)
 438     {
 439       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 440                                    _("<gdb:frame>"));
 441     }
 442
 443   if (name != NULL)
 444     result = gdbscm_scm_from_c_string (name.get ());
 445   else
 446     result = SCM_BOOL_F;
 447
 448   return result;
 449 }
 450
 451 /* (frame-type <gdb:frame>) -> integer
 452    Returns the frame type, namely one of the gdb:*_FRAME constants.  */
 453
 454 static SCM
 455 gdbscm_frame_type (SCM self)
 456 {
 457   frame_smob *f_smob;
 458   enum frame_type type = NORMAL_FRAME;
 459   struct frame_info *frame = NULL;
 460
 461   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 462
 463   try
 464     {
 465       frame = frscm_frame_smob_to_frame (f_smob);
 466       if (frame != NULL)
 467         type = get_frame_type (frame);
 468     }
 469   catch (const gdb_exception &except)
 470     {
 471       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 472     }
 473
 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   try
 495     {
 496       frame = frscm_frame_smob_to_frame (f_smob);
 497     }
 498   catch (const gdb_exception &except)
 499     {
 500       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 501     }
 502
 503   if (frame == NULL)
 504     {
 505       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 506                                    _("<gdb:frame>"));
 507     }
 508
 509   return arscm_scm_from_arch (f_smob->gdbarch);
 510 }
 511
 512 /* (frame-unwind-stop-reason <gdb:frame>) -> integer
 513    Returns one of the gdb:FRAME_UNWIND_* constants.  */
 514
 515 static SCM
 516 gdbscm_frame_unwind_stop_reason (SCM self)
 517 {
 518   frame_smob *f_smob;
 519   struct frame_info *frame = NULL;
 520   enum unwind_stop_reason stop_reason;
 521
 522   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 523
 524   try
 525     {
 526       frame = frscm_frame_smob_to_frame (f_smob);
 527     }
 528   catch (const gdb_exception &except)
 529     {
 530       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 531     }
 532
 533   if (frame == NULL)
 534     {
 535       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 536                                    _("<gdb:frame>"));
 537     }
 538
 539   stop_reason = get_frame_unwind_stop_reason (frame);
 540
 541   return scm_from_int (stop_reason);
 542 }
 543
 544 /* (frame-pc <gdb:frame>) -> integer
 545    Returns the frame's resume address.  */
 546
 547 static SCM
 548 gdbscm_frame_pc (SCM self)
 549 {
 550   frame_smob *f_smob;
 551   CORE_ADDR pc = 0;
 552   struct frame_info *frame = NULL;
 553
 554   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 555
 556   try
 557     {
 558       frame = frscm_frame_smob_to_frame (f_smob);
 559       if (frame != NULL)
 560         pc = get_frame_pc (frame);
 561     }
 562   catch (const gdb_exception &except)
 563     {
 564       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 565     }
 566
 567   if (frame == NULL)
 568     {
 569       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 570                                    _("<gdb:frame>"));
 571     }
 572
 573   return gdbscm_scm_from_ulongest (pc);
 574 }
 575
 576 /* (frame-block <gdb:frame>) -> <gdb:block>
 577    Returns the frame's code block, or #f if one cannot be found.  */
 578
 579 static SCM
 580 gdbscm_frame_block (SCM self)
 581 {
 582   frame_smob *f_smob;
 583   const struct block *block = NULL, *fn_block;
 584   struct frame_info *frame = NULL;
 585
 586   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 587
 588   try
 589     {
 590       frame = frscm_frame_smob_to_frame (f_smob);
 591       if (frame != NULL)
 592         block = get_frame_block (frame, NULL);
 593     }
 594   catch (const gdb_exception &except)
 595     {
 596       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 597     }
 598
 599   if (frame == NULL)
 600     {
 601       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 602                                    _("<gdb:frame>"));
 603     }
 604
 605   for (fn_block = block;
 606        fn_block != NULL && BLOCK_FUNCTION (fn_block) == NULL;
 607        fn_block = BLOCK_SUPERBLOCK (fn_block))
 608     continue;
 609
 610   if (block == NULL || fn_block == NULL || BLOCK_FUNCTION (fn_block) == NULL)
 611     {
 612       scm_misc_error (FUNC_NAME, _("cannot find block for frame"),
 613                       scm_list_1 (self));
 614     }
 615
 616   if (block != NULL)
 617     {
 618       return bkscm_scm_from_block
 619         (block, symbol_objfile (BLOCK_FUNCTION (fn_block)));
 620     }
 621
 622   return SCM_BOOL_F;
 623 }
 624
 625 /* (frame-function <gdb:frame>) -> <gdb:symbol>
 626    Returns the symbol for the function corresponding to this frame,
 627    or #f if there isn't one.  */
 628
 629 static SCM
 630 gdbscm_frame_function (SCM self)
 631 {
 632   frame_smob *f_smob;
 633   struct symbol *sym = NULL;
 634   struct frame_info *frame = NULL;
 635
 636   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 637
 638   try
 639     {
 640       frame = frscm_frame_smob_to_frame (f_smob);
 641       if (frame != NULL)
 642         sym = find_pc_function (get_frame_address_in_block (frame));
 643     }
 644   catch (const gdb_exception &except)
 645     {
 646       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 647     }
 648
 649   if (frame == NULL)
 650     {
 651       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 652                                    _("<gdb:frame>"));
 653     }
 654
 655   if (sym != NULL)
 656     return syscm_scm_from_symbol (sym);
 657
 658   return SCM_BOOL_F;
 659 }
 660
 661 /* (frame-older <gdb:frame>) -> <gdb:frame>
 662    Returns the frame immediately older (outer) to this frame,
 663    or #f if there isn't one.  */
 664
 665 static SCM
 666 gdbscm_frame_older (SCM self)
 667 {
 668   frame_smob *f_smob;
 669   struct frame_info *prev = NULL;
 670   struct frame_info *frame = NULL;
 671
 672   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 673
 674   try
 675     {
 676       frame = frscm_frame_smob_to_frame (f_smob);
 677       if (frame != NULL)
 678         prev = get_prev_frame (frame);
 679     }
 680   catch (const gdb_exception &except)
 681     {
 682       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 683     }
 684
 685   if (frame == NULL)
 686     {
 687       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 688                                    _("<gdb:frame>"));
 689     }
 690
 691   if (prev != NULL)
 692     return frscm_scm_from_frame_unsafe (prev, f_smob->inferior);
 693
 694   return SCM_BOOL_F;
 695 }
 696
 697 /* (frame-newer <gdb:frame>) -> <gdb:frame>
 698    Returns the frame immediately newer (inner) to this frame,
 699    or #f if there isn't one.  */
 700
 701 static SCM
 702 gdbscm_frame_newer (SCM self)
 703 {
 704   frame_smob *f_smob;
 705   struct frame_info *next = NULL;
 706   struct frame_info *frame = NULL;
 707
 708   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 709
 710   try
 711     {
 712       frame = frscm_frame_smob_to_frame (f_smob);
 713       if (frame != NULL)
 714         next = get_next_frame (frame);
 715     }
 716   catch (const gdb_exception &except)
 717     {
 718       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 719     }
 720
 721   if (frame == NULL)
 722     {
 723       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 724                                    _("<gdb:frame>"));
 725     }
 726
 727   if (next != NULL)
 728     return frscm_scm_from_frame_unsafe (next, f_smob->inferior);
 729
 730   return SCM_BOOL_F;
 731 }
 732
 733 /* (frame-sal <gdb:frame>) -> <gdb:sal>
 734    Returns the frame's symtab and line.  */
 735
 736 static SCM
 737 gdbscm_frame_sal (SCM self)
 738 {
 739   frame_smob *f_smob;
 740   struct symtab_and_line sal;
 741   struct frame_info *frame = NULL;
 742
 743   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 744
 745   try
 746     {
 747       frame = frscm_frame_smob_to_frame (f_smob);
 748       if (frame != NULL)
 749         sal = find_frame_sal (frame);
 750     }
 751   catch (const gdb_exception &except)
 752     {
 753       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 754     }
 755
 756   if (frame == NULL)
 757     {
 758       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 759                                    _("<gdb:frame>"));
 760     }
 761
 762   return stscm_scm_from_sal (sal);
 763 }
 764
 765 /* (frame-read-register <gdb:frame> string) -> <gdb:value>
 766    The register argument must be a string.  */
 767
 768 static SCM
 769 gdbscm_frame_read_register (SCM self, SCM register_scm)
 770 {
 771   char *register_str;
 772   struct value *value = NULL;
 773   struct frame_info *frame = NULL;
 774   frame_smob *f_smob;
 775
 776   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 777   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, NULL, "s",
 778                               register_scm, &register_str);
 779
 780   struct gdb_exception except = exception_none;
 781
 782   try
 783     {
 784       int regnum;
 785
 786       frame = frscm_frame_smob_to_frame (f_smob);
 787       if (frame)
 788         {
 789           regnum = user_reg_map_name_to_regnum (get_frame_arch (frame),
 790                                                 register_str,
 791                                                 strlen (register_str));
 792           if (regnum >= 0)
 793             value = value_of_register (regnum, frame);
 794         }
 795     }
 796   catch (const gdb_exception &ex)
 797     {
 798       except = ex;
 799     }
 800
 801   xfree (register_str);
 802   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 803
 804   if (frame == NULL)
 805     {
 806       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 807                                    _("<gdb:frame>"));
 808     }
 809
 810   if (value == NULL)
 811     {
 812       gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, register_scm,
 813                                  _("unknown register"));
 814     }
 815
 816   return vlscm_scm_from_value (value);
 817 }
 818
 819 /* (frame-read-var <gdb:frame> <gdb:symbol>) -> <gdb:value>
 820    (frame-read-var <gdb:frame> string [#:block <gdb:block>]) -> <gdb:value>
 821    If the optional block argument is provided start the search from that block,
 822    otherwise search from the frame's current block (determined by examining
 823    the resume address of the frame).  The variable argument must be a string
 824    or an instance of a <gdb:symbol>.  The block argument must be an instance of
 825    <gdb:block>.  */
 826
 827 static SCM
 828 gdbscm_frame_read_var (SCM self, SCM symbol_scm, SCM rest)
 829 {
 830   SCM keywords[] = { block_keyword, SCM_BOOL_F };
 831   frame_smob *f_smob;
 832   int block_arg_pos = -1;
 833   SCM block_scm = SCM_UNDEFINED;
 834   struct frame_info *frame = NULL;
 835   struct symbol *var = NULL;
 836   const struct block *block = NULL;
 837   struct value *value = NULL;
 838
 839   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 840
 841   try
 842     {
 843       frame = frscm_frame_smob_to_frame (f_smob);
 844     }
 845   catch (const gdb_exception &except)
 846     {
 847       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 848     }
 849
 850   if (frame == NULL)
 851     {
 852       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 853                                    _("<gdb:frame>"));
 854     }
 855
 856   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG3, keywords, "#O",
 857                               rest, &block_arg_pos, &block_scm);
 858
 859   if (syscm_is_symbol (symbol_scm))
 860     {
 861       var = syscm_get_valid_symbol_arg_unsafe (symbol_scm, SCM_ARG2,
 862                                                FUNC_NAME);
 863       SCM_ASSERT (SCM_UNBNDP (block_scm), block_scm, SCM_ARG3, FUNC_NAME);
 864     }
 865   else if (scm_is_string (symbol_scm))
 866     {
 867       struct gdb_exception except = exception_none;
 868
 869       if (! SCM_UNBNDP (block_scm))
 870         {
 871           SCM except_scm;
 872
 873           gdb_assert (block_arg_pos > 0);
 874           block = bkscm_scm_to_block (block_scm, block_arg_pos, FUNC_NAME,
 875                                       &except_scm);
 876           if (block == NULL)
 877             gdbscm_throw (except_scm);
 878         }
 879
 880       {
 881         gdb::unique_xmalloc_ptr<char> var_name
 882           (gdbscm_scm_to_c_string (symbol_scm));
 883         /* N.B. Between here and the end of the scope, don't do anything
 884            to cause a Scheme exception.  */
 885
 886         try
 887           {
 888             struct block_symbol lookup_sym;
 889
 890             if (block == NULL)
 891               block = get_frame_block (frame, NULL);
 892             lookup_sym = lookup_symbol (var_name.get (), block, VAR_DOMAIN,
 893                                         NULL);
 894             var = lookup_sym.symbol;
 895             block = lookup_sym.block;
 896           }
 897         catch (const gdb_exception &ex)
 898           {
 899             except = ex;
 900           }
 901       }
 902
 903       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 904
 905       if (var == NULL)
 906         gdbscm_out_of_range_error (FUNC_NAME, 0, symbol_scm,
 907                                    _("variable not found"));
 908     }
 909   else
 910     {
 911       /* Use SCM_ASSERT_TYPE for more consistent error messages.  */
 912       SCM_ASSERT_TYPE (0, symbol_scm, SCM_ARG1, FUNC_NAME,
 913                        _("gdb:symbol or string"));
 914     }
 915
 916   try
 917     {
 918       value = read_var_value (var, block, frame);
 919     }
 920   catch (const gdb_exception &except)
 921     {
 922       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 923     }
 924
 925   return vlscm_scm_from_value (value);
 926 }
 927
 928 /* (frame-select <gdb:frame>) -> unspecified
 929    Select this frame.  */
 930
 931 static SCM
 932 gdbscm_frame_select (SCM self)
 933 {
 934   frame_smob *f_smob;
 935   struct frame_info *frame = NULL;
 936
 937   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 938
 939   try
 940     {
 941       frame = frscm_frame_smob_to_frame (f_smob);
 942       if (frame != NULL)
 943         select_frame (frame);
 944     }
 945   catch (const gdb_exception &except)
 946     {
 947       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 948     }
 949
 950   if (frame == NULL)
 951     {
 952       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 953                                    _("<gdb:frame>"));
 954     }
 955
 956   return SCM_UNSPECIFIED;
 957 }
 958
 959 /* (newest-frame) -> <gdb:frame>
 960    Returns the newest frame.  */
 961
 962 static SCM
 963 gdbscm_newest_frame (void)
 964 {
 965   struct frame_info *frame = NULL;
 966
 967   try
 968     {
 969       frame = get_current_frame ();
 970     }
 971   catch (const gdb_exception &except)
 972     {
 973       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 974     }
 975
 976   return frscm_scm_from_frame_unsafe (frame, current_inferior ());
 977 }
 978
 979 /* (selected-frame) -> <gdb:frame>
 980    Returns the selected frame.  */
 981
 982 static SCM
 983 gdbscm_selected_frame (void)
 984 {
 985   struct frame_info *frame = NULL;
 986
 987   try
 988     {
 989       frame = get_selected_frame (_("No frame is currently selected"));
 990     }
 991   catch (const gdb_exception &except)
 992     {
 993       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 994     }
 995
 996   return frscm_scm_from_frame_unsafe (frame, current_inferior ());
 997 }
 998
 999 /* (unwind-stop-reason-string integer) -> string
1000    Return a string explaining the unwind stop reason.  */
1001
1002 static SCM
1003 gdbscm_unwind_stop_reason_string (SCM reason_scm)
1004 {
1005   int reason;
1006   const char *str;
1007
1008   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "i",
1009                               reason_scm, &reason);
1010
1011   if (reason < UNWIND_FIRST || reason > UNWIND_LAST)
1012     scm_out_of_range (FUNC_NAME, reason_scm);
1013
1014   str = unwind_stop_reason_to_string ((enum unwind_stop_reason) reason);
1015   return gdbscm_scm_from_c_string (str);
1016 }
1017 \f
1018 /* Initialize the Scheme frame support.  */
1019
1020 static const scheme_integer_constant frame_integer_constants[] =
1021 {
1022 #define ENTRY(X) { #X, X }
1023
1024   ENTRY (NORMAL_FRAME),
1025   ENTRY (DUMMY_FRAME),
1026   ENTRY (INLINE_FRAME),
1027   ENTRY (TAILCALL_FRAME),
1028   ENTRY (SIGTRAMP_FRAME),
1029   ENTRY (ARCH_FRAME),
1030   ENTRY (SENTINEL_FRAME),
1031
1032 #undef ENTRY
1033
1034 #define SET(name, description) \
1035   { "FRAME_" #name, name },
1036 #include "unwind_stop_reasons.def"
1037 #undef SET
1038
1039   END_INTEGER_CONSTANTS
1040 };
1041
1042 static const scheme_function frame_functions[] =
1043 {
1044   { "frame?", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_p),
1045     "\
1046 Return #t if the object is a <gdb:frame> object." },
1047
1048   { "frame-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_valid_p),
1049     "\
1050 Return #t if the object is a valid <gdb:frame> object.\n\
1051 Frames become invalid when the inferior returns to its caller." },
1052
1053   { "frame-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_name),
1054     "\
1055 Return the name of the function corresponding to this frame,\n\
1056 or #f if there is no function." },
1057
1058   { "frame-arch", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_arch),
1059     "\
1060 Return the frame's architecture as a <gdb:arch> object." },
1061
1062   { "frame-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_type),
1063     "\
1064 Return the frame type, namely one of the gdb:*_FRAME constants." },
1065
1066   { "frame-unwind-stop-reason", 1, 0, 0,
1067     as_a_scm_t_subr (gdbscm_frame_unwind_stop_reason),
1068     "\
1069 Return one of the gdb:FRAME_UNWIND_* constants explaining why\n\
1070 it's not possible to find frames older than this." },
1071
1072   { "frame-pc", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_pc),
1073     "\
1074 Return the frame's resume address." },
1075
1076   { "frame-block", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_block),
1077     "\
1078 Return the frame's code block, or #f if one cannot be found." },
1079
1080   { "frame-function", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_function),
1081     "\
1082 Return the <gdb:symbol> for the function corresponding to this frame,\n\
1083 or #f if there isn't one." },
1084
1085   { "frame-older", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_older),
1086     "\
1087 Return the frame immediately older (outer) to this frame,\n\
1088 or #f if there isn't one." },
1089
1090   { "frame-newer", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_newer),
1091     "\
1092 Return the frame immediately newer (inner) to this frame,\n\
1093 or #f if there isn't one." },
1094
1095   { "frame-sal", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_sal),
1096     "\
1097 Return the frame's symtab-and-line <gdb:sal> object." },
1098
1099   { "frame-read-var", 2, 0, 1, as_a_scm_t_subr (gdbscm_frame_read_var),
1100     "\
1101 Return the value of the symbol in the frame.\n\
1102 \n\
1103   Arguments: <gdb:frame> <gdb:symbol>\n\
1104          Or: <gdb:frame> string [#:block <gdb:block>]" },
1105
1106   { "frame-read-register", 2, 0, 0,
1107     as_a_scm_t_subr (gdbscm_frame_read_register),
1108     "\
1109 Return the value of the register in the frame.\n\
1110 \n\
1111   Arguments: <gdb:frame> string" },
1112
1113   { "frame-select", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_select),
1114     "\
1115 Select this frame." },
1116
1117   { "newest-frame", 0, 0, 0, as_a_scm_t_subr (gdbscm_newest_frame),
1118     "\
1119 Return the newest frame." },
1120
1121   { "selected-frame", 0, 0, 0, as_a_scm_t_subr (gdbscm_selected_frame),
1122     "\
1123 Return the selected frame." },
1124
1125   { "unwind-stop-reason-string", 1, 0, 0,
1126     as_a_scm_t_subr (gdbscm_unwind_stop_reason_string),
1127     "\
1128 Return a string explaining the unwind stop reason.\n\
1129 \n\
1130   Arguments: integer (the result of frame-unwind-stop-reason)" },
1131
1132   END_FUNCTIONS
1133 };
1134
1135 void
1136 gdbscm_initialize_frames (void)
1137 {
1138   frame_smob_tag
1139     = gdbscm_make_smob_type (frame_smob_name, sizeof (frame_smob));
1140   scm_set_smob_free (frame_smob_tag, frscm_free_frame_smob);
1141   scm_set_smob_print (frame_smob_tag, frscm_print_frame_smob);
1142
1143   gdbscm_define_integer_constants (frame_integer_constants, 1);
1144   gdbscm_define_functions (frame_functions, 1);
1145
1146   block_keyword = scm_from_latin1_keyword ("block");
1147
1148   /* Register an inferior "free" callback so we can properly
1149      invalidate frames when an inferior file is about to be deleted.  */
1150   frscm_inferior_data_key
1151     = register_inferior_data_with_cleanup (NULL, frscm_del_inferior_frames);
1152 }