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