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   char *name = NULL;
 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         find_frame_funname (frame, &name, &lang, NULL);
 433     }
 434   CATCH (except, RETURN_MASK_ALL)
 435     {
 436       xfree (name);
 437       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 438     }
 439   END_CATCH
 440
 441   if (frame == NULL)
 442     {
 443       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 444                                    _("<gdb:frame>"));
 445     }
 446
 447   if (name != NULL)
 448     {
 449       result = gdbscm_scm_from_c_string (name);
 450       xfree (name);
 451     }
 452   else
 453     result = SCM_BOOL_F;
 454
 455   return result;
 456 }
 457
 458 /* (frame-type <gdb:frame>) -> integer
 459    Returns the frame type, namely one of the gdb:*_FRAME constants.  */
 460
 461 static SCM
 462 gdbscm_frame_type (SCM self)
 463 {
 464   frame_smob *f_smob;
 465   enum frame_type type = NORMAL_FRAME;
 466   struct frame_info *frame = NULL;
 467
 468   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 469
 470   TRY
 471     {
 472       frame = frscm_frame_smob_to_frame (f_smob);
 473       if (frame != NULL)
 474         type = get_frame_type (frame);
 475     }
 476   CATCH (except, RETURN_MASK_ALL)
 477     {
 478       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 479     }
 480   END_CATCH
 481
 482   if (frame == NULL)
 483     {
 484       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 485                                    _("<gdb:frame>"));
 486     }
 487
 488   return scm_from_int (type);
 489 }
 490
 491 /* (frame-arch <gdb:frame>) -> <gdb:architecture>
 492    Returns the frame's architecture as a gdb:architecture object.  */
 493
 494 static SCM
 495 gdbscm_frame_arch (SCM self)
 496 {
 497   frame_smob *f_smob;
 498   struct frame_info *frame = NULL;
 499
 500   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 501
 502   TRY
 503     {
 504       frame = frscm_frame_smob_to_frame (f_smob);
 505     }
 506   CATCH (except, RETURN_MASK_ALL)
 507     {
 508       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 509     }
 510   END_CATCH
 511
 512   if (frame == NULL)
 513     {
 514       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 515                                    _("<gdb:frame>"));
 516     }
 517
 518   return arscm_scm_from_arch (f_smob->gdbarch);
 519 }
 520
 521 /* (frame-unwind-stop-reason <gdb:frame>) -> integer
 522    Returns one of the gdb:FRAME_UNWIND_* constants.  */
 523
 524 static SCM
 525 gdbscm_frame_unwind_stop_reason (SCM self)
 526 {
 527   frame_smob *f_smob;
 528   struct frame_info *frame = NULL;
 529   enum unwind_stop_reason stop_reason;
 530
 531   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 532
 533   TRY
 534     {
 535       frame = frscm_frame_smob_to_frame (f_smob);
 536     }
 537   CATCH (except, RETURN_MASK_ALL)
 538     {
 539       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 540     }
 541   END_CATCH
 542
 543   if (frame == NULL)
 544     {
 545       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 546                                    _("<gdb:frame>"));
 547     }
 548
 549   stop_reason = get_frame_unwind_stop_reason (frame);
 550
 551   return scm_from_int (stop_reason);
 552 }
 553
 554 /* (frame-pc <gdb:frame>) -> integer
 555    Returns the frame's resume address.  */
 556
 557 static SCM
 558 gdbscm_frame_pc (SCM self)
 559 {
 560   frame_smob *f_smob;
 561   CORE_ADDR pc = 0;
 562   struct frame_info *frame = NULL;
 563
 564   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 565
 566   TRY
 567     {
 568       frame = frscm_frame_smob_to_frame (f_smob);
 569       if (frame != NULL)
 570         pc = get_frame_pc (frame);
 571     }
 572   CATCH (except, RETURN_MASK_ALL)
 573     {
 574       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 575     }
 576   END_CATCH
 577
 578   if (frame == NULL)
 579     {
 580       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 581                                    _("<gdb:frame>"));
 582     }
 583
 584   return gdbscm_scm_from_ulongest (pc);
 585 }
 586
 587 /* (frame-block <gdb:frame>) -> <gdb:block>
 588    Returns the frame's code block, or #f if one cannot be found.  */
 589
 590 static SCM
 591 gdbscm_frame_block (SCM self)
 592 {
 593   frame_smob *f_smob;
 594   const struct block *block = NULL, *fn_block;
 595   struct frame_info *frame = NULL;
 596
 597   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 598
 599   TRY
 600     {
 601       frame = frscm_frame_smob_to_frame (f_smob);
 602       if (frame != NULL)
 603         block = get_frame_block (frame, NULL);
 604     }
 605   CATCH (except, RETURN_MASK_ALL)
 606     {
 607       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 608     }
 609   END_CATCH
 610
 611   if (frame == NULL)
 612     {
 613       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 614                                    _("<gdb:frame>"));
 615     }
 616
 617   for (fn_block = block;
 618        fn_block != NULL && BLOCK_FUNCTION (fn_block) == NULL;
 619        fn_block = BLOCK_SUPERBLOCK (fn_block))
 620     continue;
 621
 622   if (block == NULL || fn_block == NULL || BLOCK_FUNCTION (fn_block) == NULL)
 623     {
 624       scm_misc_error (FUNC_NAME, _("cannot find block for frame"),
 625                       scm_list_1 (self));
 626     }
 627
 628   if (block != NULL)
 629     {
 630       return bkscm_scm_from_block
 631         (block, symbol_objfile (BLOCK_FUNCTION (fn_block)));
 632     }
 633
 634   return SCM_BOOL_F;
 635 }
 636
 637 /* (frame-function <gdb:frame>) -> <gdb:symbol>
 638    Returns the symbol for the function corresponding to this frame,
 639    or #f if there isn't one.  */
 640
 641 static SCM
 642 gdbscm_frame_function (SCM self)
 643 {
 644   frame_smob *f_smob;
 645   struct symbol *sym = NULL;
 646   struct frame_info *frame = NULL;
 647
 648   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 649
 650   TRY
 651     {
 652       frame = frscm_frame_smob_to_frame (f_smob);
 653       if (frame != NULL)
 654         sym = find_pc_function (get_frame_address_in_block (frame));
 655     }
 656   CATCH (except, RETURN_MASK_ALL)
 657     {
 658       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 659     }
 660   END_CATCH
 661
 662   if (frame == NULL)
 663     {
 664       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 665                                    _("<gdb:frame>"));
 666     }
 667
 668   if (sym != NULL)
 669     return syscm_scm_from_symbol (sym);
 670
 671   return SCM_BOOL_F;
 672 }
 673
 674 /* (frame-older <gdb:frame>) -> <gdb:frame>
 675    Returns the frame immediately older (outer) to this frame,
 676    or #f if there isn't one.  */
 677
 678 static SCM
 679 gdbscm_frame_older (SCM self)
 680 {
 681   frame_smob *f_smob;
 682   struct frame_info *prev = NULL;
 683   struct frame_info *frame = NULL;
 684
 685   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 686
 687   TRY
 688     {
 689       frame = frscm_frame_smob_to_frame (f_smob);
 690       if (frame != NULL)
 691         prev = get_prev_frame (frame);
 692     }
 693   CATCH (except, RETURN_MASK_ALL)
 694     {
 695       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 696     }
 697   END_CATCH
 698
 699   if (frame == NULL)
 700     {
 701       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 702                                    _("<gdb:frame>"));
 703     }
 704
 705   if (prev != NULL)
 706     return frscm_scm_from_frame_unsafe (prev, f_smob->inferior);
 707
 708   return SCM_BOOL_F;
 709 }
 710
 711 /* (frame-newer <gdb:frame>) -> <gdb:frame>
 712    Returns the frame immediately newer (inner) to this frame,
 713    or #f if there isn't one.  */
 714
 715 static SCM
 716 gdbscm_frame_newer (SCM self)
 717 {
 718   frame_smob *f_smob;
 719   struct frame_info *next = NULL;
 720   struct frame_info *frame = NULL;
 721
 722   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 723
 724   TRY
 725     {
 726       frame = frscm_frame_smob_to_frame (f_smob);
 727       if (frame != NULL)
 728         next = get_next_frame (frame);
 729     }
 730   CATCH (except, RETURN_MASK_ALL)
 731     {
 732       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 733     }
 734   END_CATCH
 735
 736   if (frame == NULL)
 737     {
 738       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 739                                    _("<gdb:frame>"));
 740     }
 741
 742   if (next != NULL)
 743     return frscm_scm_from_frame_unsafe (next, f_smob->inferior);
 744
 745   return SCM_BOOL_F;
 746 }
 747
 748 /* (frame-sal <gdb:frame>) -> <gdb:sal>
 749    Returns the frame's symtab and line.  */
 750
 751 static SCM
 752 gdbscm_frame_sal (SCM self)
 753 {
 754   frame_smob *f_smob;
 755   struct symtab_and_line sal;
 756   struct frame_info *frame = NULL;
 757
 758   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 759
 760   TRY
 761     {
 762       frame = frscm_frame_smob_to_frame (f_smob);
 763       if (frame != NULL)
 764         find_frame_sal (frame, &sal);
 765     }
 766   CATCH (except, RETURN_MASK_ALL)
 767     {
 768       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 769     }
 770   END_CATCH
 771
 772   if (frame == NULL)
 773     {
 774       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 775                                    _("<gdb:frame>"));
 776     }
 777
 778   return stscm_scm_from_sal (sal);
 779 }
 780
 781 /* (frame-read-register <gdb:frame> string) -> <gdb:value>
 782    The register argument must be a string.  */
 783
 784 static SCM
 785 gdbscm_frame_read_register (SCM self, SCM register_scm)
 786 {
 787   char *register_str;
 788   struct value *value = NULL;
 789   struct frame_info *frame = NULL;
 790   struct cleanup *cleanup;
 791   frame_smob *f_smob;
 792
 793   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 794   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, NULL, "s",
 795                               register_scm, &register_str);
 796   cleanup = make_cleanup (xfree, register_str);
 797
 798   TRY
 799     {
 800       int regnum;
 801
 802       frame = frscm_frame_smob_to_frame (f_smob);
 803       if (frame)
 804         {
 805           regnum = user_reg_map_name_to_regnum (get_frame_arch (frame),
 806                                                 register_str,
 807                                                 strlen (register_str));
 808           if (regnum >= 0)
 809             value = value_of_register (regnum, frame);
 810         }
 811     }
 812   CATCH (except, RETURN_MASK_ALL)
 813     {
 814       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 815     }
 816   END_CATCH
 817
 818   do_cleanups (cleanup);
 819
 820   if (frame == NULL)
 821     {
 822       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 823                                    _("<gdb:frame>"));
 824     }
 825
 826   if (value == NULL)
 827     {
 828       gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, register_scm,
 829                                  _("unknown register"));
 830     }
 831
 832   return vlscm_scm_from_value (value);
 833 }
 834
 835 /* (frame-read-var <gdb:frame> <gdb:symbol>) -> <gdb:value>
 836    (frame-read-var <gdb:frame> string [#:block <gdb:block>]) -> <gdb:value>
 837    If the optional block argument is provided start the search from that block,
 838    otherwise search from the frame's current block (determined by examining
 839    the resume address of the frame).  The variable argument must be a string
 840    or an instance of a <gdb:symbol>.  The block argument must be an instance of
 841    <gdb:block>.  */
 842
 843 static SCM
 844 gdbscm_frame_read_var (SCM self, SCM symbol_scm, SCM rest)
 845 {
 846   SCM keywords[] = { block_keyword, SCM_BOOL_F };
 847   int rc;
 848   frame_smob *f_smob;
 849   int block_arg_pos = -1;
 850   SCM block_scm = SCM_UNDEFINED;
 851   struct frame_info *frame = NULL;
 852   struct symbol *var = NULL;
 853   const struct block *block = NULL;
 854   struct value *value = NULL;
 855
 856   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 857
 858   TRY
 859     {
 860       frame = frscm_frame_smob_to_frame (f_smob);
 861     }
 862   CATCH (except, RETURN_MASK_ALL)
 863     {
 864       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 865     }
 866   END_CATCH
 867
 868   if (frame == NULL)
 869     {
 870       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 871                                    _("<gdb:frame>"));
 872     }
 873
 874   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG3, keywords, "#O",
 875                               rest, &block_arg_pos, &block_scm);
 876
 877   if (syscm_is_symbol (symbol_scm))
 878     {
 879       var = syscm_get_valid_symbol_arg_unsafe (symbol_scm, SCM_ARG2,
 880                                                FUNC_NAME);
 881       SCM_ASSERT (SCM_UNBNDP (block_scm), block_scm, SCM_ARG3, FUNC_NAME);
 882     }
 883   else if (scm_is_string (symbol_scm))
 884     {
 885       char *var_name;
 886       const struct block *block = NULL;
 887       struct cleanup *cleanup;
 888       struct gdb_exception except = exception_none;
 889
 890       if (! SCM_UNBNDP (block_scm))
 891         {
 892           SCM except_scm;
 893
 894           gdb_assert (block_arg_pos > 0);
 895           block = bkscm_scm_to_block (block_scm, block_arg_pos, FUNC_NAME,
 896                                       &except_scm);
 897           if (block == NULL)
 898             gdbscm_throw (except_scm);
 899         }
 900
 901       var_name = gdbscm_scm_to_c_string (symbol_scm);
 902       cleanup = make_cleanup (xfree, var_name);
 903       /* N.B. Between here and the call to do_cleanups, don't do anything
 904          to cause a Scheme exception without performing the cleanup.  */
 905
 906       TRY
 907         {
 908           struct block_symbol lookup_sym;
 909
 910           if (block == NULL)
 911             block = get_frame_block (frame, NULL);
 912           lookup_sym = lookup_symbol (var_name, block, VAR_DOMAIN, NULL);
 913           var = lookup_sym.symbol;
 914           block = lookup_sym.block;
 915         }
 916       CATCH (ex, RETURN_MASK_ALL)
 917         {
 918           except = ex;
 919         }
 920       END_CATCH
 921
 922       do_cleanups (cleanup);
 923       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 924
 925       if (var == NULL)
 926         {
 927           do_cleanups (cleanup);
 928           gdbscm_out_of_range_error (FUNC_NAME, 0, symbol_scm,
 929                                      _("variable not found"));
 930         }
 931
 932       do_cleanups (cleanup);
 933     }
 934   else
 935     {
 936       /* Use SCM_ASSERT_TYPE for more consistent error messages.  */
 937       SCM_ASSERT_TYPE (0, symbol_scm, SCM_ARG1, FUNC_NAME,
 938                        _("gdb:symbol or string"));
 939     }
 940
 941   TRY
 942     {
 943       value = read_var_value (var, block, frame);
 944     }
 945   CATCH (except, RETURN_MASK_ALL)
 946     {
 947       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 948     }
 949   END_CATCH
 950
 951   return vlscm_scm_from_value (value);
 952 }
 953
 954 /* (frame-select <gdb:frame>) -> unspecified
 955    Select this frame.  */
 956
 957 static SCM
 958 gdbscm_frame_select (SCM self)
 959 {
 960   frame_smob *f_smob;
 961   struct frame_info *frame = NULL;
 962
 963   f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 964
 965   TRY
 966     {
 967       frame = frscm_frame_smob_to_frame (f_smob);
 968       if (frame != NULL)
 969         select_frame (frame);
 970     }
 971   CATCH (except, RETURN_MASK_ALL)
 972     {
 973       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 974     }
 975   END_CATCH
 976
 977   if (frame == NULL)
 978     {
 979       gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
 980                                    _("<gdb:frame>"));
 981     }
 982
 983   return SCM_UNSPECIFIED;
 984 }
 985
 986 /* (newest-frame) -> <gdb:frame>
 987    Returns the newest frame.  */
 988
 989 static SCM
 990 gdbscm_newest_frame (void)
 991 {
 992   struct frame_info *frame = NULL;
 993
 994   TRY
 995     {
 996       frame = get_current_frame ();
 997     }
 998   CATCH (except, RETURN_MASK_ALL)
 999     {
1000       GDBSCM_HANDLE_GDB_EXCEPTION (except);
1001     }
1002   END_CATCH
1003
1004   return frscm_scm_from_frame_unsafe (frame, current_inferior ());
1005 }
1006
1007 /* (selected-frame) -> <gdb:frame>
1008    Returns the selected frame.  */
1009
1010 static SCM
1011 gdbscm_selected_frame (void)
1012 {
1013   struct frame_info *frame = NULL;
1014
1015   TRY
1016     {
1017       frame = get_selected_frame (_("No frame is currently selected"));
1018     }
1019   CATCH (except, RETURN_MASK_ALL)
1020     {
1021       GDBSCM_HANDLE_GDB_EXCEPTION (except);
1022     }
1023   END_CATCH
1024
1025   return frscm_scm_from_frame_unsafe (frame, current_inferior ());
1026 }
1027
1028 /* (unwind-stop-reason-string integer) -> string
1029    Return a string explaining the unwind stop reason.  */
1030
1031 static SCM
1032 gdbscm_unwind_stop_reason_string (SCM reason_scm)
1033 {
1034   int reason;
1035   const char *str;
1036
1037   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "i",
1038                               reason_scm, &reason);
1039
1040   if (reason < UNWIND_FIRST || reason > UNWIND_LAST)
1041     scm_out_of_range (FUNC_NAME, reason_scm);
1042
1043   str = unwind_stop_reason_to_string ((enum unwind_stop_reason) reason);
1044   return gdbscm_scm_from_c_string (str);
1045 }
1046 \f
1047 /* Initialize the Scheme frame support.  */
1048
1049 static const scheme_integer_constant frame_integer_constants[] =
1050 {
1051 #define ENTRY(X) { #X, X }
1052
1053   ENTRY (NORMAL_FRAME),
1054   ENTRY (DUMMY_FRAME),
1055   ENTRY (INLINE_FRAME),
1056   ENTRY (TAILCALL_FRAME),
1057   ENTRY (SIGTRAMP_FRAME),
1058   ENTRY (ARCH_FRAME),
1059   ENTRY (SENTINEL_FRAME),
1060
1061 #undef ENTRY
1062
1063 #define SET(name, description) \
1064   { "FRAME_" #name, name },
1065 #include "unwind_stop_reasons.def"
1066 #undef SET
1067
1068   END_INTEGER_CONSTANTS
1069 };
1070
1071 static const scheme_function frame_functions[] =
1072 {
1073   { "frame?", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_p),
1074     "\
1075 Return #t if the object is a <gdb:frame> object." },
1076
1077   { "frame-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_valid_p),
1078     "\
1079 Return #t if the object is a valid <gdb:frame> object.\n\
1080 Frames become invalid when the inferior returns to its caller." },
1081
1082   { "frame-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_name),
1083     "\
1084 Return the name of the function corresponding to this frame,\n\
1085 or #f if there is no function." },
1086
1087   { "frame-arch", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_arch),
1088     "\
1089 Return the frame's architecture as a <gdb:arch> object." },
1090
1091   { "frame-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_type),
1092     "\
1093 Return the frame type, namely one of the gdb:*_FRAME constants." },
1094
1095   { "frame-unwind-stop-reason", 1, 0, 0,
1096     as_a_scm_t_subr (gdbscm_frame_unwind_stop_reason),
1097     "\
1098 Return one of the gdb:FRAME_UNWIND_* constants explaining why\n\
1099 it's not possible to find frames older than this." },
1100
1101   { "frame-pc", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_pc),
1102     "\
1103 Return the frame's resume address." },
1104
1105   { "frame-block", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_block),
1106     "\
1107 Return the frame's code block, or #f if one cannot be found." },
1108
1109   { "frame-function", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_function),
1110     "\
1111 Return the <gdb:symbol> for the function corresponding to this frame,\n\
1112 or #f if there isn't one." },
1113
1114   { "frame-older", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_older),
1115     "\
1116 Return the frame immediately older (outer) to this frame,\n\
1117 or #f if there isn't one." },
1118
1119   { "frame-newer", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_newer),
1120     "\
1121 Return the frame immediately newer (inner) to this frame,\n\
1122 or #f if there isn't one." },
1123
1124   { "frame-sal", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_sal),
1125     "\
1126 Return the frame's symtab-and-line <gdb:sal> object." },
1127
1128   { "frame-read-var", 2, 0, 1, as_a_scm_t_subr (gdbscm_frame_read_var),
1129     "\
1130 Return the value of the symbol in the frame.\n\
1131 \n\
1132   Arguments: <gdb:frame> <gdb:symbol>\n\
1133          Or: <gdb:frame> string [#:block <gdb:block>]" },
1134
1135   { "frame-read-register", 2, 0, 0,
1136     as_a_scm_t_subr (gdbscm_frame_read_register),
1137     "\
1138 Return the value of the register in the frame.\n\
1139 \n\
1140   Arguments: <gdb:frame> string" },
1141
1142   { "frame-select", 1, 0, 0, as_a_scm_t_subr (gdbscm_frame_select),
1143     "\
1144 Select this frame." },
1145
1146   { "newest-frame", 0, 0, 0, as_a_scm_t_subr (gdbscm_newest_frame),
1147     "\
1148 Return the newest frame." },
1149
1150   { "selected-frame", 0, 0, 0, as_a_scm_t_subr (gdbscm_selected_frame),
1151     "\
1152 Return the selected frame." },
1153
1154   { "unwind-stop-reason-string", 1, 0, 0,
1155     as_a_scm_t_subr (gdbscm_unwind_stop_reason_string),
1156     "\
1157 Return a string explaining the unwind stop reason.\n\
1158 \n\
1159   Arguments: integer (the result of frame-unwind-stop-reason)" },
1160
1161   END_FUNCTIONS
1162 };
1163
1164 void
1165 gdbscm_initialize_frames (void)
1166 {
1167   frame_smob_tag
1168     = gdbscm_make_smob_type (frame_smob_name, sizeof (frame_smob));
1169   scm_set_smob_free (frame_smob_tag, frscm_free_frame_smob);
1170   scm_set_smob_print (frame_smob_tag, frscm_print_frame_smob);
1171
1172   gdbscm_define_integer_constants (frame_integer_constants, 1);
1173   gdbscm_define_functions (frame_functions, 1);
1174
1175   block_keyword = scm_from_latin1_keyword ("block");
1176
1177   /* Register an inferior "free" callback so we can properly
1178      invalidate frames when an inferior file is about to be deleted.  */
1179   frscm_inferior_data_key
1180     = register_inferior_data_with_cleanup (NULL, frscm_del_inferior_frames);
1181 }