gdb/guile/scm-frame.c

   1 /* Scheme interface to stack frames.
   2
   3    Copyright (C) 2008-2018 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   frame_smob *f_smob;
 787
 788   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 789   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, NULL, "s",
 790                               register_scm, &register_str);
 791
 792   struct gdb_exception except = exception_none;
 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 (ex, RETURN_MASK_ALL)
 809     {
 810       except = ex;
 811     }
 812   END_CATCH
 813
 814   xfree (register_str);
 815   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 816
 817   if (frame == NULL)
 818     {
 819       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 820                                    _("<gdb:frame>"));
 821     }
 822
 823   if (value == NULL)
 824     {
 825       gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, register_scm,
 826                                  _("unknown register"));
 827     }
 828
 829   return vlscm_scm_from_value (value);
 830 }
 831
 832 /* (frame-read-var <gdb:frame> <gdb:symbol>) -> <gdb:value>
 833    (frame-read-var <gdb:frame> string [#:block <gdb:block>]) -> <gdb:value>
 834    If the optional block argument is provided start the search from that block,
 835    otherwise search from the frame's current block (determined by examining
 836    the resume address of the frame).  The variable argument must be a string
 837    or an instance of a <gdb:symbol>.  The block argument must be an instance of
 838    <gdb:block>.  */
 839
 840 static SCM
 841 gdbscm_frame_read_var (SCM self, SCM symbol_scm, SCM rest)
 842 {
 843   SCM keywords[] = { block_keyword, SCM_BOOL_F };
 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       const struct block *block = NULL;
 882       struct gdb_exception except = exception_none;
 883
 884       if (! SCM_UNBNDP (block_scm))
 885         {
 886           SCM except_scm;
 887
 888           gdb_assert (block_arg_pos > 0);
 889           block = bkscm_scm_to_block (block_scm, block_arg_pos, FUNC_NAME,
 890                                       &except_scm);
 891           if (block == NULL)
 892             gdbscm_throw (except_scm);
 893         }
 894
 895       {
 896         gdb::unique_xmalloc_ptr<char> var_name
 897           (gdbscm_scm_to_c_string (symbol_scm));
 898         /* N.B. Between here and the end of the scope, don't do anything
 899            to cause a Scheme exception.  */
 900
 901         TRY
 902           {
 903             struct block_symbol lookup_sym;
 904
 905             if (block == NULL)
 906               block = get_frame_block (frame, NULL);
 907             lookup_sym = lookup_symbol (var_name.get (), block, VAR_DOMAIN,
 908                                         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
 919       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 920
 921       if (var == NULL)
 922         gdbscm_out_of_range_error (FUNC_NAME, 0, symbol_scm,
 923                                    _("variable not found"));
 924     }
 925   else
 926     {
 927       /* Use SCM_ASSERT_TYPE for more consistent error messages.  */
 928       SCM_ASSERT_TYPE (0, symbol_scm, SCM_ARG1, FUNC_NAME,
 929                        _("gdb:symbol or string"));
 930     }
 931
 932   TRY
 933     {
 934       value = read_var_value (var, block, frame);
 935     }
 936   CATCH (except, RETURN_MASK_ALL)
 937     {
 938       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 939     }
 940   END_CATCH
 941
 942   return vlscm_scm_from_value (value);
 943 }
 944
 945 /* (frame-select <gdb:frame>) -> unspecified
 946    Select this frame.  */
 947
 948 static SCM
 949 gdbscm_frame_select (SCM self)
 950 {
 951   frame_smob *f_smob;
 952   struct frame_info *frame = NULL;
 953
 954   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 955
 956   TRY
 957     {
 958       frame = frscm_frame_smob_to_frame (f_smob);
 959       if (frame != NULL)
 960         select_frame (frame);
 961     }
 962   CATCH (except, RETURN_MASK_ALL)
 963     {
 964       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 965     }
 966   END_CATCH
 967
 968   if (frame == NULL)
 969     {
 970       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 971                                    _("<gdb:frame>"));
 972     }
 973
 974   return SCM_UNSPECIFIED;
 975 }
 976
 977 /* (newest-frame) -> <gdb:frame>
 978    Returns the newest frame.  */
 979
 980 static SCM
 981 gdbscm_newest_frame (void)
 982 {
 983   struct frame_info *frame = NULL;
 984
 985   TRY
 986     {
 987       frame = get_current_frame ();
 988     }
 989   CATCH (except, RETURN_MASK_ALL)
 990     {
 991       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 992     }
 993   END_CATCH
 994
 995   return frscm_scm_from_frame_unsafe (frame, current_inferior ());
 996 }
 997
 998 /* (selected-frame) -> <gdb:frame>
 999    Returns the selected frame.  */
1000
1001 static SCM
1002 gdbscm_selected_frame (void)
1003 {
1004   struct frame_info *frame = NULL;
1005
1006   TRY
1007     {
1008       frame = get_selected_frame (_("No frame is currently selected"));
1009     }
1010   CATCH (except, RETURN_MASK_ALL)
1011     {
1012       GDBSCM_HANDLE_GDB_EXCEPTION (except);
1013     }
1014   END_CATCH
1015
1016   return frscm_scm_from_frame_unsafe (frame, current_inferior ());
1017 }
1018
1019 /* (unwind-stop-reason-string integer) -> string
1020    Return a string explaining the unwind stop reason.  */
1021
1022 static SCM
1023 gdbscm_unwind_stop_reason_string (SCM reason_scm)
1024 {
1025   int reason;
1026   const char *str;
1027
1028   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "i",
1029                               reason_scm, &reason);
1030
1031   if (reason < UNWIND_FIRST || reason > UNWIND_LAST)
1032     scm_out_of_range (FUNC_NAME, reason_scm);
1033
1034   str = unwind_stop_reason_to_string ((enum unwind_stop_reason) reason);
1035   return gdbscm_scm_from_c_string (str);
1036 }
1037 \f
1038 /* Initialize the Scheme frame support.  */
1039
1040 static const scheme_integer_constant frame_integer_constants[] =
1041 {
1042 #define ENTRY(X) { #X, X }
1043
1044   ENTRY (NORMAL_FRAME),
1045   ENTRY (DUMMY_FRAME),
1046   ENTRY (INLINE_FRAME),
1047   ENTRY (TAILCALL_FRAME),
1048   ENTRY (SIGTRAMP_FRAME),
1049   ENTRY (ARCH_FRAME),
1050   ENTRY (SENTINEL_FRAME),
1051
1052 #undef ENTRY
1053
1054 #define SET(name, description) \
1055   { "FRAME_" #name, name },
1056 #include "unwind_stop_reasons.def"
1057 #undef SET
1058
1059   END_INTEGER_CONSTANTS
1060 };
1061
1062 static const scheme_function frame_functions[] =
1063 {
1064   { "frame?", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_p),
1065     "\
1066 Return #t if the object is a <gdb:frame> object." },
1067
1068   { "frame-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_valid_p),
1069     "\
1070 Return #t if the object is a valid <gdb:frame> object.\n\
1071 Frames become invalid when the inferior returns to its caller." },
1072
1073   { "frame-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_name),
1074     "\
1075 Return the name of the function corresponding to this frame,\n\
1076 or #f if there is no function." },
1077
1078   { "frame-arch", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_arch),
1079     "\
1080 Return the frame's architecture as a <gdb:arch> object." },
1081
1082   { "frame-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_type),
1083     "\
1084 Return the frame type, namely one of the gdb:*_FRAME constants." },
1085
1086   { "frame-unwind-stop-reason", 1, 0, 0,
1087     as_a_scm_t_subr (gdbscm_frame_unwind_stop_reason),
1088     "\
1089 Return one of the gdb:FRAME_UNWIND_* constants explaining why\n\
1090 it's not possible to find frames older than this." },
1091
1092   { "frame-pc", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_pc),
1093     "\
1094 Return the frame's resume address." },
1095
1096   { "frame-block", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_block),
1097     "\
1098 Return the frame's code block, or #f if one cannot be found." },
1099
1100   { "frame-function", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_function),
1101     "\
1102 Return the <gdb:symbol> for the function corresponding to this frame,\n\
1103 or #f if there isn't one." },
1104
1105   { "frame-older", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_older),
1106     "\
1107 Return the frame immediately older (outer) to this frame,\n\
1108 or #f if there isn't one." },
1109
1110   { "frame-newer", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_newer),
1111     "\
1112 Return the frame immediately newer (inner) to this frame,\n\
1113 or #f if there isn't one." },
1114
1115   { "frame-sal", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_sal),
1116     "\
1117 Return the frame's symtab-and-line <gdb:sal> object." },
1118
1119   { "frame-read-var", 2, 0, 1, as_a_scm_t_subr (gdbscm_frame_read_var),
1120     "\
1121 Return the value of the symbol in the frame.\n\
1122 \n\
1123   Arguments: <gdb:frame> <gdb:symbol>\n\
1124          Or: <gdb:frame> string [#:block <gdb:block>]" },
1125
1126   { "frame-read-register", 2, 0, 0,
1127     as_a_scm_t_subr (gdbscm_frame_read_register),
1128     "\
1129 Return the value of the register in the frame.\n\
1130 \n\
1131   Arguments: <gdb:frame> string" },
1132
1133   { "frame-select", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_select),
1134     "\
1135 Select this frame." },
1136
1137   { "newest-frame", 0, 0, 0, as_a_scm_t_subr (gdbscm_newest_frame),
1138     "\
1139 Return the newest frame." },
1140
1141   { "selected-frame", 0, 0, 0, as_a_scm_t_subr (gdbscm_selected_frame),
1142     "\
1143 Return the selected frame." },
1144
1145   { "unwind-stop-reason-string", 1, 0, 0,
1146     as_a_scm_t_subr (gdbscm_unwind_stop_reason_string),
1147     "\
1148 Return a string explaining the unwind stop reason.\n\
1149 \n\
1150   Arguments: integer (the result of frame-unwind-stop-reason)" },
1151
1152   END_FUNCTIONS
1153 };
1154
1155 void
1156 gdbscm_initialize_frames (void)
1157 {
1158   frame_smob_tag
1159     = gdbscm_make_smob_type (frame_smob_name, sizeof (frame_smob));
1160   scm_set_smob_free (frame_smob_tag, frscm_free_frame_smob);
1161   scm_set_smob_print (frame_smob_tag, frscm_print_frame_smob);
1162
1163   gdbscm_define_integer_constants (frame_integer_constants, 1);
1164   gdbscm_define_functions (frame_functions, 1);
1165
1166   block_keyword = scm_from_latin1_keyword ("block");
1167
1168   /* Register an inferior "free" callback so we can properly
1169      invalidate frames when an inferior file is about to be deleted.  */
1170   frscm_inferior_data_key
1171     = register_inferior_data_with_cleanup (NULL, frscm_del_inferior_frames);
1172 }