gdb/guile/scm-frame.c

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