gdb/guile/scm-frame.c

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