gdb/guile/scm-frame.c

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