gdb/guile/scm-frame.c

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