gdb/guile/scm-frame.c

   1 /* Scheme interface to stack frames.
   2
   3    Copyright (C) 2008-2014 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 "exceptions.h"
  27 #include "inferior.h"
  28 #include "objfiles.h"
  29 #include "symfile.h"
  30 #include "symtab.h"
  31 #include "stack.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 = 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 = ap;
 108   const frame_smob *b = 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 = 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   struct ui_file *strfile;
 160   char *s;
 161
 162   gdbscm_printf (port, "#<%s ", frame_smob_name);
 163
 164   strfile = mem_fileopen ();
 165   fprint_frame_id (strfile, f_smob->frame_id);
 166   s = ui_file_xstrdup (strfile, NULL);
 167   gdbscm_printf (port, "%s", s);
 168   ui_file_delete (strfile);
 169   xfree (s);
 170
 171   scm_puts (">", port);
 172
 173   scm_remember_upto_here_1 (self);
 174
 175   /* Non-zero means success.  */
 176   return 1;
 177 }
 178
 179 /* Low level routine to create a <gdb:frame> object.  */
 180
 181 static SCM
 182 frscm_make_frame_smob (void)
 183 {
 184   frame_smob *f_smob = (frame_smob *)
 185     scm_gc_malloc (sizeof (frame_smob), frame_smob_name);
 186   SCM f_scm;
 187
 188   f_smob->frame_id = null_frame_id;
 189   f_smob->gdbarch = NULL;
 190   f_smob->inferior = NULL;
 191   f_smob->frame_id_is_next = 0;
 192   f_scm = scm_new_smob (frame_smob_tag, (scm_t_bits) f_smob);
 193   gdbscm_init_eqable_gsmob (&f_smob->base, f_scm);
 194
 195   return f_scm;
 196 }
 197
 198 /* Return non-zero if SCM is a <gdb:frame> object.  */
 199
 200 int
 201 frscm_is_frame (SCM scm)
 202 {
 203   return SCM_SMOB_PREDICATE (frame_smob_tag, scm);
 204 }
 205
 206 /* (frame? object) -> boolean */
 207
 208 static SCM
 209 gdbscm_frame_p (SCM scm)
 210 {
 211   return scm_from_bool (frscm_is_frame (scm));
 212 }
 213
 214 /* Create a new <gdb:frame> object that encapsulates FRAME.
 215    Returns a <gdb:exception> object if there is an error.  */
 216
 217 static SCM
 218 frscm_scm_from_frame (struct frame_info *frame, struct inferior *inferior)
 219 {
 220   frame_smob *f_smob, f_smob_for_lookup;
 221   SCM f_scm;
 222   htab_t htab;
 223   eqable_gdb_smob **slot;
 224   volatile struct gdb_exception except;
 225   struct frame_id frame_id = null_frame_id;
 226   struct gdbarch *gdbarch = NULL;
 227   int frame_id_is_next = 0;
 228
 229   /* If we've already created a gsmob for this frame, return it.
 230      This makes frames eq?-able.  */
 231   htab = frscm_inferior_frame_map (inferior);
 232   f_smob_for_lookup.frame_id = get_frame_id (frame);
 233   f_smob_for_lookup.inferior = inferior;
 234   slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &f_smob_for_lookup.base);
 235   if (*slot != NULL)
 236     return (*slot)->containing_scm;
 237
 238   TRY_CATCH (except, RETURN_MASK_ALL)
 239     {
 240       /* Try to get the previous frame, to determine if this is the last frame
 241          in a corrupt stack.  If so, we need to store the frame_id of the next
 242          frame and not of this one (which is possibly invalid).  */
 243       if (get_prev_frame (frame) == NULL
 244           && get_frame_unwind_stop_reason (frame) != UNWIND_NO_REASON
 245           && get_next_frame (frame) != NULL)
 246         {
 247           frame_id = get_frame_id (get_next_frame (frame));
 248           frame_id_is_next = 1;
 249         }
 250       else
 251         {
 252           frame_id = get_frame_id (frame);
 253           frame_id_is_next = 0;
 254         }
 255       gdbarch = get_frame_arch (frame);
 256     }
 257   if (except.reason < 0)
 258     return gdbscm_scm_from_gdb_exception (except);
 259
 260   f_scm = frscm_make_frame_smob ();
 261   f_smob = (frame_smob *) SCM_SMOB_DATA (f_scm);
 262   f_smob->frame_id = frame_id;
 263   f_smob->gdbarch = gdbarch;
 264   f_smob->inferior = inferior;
 265   f_smob->frame_id_is_next = frame_id_is_next;
 266
 267   gdbscm_fill_eqable_gsmob_ptr_slot (slot, &f_smob->base);
 268
 269   return f_scm;
 270 }
 271
 272 /* Create a new <gdb:frame> object that encapsulates FRAME.
 273    A Scheme exception is thrown if there is an error.  */
 274
 275 static SCM
 276 frscm_scm_from_frame_unsafe (struct frame_info *frame,
 277                              struct inferior *inferior)
 278 {
 279   SCM f_scm = frscm_scm_from_frame (frame, inferior);
 280
 281   if (gdbscm_is_exception (f_scm))
 282     gdbscm_throw (f_scm);
 283
 284   return f_scm;
 285 }
 286
 287 /* Returns the <gdb:frame> object in SELF.
 288    Throws an exception if SELF is not a <gdb:frame> object.  */
 289
 290 static SCM
 291 frscm_get_frame_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 292 {
 293   SCM_ASSERT_TYPE (frscm_is_frame (self), self, arg_pos, func_name,
 294                    frame_smob_name);
 295
 296   return self;
 297 }
 298
 299 /* There is no gdbscm_scm_to_frame function because translating
 300    a frame SCM object to a struct frame_info * can throw a GDB error.
 301    Thus code working with frames has to handle both Scheme errors (e.g., the
 302    object is not a frame) and GDB errors (e.g., the frame lookup failed).
 303
 304    To help keep things clear we split gdbscm_scm_to_frame into two:
 305
 306    gdbscm_get_frame_smob_arg_unsafe
 307      - throws a Scheme error if object is not a frame,
 308        or if the inferior is gone or is no longer current
 309
 310    gdbscm_frame_smob_to_frame
 311      - may throw a gdb error if the conversion fails
 312      - it's not clear when it will and won't throw a GDB error,
 313        but for robustness' sake we assume that whenever we call out to GDB
 314        a GDB error may get thrown (and thus the call must be wrapped in a
 315        TRY_CATCH)  */
 316
 317 /* Returns the frame_smob for the object wrapped by FRAME_SCM.
 318    A Scheme error is thrown if FRAME_SCM is not a frame.  */
 319
 320 frame_smob *
 321 frscm_get_frame_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 322 {
 323   SCM f_scm = frscm_get_frame_arg_unsafe (self, arg_pos, func_name);
 324   frame_smob *f_smob = (frame_smob *) SCM_SMOB_DATA (f_scm);
 325
 326   if (f_smob->inferior == NULL)
 327     {
 328       gdbscm_invalid_object_error (func_name, arg_pos, self,
 329                                    _("inferior"));
 330     }
 331   if (f_smob->inferior != current_inferior ())
 332     scm_misc_error (func_name, _("inferior has changed"), SCM_EOL);
 333
 334   return f_smob;
 335 }
 336
 337 /* Returns the frame_info object wrapped by F_SMOB.
 338    If the frame doesn't exist anymore (the frame id doesn't
 339    correspond to any frame in the inferior), returns NULL.
 340    This function calls GDB routines, so don't assume a GDB error will
 341    not be thrown.  */
 342
 343 struct frame_info *
 344 frscm_frame_smob_to_frame (frame_smob *f_smob)
 345 {
 346   struct frame_info *frame;
 347
 348   frame = frame_find_by_id (f_smob->frame_id);
 349   if (frame == NULL)
 350     return NULL;
 351
 352   if (f_smob->frame_id_is_next)
 353     frame = get_prev_frame (frame);
 354
 355   return frame;
 356 }
 357
 358 /* Helper function for frscm_del_inferior_frames to mark the frame
 359    as invalid.  */
 360
 361 static int
 362 frscm_mark_frame_invalid (void **slot, void *info)
 363 {
 364   frame_smob *f_smob = (frame_smob *) *slot;
 365
 366   f_smob->inferior = NULL;
 367   return 1;
 368 }
 369
 370 /* This function is called when an inferior is about to be freed.
 371    Invalidate the frame as further actions on the frame could result
 372    in bad data.  All access to the frame should be gated by
 373    frscm_get_frame_smob_arg_unsafe which will raise an exception on
 374    invalid frames.  */
 375
 376 static void
 377 frscm_del_inferior_frames (struct inferior *inferior, void *datum)
 378 {
 379   htab_t htab = datum;
 380
 381   if (htab != NULL)
 382     {
 383       htab_traverse_noresize (htab, frscm_mark_frame_invalid, NULL);
 384       htab_delete (htab);
 385     }
 386 }
 387 \f
 388 /* Frame methods.  */
 389
 390 /* (frame-valid? <gdb:frame>) -> bool
 391    Returns #t if the frame corresponding to the frame_id of this
 392    object still exists in the inferior.  */
 393
 394 static SCM
 395 gdbscm_frame_valid_p (SCM self)
 396 {
 397   frame_smob *f_smob;
 398   struct frame_info *frame = NULL;
 399   volatile struct gdb_exception except;
 400
 401   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 402
 403   TRY_CATCH (except, RETURN_MASK_ALL)
 404     {
 405       frame = frscm_frame_smob_to_frame (f_smob);
 406     }
 407   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 408
 409   return scm_from_bool (frame != NULL);
 410 }
 411
 412 /* (frame-name <gdb:frame>) -> string
 413    Returns the name of the function corresponding to this frame,
 414    or #f if there is no function.  */
 415
 416 static SCM
 417 gdbscm_frame_name (SCM self)
 418 {
 419   frame_smob *f_smob;
 420   char *name = NULL;
 421   enum language lang = language_minimal;
 422   struct frame_info *frame = NULL;
 423   SCM result;
 424   volatile struct gdb_exception except;
 425
 426   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 427
 428   TRY_CATCH (except, RETURN_MASK_ALL)
 429     {
 430       frame = frscm_frame_smob_to_frame (f_smob);
 431       if (frame != NULL)
 432         find_frame_funname (frame, &name, &lang, NULL);
 433     }
 434   if (except.reason < 0)
 435     xfree (name);
 436   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 437
 438   if (frame == NULL)
 439     {
 440       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 441                                    _("<gdb:frame>"));
 442     }
 443
 444   if (name != NULL)
 445     {
 446       result = gdbscm_scm_from_c_string (name);
 447       xfree (name);
 448     }
 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   volatile struct gdb_exception except;
 465
 466   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 467
 468   TRY_CATCH (except, RETURN_MASK_ALL)
 469     {
 470       frame = frscm_frame_smob_to_frame (f_smob);
 471       if (frame != NULL)
 472         type = get_frame_type (frame);
 473     }
 474   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 475
 476   if (frame == NULL)
 477     {
 478       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 479                                    _("<gdb:frame>"));
 480     }
 481
 482   return scm_from_int (type);
 483 }
 484
 485 /* (frame-arch <gdb:frame>) -> <gdb:architecture>
 486    Returns the frame's architecture as a gdb:architecture object.  */
 487
 488 static SCM
 489 gdbscm_frame_arch (SCM self)
 490 {
 491   frame_smob *f_smob;
 492   struct frame_info *frame = NULL;
 493   volatile struct gdb_exception except;
 494
 495   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 496
 497   TRY_CATCH (except, RETURN_MASK_ALL)
 498     {
 499       frame = frscm_frame_smob_to_frame (f_smob);
 500     }
 501   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 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   volatile struct gdb_exception except;
 521   enum unwind_stop_reason stop_reason;
 522
 523   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 524
 525   TRY_CATCH (except, RETURN_MASK_ALL)
 526     {
 527       frame = frscm_frame_smob_to_frame (f_smob);
 528     }
 529   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 530
 531   if (frame == NULL)
 532     {
 533       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 534                                    _("<gdb:frame>"));
 535     }
 536
 537   stop_reason = get_frame_unwind_stop_reason (frame);
 538
 539   return scm_from_int (stop_reason);
 540 }
 541
 542 /* (frame-pc <gdb:frame>) -> integer
 543    Returns the frame's resume address.  */
 544
 545 static SCM
 546 gdbscm_frame_pc (SCM self)
 547 {
 548   frame_smob *f_smob;
 549   CORE_ADDR pc = 0;
 550   struct frame_info *frame = NULL;
 551   volatile struct gdb_exception except;
 552
 553   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 554
 555   TRY_CATCH (except, RETURN_MASK_ALL)
 556     {
 557       frame = frscm_frame_smob_to_frame (f_smob);
 558       if (frame != NULL)
 559         pc = get_frame_pc (frame);
 560     }
 561   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 562
 563   if (frame == NULL)
 564     {
 565       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 566                                    _("<gdb:frame>"));
 567     }
 568
 569   return gdbscm_scm_from_ulongest (pc);
 570 }
 571
 572 /* (frame-block <gdb:frame>) -> <gdb:block>
 573    Returns the frame's code block, or #f if one cannot be found.  */
 574
 575 static SCM
 576 gdbscm_frame_block (SCM self)
 577 {
 578   frame_smob *f_smob;
 579   struct block *block = NULL, *fn_block;
 580   struct frame_info *frame = NULL;
 581   volatile struct gdb_exception except;
 582
 583   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 584
 585   TRY_CATCH (except, RETURN_MASK_ALL)
 586     {
 587       frame = frscm_frame_smob_to_frame (f_smob);
 588       if (frame != NULL)
 589         block = get_frame_block (frame, NULL);
 590     }
 591   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 592
 593   if (frame == NULL)
 594     {
 595       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 596                                    _("<gdb:frame>"));
 597     }
 598
 599   for (fn_block = block;
 600        fn_block != NULL && BLOCK_FUNCTION (fn_block) == NULL;
 601        fn_block = BLOCK_SUPERBLOCK (fn_block))
 602     continue;
 603
 604   if (block == NULL || fn_block == NULL || BLOCK_FUNCTION (fn_block) == NULL)
 605     {
 606       scm_misc_error (FUNC_NAME, _("cannot find block for frame"),
 607                       scm_list_1 (self));
 608     }
 609
 610   if (block != NULL)
 611     {
 612       struct symtab *st;
 613       SCM block_scm;
 614
 615       st = SYMBOL_SYMTAB (BLOCK_FUNCTION (fn_block));
 616       return bkscm_scm_from_block (block, st->objfile);
 617     }
 618
 619   return SCM_BOOL_F;
 620 }
 621
 622 /* (frame-function <gdb:frame>) -> <gdb:symbol>
 623    Returns the symbol for the function corresponding to this frame,
 624    or #f if there isn't one.  */
 625
 626 static SCM
 627 gdbscm_frame_function (SCM self)
 628 {
 629   frame_smob *f_smob;
 630   struct symbol *sym = NULL;
 631   struct frame_info *frame = NULL;
 632   volatile struct gdb_exception except;
 633
 634   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 635
 636   TRY_CATCH (except, RETURN_MASK_ALL)
 637     {
 638       frame = frscm_frame_smob_to_frame (f_smob);
 639       if (frame != NULL)
 640         sym = find_pc_function (get_frame_address_in_block (frame));
 641     }
 642   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 643
 644   if (frame == NULL)
 645     {
 646       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 647                                    _("<gdb:frame>"));
 648     }
 649
 650   if (sym != NULL)
 651     return syscm_scm_from_symbol (sym);
 652
 653   return SCM_BOOL_F;
 654 }
 655
 656 /* (frame-older <gdb:frame>) -> <gdb:frame>
 657    Returns the frame immediately older (outer) to this frame,
 658    or #f if there isn't one.  */
 659
 660 static SCM
 661 gdbscm_frame_older (SCM self)
 662 {
 663   frame_smob *f_smob;
 664   struct frame_info *prev = NULL;
 665   struct frame_info *frame = NULL;
 666   volatile struct gdb_exception except;
 667
 668   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 669
 670   TRY_CATCH (except, RETURN_MASK_ALL)
 671     {
 672       frame = frscm_frame_smob_to_frame (f_smob);
 673       if (frame != NULL)
 674         prev = get_prev_frame (frame);
 675     }
 676   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 677
 678   if (frame == NULL)
 679     {
 680       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 681                                    _("<gdb:frame>"));
 682     }
 683
 684   if (prev != NULL)
 685     return frscm_scm_from_frame_unsafe (prev, f_smob->inferior);
 686
 687   return SCM_BOOL_F;
 688 }
 689
 690 /* (frame-newer <gdb:frame>) -> <gdb:frame>
 691    Returns the frame immediately newer (inner) to this frame,
 692    or #f if there isn't one.  */
 693
 694 static SCM
 695 gdbscm_frame_newer (SCM self)
 696 {
 697   frame_smob *f_smob;
 698   struct frame_info *next = NULL;
 699   struct frame_info *frame = NULL;
 700   volatile struct gdb_exception except;
 701
 702   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 703
 704   TRY_CATCH (except, RETURN_MASK_ALL)
 705     {
 706       frame = frscm_frame_smob_to_frame (f_smob);
 707       if (frame != NULL)
 708         next = get_next_frame (frame);
 709     }
 710   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 711
 712   if (frame == NULL)
 713     {
 714       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 715                                    _("<gdb:frame>"));
 716     }
 717
 718   if (next != NULL)
 719     return frscm_scm_from_frame_unsafe (next, f_smob->inferior);
 720
 721   return SCM_BOOL_F;
 722 }
 723
 724 /* (frame-sal <gdb:frame>) -> <gdb:sal>
 725    Returns the frame's symtab and line.  */
 726
 727 static SCM
 728 gdbscm_frame_sal (SCM self)
 729 {
 730   frame_smob *f_smob;
 731   struct symtab_and_line sal;
 732   struct frame_info *frame = NULL;
 733   volatile struct gdb_exception except;
 734
 735   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 736
 737   TRY_CATCH (except, RETURN_MASK_ALL)
 738     {
 739       frame = frscm_frame_smob_to_frame (f_smob);
 740       if (frame != NULL)
 741         find_frame_sal (frame, &sal);
 742     }
 743   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 744
 745   if (frame == NULL)
 746     {
 747       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 748                                    _("<gdb:frame>"));
 749     }
 750
 751   return stscm_scm_from_sal (sal);
 752 }
 753
 754 /* (frame-read-var <gdb:frame> <gdb:symbol>) -> <gdb:value>
 755    (frame-read-var <gdb:frame> string [#:block <gdb:block>]) -> <gdb:value>
 756    If the optional block argument is provided start the search from that block,
 757    otherwise search from the frame's current block (determined by examining
 758    the resume address of the frame).  The variable argument must be a string
 759    or an instance of a <gdb:symbol>.  The block argument must be an instance of
 760    <gdb:block>.  */
 761
 762 static SCM
 763 gdbscm_frame_read_var (SCM self, SCM symbol_scm, SCM rest)
 764 {
 765   SCM keywords[] = { block_keyword, SCM_BOOL_F };
 766   int rc;
 767   frame_smob *f_smob;
 768   int block_arg_pos = -1;
 769   SCM block_scm = SCM_UNDEFINED;
 770   struct frame_info *frame = NULL;
 771   struct symbol *var = NULL;
 772   struct value *value = NULL;
 773   volatile struct gdb_exception except;
 774
 775   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 776
 777   TRY_CATCH (except, RETURN_MASK_ALL)
 778     {
 779       frame = frscm_frame_smob_to_frame (f_smob);
 780     }
 781   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 782
 783   if (frame == NULL)
 784     {
 785       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 786                                    _("<gdb:frame>"));
 787     }
 788
 789   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG3, keywords, "#O",
 790                               rest, &block_arg_pos, &block_scm);
 791
 792   if (syscm_is_symbol (symbol_scm))
 793     {
 794       var = syscm_get_valid_symbol_arg_unsafe (symbol_scm, SCM_ARG2,
 795                                                FUNC_NAME);
 796       SCM_ASSERT (SCM_UNBNDP (block_scm), block_scm, SCM_ARG3, FUNC_NAME);
 797     }
 798   else if (scm_is_string (symbol_scm))
 799     {
 800       char *var_name;
 801       const struct block *block = NULL;
 802       struct cleanup *cleanup;
 803       volatile struct gdb_exception except;
 804
 805       if (! SCM_UNBNDP (block_scm))
 806         {
 807           SCM except_scm;
 808
 809           gdb_assert (block_arg_pos > 0);
 810           block = bkscm_scm_to_block (block_scm, block_arg_pos, FUNC_NAME,
 811                                       &except_scm);
 812           if (block == NULL)
 813             gdbscm_throw (except_scm);
 814         }
 815
 816       var_name = gdbscm_scm_to_c_string (symbol_scm);
 817       cleanup = make_cleanup (xfree, var_name);
 818       /* N.B. Between here and the call to do_cleanups, don't do anything
 819          to cause a Scheme exception without performing the cleanup.  */
 820
 821       TRY_CATCH (except, RETURN_MASK_ALL)
 822         {
 823           if (block == NULL)
 824             block = get_frame_block (frame, NULL);
 825           var = lookup_symbol (var_name, block, VAR_DOMAIN, NULL);
 826         }
 827       if (except.reason < 0)
 828         do_cleanups (cleanup);
 829       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 830
 831       if (var == NULL)
 832         {
 833           do_cleanups (cleanup);
 834           gdbscm_out_of_range_error (FUNC_NAME, 0, symbol_scm,
 835                                      _("variable not found"));
 836         }
 837
 838       do_cleanups (cleanup);
 839     }
 840   else
 841     {
 842       /* Use SCM_ASSERT_TYPE for more consistent error messages.  */
 843       SCM_ASSERT_TYPE (0, symbol_scm, SCM_ARG1, FUNC_NAME,
 844                        _("gdb:symbol or string"));
 845     }
 846
 847   TRY_CATCH (except, RETURN_MASK_ALL)
 848     {
 849       value = read_var_value (var, frame);
 850     }
 851   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 852
 853   return vlscm_scm_from_value (value);
 854 }
 855
 856 /* (frame-select <gdb:frame>) -> unspecified
 857    Select this frame.  */
 858
 859 static SCM
 860 gdbscm_frame_select (SCM self)
 861 {
 862   frame_smob *f_smob;
 863   struct frame_info *frame = NULL;
 864   volatile struct gdb_exception except;
 865
 866   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 867
 868   TRY_CATCH (except, RETURN_MASK_ALL)
 869     {
 870       frame = frscm_frame_smob_to_frame (f_smob);
 871       if (frame != NULL)
 872         select_frame (frame);
 873     }
 874   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 875
 876   if (frame == NULL)
 877     {
 878       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 879                                    _("<gdb:frame>"));
 880     }
 881
 882   return SCM_UNSPECIFIED;
 883 }
 884
 885 /* (newest-frame) -> <gdb:frame>
 886    Returns the newest frame.  */
 887
 888 static SCM
 889 gdbscm_newest_frame (void)
 890 {
 891   struct frame_info *frame = NULL;
 892   volatile struct gdb_exception except;
 893
 894   TRY_CATCH (except, RETURN_MASK_ALL)
 895     {
 896       frame = get_current_frame ();
 897     }
 898   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 899
 900   return frscm_scm_from_frame_unsafe (frame, current_inferior ());
 901 }
 902
 903 /* (selected-frame) -> <gdb:frame>
 904    Returns the selected frame.  */
 905
 906 static SCM
 907 gdbscm_selected_frame (void)
 908 {
 909   struct frame_info *frame = NULL;
 910   volatile struct gdb_exception except;
 911
 912   TRY_CATCH (except, RETURN_MASK_ALL)
 913     {
 914       frame = get_selected_frame (_("No frame is currently selected"));
 915     }
 916   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 917
 918   return frscm_scm_from_frame_unsafe (frame, current_inferior ());
 919 }
 920
 921 /* (unwind-stop-reason-string integer) -> string
 922    Return a string explaining the unwind stop reason.  */
 923
 924 static SCM
 925 gdbscm_unwind_stop_reason_string (SCM reason_scm)
 926 {
 927   int reason;
 928   const char *str;
 929
 930   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "i",
 931                               reason_scm, &reason);
 932
 933   if (reason < UNWIND_FIRST || reason > UNWIND_LAST)
 934     scm_out_of_range (FUNC_NAME, reason_scm);
 935
 936   str = frame_stop_reason_string (reason);
 937   return gdbscm_scm_from_c_string (str);
 938 }
 939 \f
 940 /* Initialize the Scheme frame support.  */
 941
 942 static const scheme_integer_constant frame_integer_constants[] =
 943 {
 944 #define ENTRY(X) { #X, X }
 945
 946   ENTRY (NORMAL_FRAME),
 947   ENTRY (DUMMY_FRAME),
 948   ENTRY (INLINE_FRAME),
 949   ENTRY (TAILCALL_FRAME),
 950   ENTRY (SIGTRAMP_FRAME),
 951   ENTRY (ARCH_FRAME),
 952   ENTRY (SENTINEL_FRAME),
 953
 954 #undef ENTRY
 955
 956 #define SET(name, description) \
 957   { "FRAME_" #name, name },
 958 #include "unwind_stop_reasons.def"
 959 #undef SET
 960
 961   END_INTEGER_CONSTANTS
 962 };
 963
 964 static const scheme_function frame_functions[] =
 965 {
 966   { "frame?", 1, 0, 0, gdbscm_frame_p,
 967     "\
 968 Return #t if the object is a <gdb:frame> object." },
 969
 970   { "frame-valid?", 1, 0, 0, gdbscm_frame_valid_p,
 971     "\
 972 Return #t if the object is a valid <gdb:frame> object.\n\
 973 Frames become invalid when the inferior returns to its caller." },
 974
 975   { "frame-name", 1, 0, 0, gdbscm_frame_name,
 976     "\
 977 Return the name of the function corresponding to this frame,\n\
 978 or #f if there is no function." },
 979
 980   { "frame-arch", 1, 0, 0, gdbscm_frame_arch,
 981     "\
 982 Return the frame's architecture as a <gdb:arch> object." },
 983
 984   { "frame-type", 1, 0, 0, gdbscm_frame_type,
 985     "\
 986 Return the frame type, namely one of the gdb:*_FRAME constants." },
 987
 988   { "frame-unwind-stop-reason", 1, 0, 0, gdbscm_frame_unwind_stop_reason,
 989     "\
 990 Return one of the gdb:FRAME_UNWIND_* constants explaining why\n\
 991 it's not possible to find frames older than this." },
 992
 993   { "frame-pc", 1, 0, 0, gdbscm_frame_pc,
 994     "\
 995 Return the frame's resume address." },
 996
 997   { "frame-block", 1, 0, 0, gdbscm_frame_block,
 998     "\
 999 Return the frame's code block, or #f if one cannot be found." },
1000
1001   { "frame-function", 1, 0, 0, gdbscm_frame_function,
1002     "\
1003 Return the <gdb:symbol> for the function corresponding to this frame,\n\
1004 or #f if there isn't one." },
1005
1006   { "frame-older", 1, 0, 0, gdbscm_frame_older,
1007     "\
1008 Return the frame immediately older (outer) to this frame,\n\
1009 or #f if there isn't one." },
1010
1011   { "frame-newer", 1, 0, 0, gdbscm_frame_newer,
1012     "\
1013 Return the frame immediately newer (inner) to this frame,\n\
1014 or #f if there isn't one." },
1015
1016   { "frame-sal", 1, 0, 0, gdbscm_frame_sal,
1017     "\
1018 Return the frame's symtab-and-line <gdb:sal> object." },
1019
1020   { "frame-read-var", 2, 0, 1, gdbscm_frame_read_var,
1021     "\
1022 Return the value of the symbol in the frame.\n\
1023 \n\
1024   Arguments: <gdb:frame> <gdb:symbol>\n\
1025          Or: <gdb:frame> string [#:block <gdb:block>]" },
1026
1027   { "frame-select", 1, 0, 0, gdbscm_frame_select,
1028     "\
1029 Select this frame." },
1030
1031   { "newest-frame", 0, 0, 0, gdbscm_newest_frame,
1032     "\
1033 Return the newest frame." },
1034
1035   { "selected-frame", 0, 0, 0, gdbscm_selected_frame,
1036     "\
1037 Return the selected frame." },
1038
1039   { "unwind-stop-reason-string", 1, 0, 0, gdbscm_unwind_stop_reason_string,
1040     "\
1041 Return a string explaining the unwind stop reason.\n\
1042 \n\
1043   Arguments: integer (the result of frame-unwind-stop-reason)" },
1044
1045   END_FUNCTIONS
1046 };
1047
1048 void
1049 gdbscm_initialize_frames (void)
1050 {
1051   frame_smob_tag
1052     = gdbscm_make_smob_type (frame_smob_name, sizeof (frame_smob));
1053   scm_set_smob_free (frame_smob_tag, frscm_free_frame_smob);
1054   scm_set_smob_print (frame_smob_tag, frscm_print_frame_smob);
1055
1056   gdbscm_define_integer_constants (frame_integer_constants, 1);
1057   gdbscm_define_functions (frame_functions, 1);
1058
1059   block_keyword = scm_from_latin1_keyword ("block");
1060
1061   /* Register an inferior "free" callback so we can properly
1062      invalidate frames when an inferior file is about to be deleted.  */
1063   frscm_inferior_data_key
1064     = register_inferior_data_with_cleanup (NULL, frscm_del_inferior_frames);
1065 }