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