libguile/stacks.c

   1 /* Representation of stack frame debug information
   2  * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008 Free Software Foundation
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public
   6  * License as published by the Free Software Foundation; either
   7  * version 2.1 of the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17  */
  18
  19
  20 \f
  21 #ifdef HAVE_CONFIG_H
  22 # include <config.h>
  23 #endif
  24
  25 #include "libguile/_scm.h"
  26 #include "libguile/eval.h"
  27 #include "libguile/debug.h"
  28 #include "libguile/continuations.h"
  29 #include "libguile/struct.h"
  30 #include "libguile/macros.h"
  31 #include "libguile/procprop.h"
  32 #include "libguile/modules.h"
  33 #include "libguile/root.h"
  34 #include "libguile/strings.h"
  35 #include "libguile/vm.h" /* to capture vm stacks */
  36 #include "libguile/frames.h" /* vm frames */
  37 #include "libguile/instructions.h" /* scm_op_halt */
  38
  39 #include "libguile/validate.h"
  40 #include "libguile/stacks.h"
  41 #include "libguile/private-options.h"
  42
  43
  44 \f
  45 /* {Frames and stacks}
  46  *
  47  * The debugging evaluator creates debug frames on the stack.  These
  48  * are linked from the innermost frame and outwards.  The last frame
  49  * created can always be accessed as SCM_LAST_DEBUG_FRAME.
  50  * Continuations contain a pointer to the innermost debug frame on the
  51  * continuation stack.
  52  *
  53  * Each debug frame contains a set of flags and information about one
  54  * or more stack frames.  The case of multiple frames occurs due to
  55  * tail recursion.  The maximal number of stack frames which can be
  56  * recorded in one debug frame can be set dynamically with the debug
  57  * option FRAMES.
  58  *
  59  * Stack frame information is of two types: eval information (the
  60  * expression being evaluated and its environment) and apply
  61  * information (the procedure being applied and its arguments).  A
  62  * stack frame normally corresponds to an eval/apply pair, but macros
  63  * and special forms (which are implemented as macros in Guile) only
  64  * have eval information and apply calls leads to apply only frames.
  65  *
  66  * Since we want to record the total stack information and later
  67  * manipulate this data at the scheme level in the debugger, we need
  68  * to transform it into a new representation.  In the following code
  69  * section you'll find the functions implementing this data type.
  70  *
  71  * Representation:
  72  *
  73  * The stack is represented as a struct with an id slot and a tail
  74  * array of scm_t_info_frame structs.
  75  *
  76  * A frame is represented as a pair where the car contains a stack and
  77  * the cdr an inum.  The inum is an index to the first SCM value of
  78  * the scm_t_info_frame struct.
  79  *
  80  * Stacks
  81  *   Constructor
  82  *     make-stack
  83  *   Selectors
  84  *     stack-id
  85  *     stack-ref
  86  *   Inspector
  87  *     stack-length
  88  *
  89  * Frames
  90  *   Constructor
  91  *     last-stack-frame
  92  *   Selectors
  93  *     frame-number
  94  *     frame-source
  95  *     frame-procedure
  96  *     frame-arguments
  97  *     frame-previous
  98  *     frame-next
  99  *   Predicates
 100  *     frame-real?
 101  *     frame-procedure?
 102  *     frame-evaluating-args?
 103  *     frame-overflow?  */
 104
 105 \f
 106
 107 /* Some auxiliary functions for reading debug frames off the stack.
 108  */
 109
 110 /* Stacks often contain pointers to other items on the stack; for
 111    example, each scm_t_debug_frame structure contains a pointer to the
 112    next frame out.  When we capture a continuation, we copy the stack
 113    into the heap, and just leave all the pointers unchanged.  This
 114    makes it simple to restore the continuation --- just copy the stack
 115    back!  However, if we retrieve a pointer from the heap copy to
 116    another item that was originally on the stack, we have to add an
 117    offset to the pointer to discover the new referent.
 118
 119    If PTR is a pointer retrieved from a continuation, whose original
 120    target was on the stack, and OFFSET is the appropriate offset from
 121    the original stack to the continuation, then RELOC_MUMBLE (PTR,
 122    OFFSET) is a pointer to the copy in the continuation of the
 123    original referent, cast to an scm_debug_MUMBLE *.  */
 124 #define RELOC_INFO(ptr, offset) \
 125   ((scm_t_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset)))
 126 #define RELOC_FRAME(ptr, offset) \
 127   ((scm_t_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset)))
 128
 129 /* FIXME: factor this out somewhere? */
 130 static int is_vm_bootstrap_frame (SCM f)
 131 {
 132   struct scm_program *bp = SCM_PROGRAM_DATA (scm_vm_frame_program (f));
 133   return bp->base[bp->size-1] == scm_op_halt;
 134 }
 135
 136 /* Count number of debug info frames on a stack, beginning with
 137  * DFRAME.  OFFSET is used for relocation of pointers when the stack
 138  * is read from a continuation.
 139  */
 140 static long
 141 stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, SCM vmframe,
 142              SCM *id)
 143 {
 144   long n;
 145   for (n = 0;
 146        dframe && !SCM_VOIDFRAMEP (*dframe);
 147        dframe = RELOC_FRAME (dframe->prev, offset))
 148     {
 149       if (SCM_EVALFRAMEP (*dframe))
 150         {
 151           scm_t_debug_info *info = RELOC_INFO (dframe->info, offset);
 152           scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
 153           n += (info - vect) / 2 + 1;
 154           /* Data in the apply part of an eval info frame comes from previous
 155              stack frame if the scm_t_debug_info vector is overflowed. */
 156           if ((((info - vect) & 1) == 0)
 157               && SCM_OVERFLOWP (*dframe)
 158               && !SCM_UNBNDP (info[1].a.proc))
 159             ++n;
 160         }
 161       else if (SCM_APPLYFRAMEP (*dframe))
 162         {
 163           scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
 164           if (SCM_PROGRAM_P (vect[0].a.proc))
 165             {
 166               /* count vmframe back to previous bootstrap frame */
 167               for (; scm_is_true (vmframe); vmframe = scm_c_vm_frame_prev (vmframe))
 168                 {
 169                   if (is_vm_bootstrap_frame (vmframe))
 170                     { /* skip bootstrap frame, cut out of the vm backtrace */
 171                       vmframe = scm_c_vm_frame_prev (vmframe);
 172                       break;
 173                     }
 174                   else
 175                     ++n;
 176                 }
 177             }
 178           ++n; /* increment for apply frame in any case */
 179         }
 180       else
 181         ++n;
 182     }
 183   if (dframe && SCM_VOIDFRAMEP (*dframe))
 184     *id = RELOC_INFO(dframe->vect, offset)[0].id;
 185   return n;
 186 }
 187
 188 /* Read debug info from DFRAME into IFRAME.
 189  */
 190 static void
 191 read_frame (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
 192             scm_t_info_frame *iframe)
 193 {
 194   scm_t_bits flags = SCM_UNPACK (SCM_INUM0); /* UGh. */
 195   if (SCM_EVALFRAMEP (*dframe))
 196     {
 197       scm_t_debug_info *info = RELOC_INFO (dframe->info, offset);
 198       scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
 199       if ((info - vect) & 1)
 200         {
 201           /* Debug.vect ends with apply info. */
 202           --info;
 203           if (!SCM_UNBNDP (info[1].a.proc))
 204             {
 205               flags |= SCM_FRAMEF_PROC;
 206               iframe->proc = info[1].a.proc;
 207               iframe->args = info[1].a.args;
 208               if (!SCM_ARGS_READY_P (*dframe))
 209                 flags |= SCM_FRAMEF_EVAL_ARGS;
 210             }
 211         }
 212       iframe->source = scm_make_memoized (info[0].e.exp, info[0].e.env);
 213     }
 214   else
 215     {
 216       scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
 217       flags |= SCM_FRAMEF_PROC;
 218       iframe->proc = vect[0].a.proc;
 219       iframe->args = vect[0].a.args;
 220     }
 221   iframe->flags = flags;
 222 }
 223
 224 /* Look up the first body form of the apply closure.  We'll use this
 225    below to prevent it from being displayed.
 226 */
 227 static SCM
 228 get_applybody ()
 229 {
 230   SCM var = scm_sym2var (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F);
 231   if (SCM_VARIABLEP (var) && SCM_CLOSUREP (SCM_VARIABLE_REF (var)))
 232     return SCM_CAR (SCM_CLOSURE_BODY (SCM_VARIABLE_REF (var)));
 233   else
 234     return SCM_UNDEFINED;
 235 }
 236
 237 #define NEXT_FRAME(iframe, n, quit) \
 238 do { \
 239   if (SCM_MEMOIZEDP (iframe->source) \
 240       && scm_is_eq (SCM_MEMOIZED_EXP (iframe->source), applybody)) \
 241     { \
 242       iframe->source = SCM_BOOL_F; \
 243       if (scm_is_false (iframe->proc)) \
 244         { \
 245           --iframe; \
 246           ++n; \
 247         } \
 248     } \
 249   ++iframe; \
 250   if (--n == 0) \
 251     goto quit; \
 252 } while (0)
 253
 254
 255 /* Fill the scm_t_info_frame vector IFRAME with data from N stack frames
 256  * starting with the first stack frame represented by debug frame
 257  * DFRAME.
 258  */
 259
 260 static scm_t_bits
 261 read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
 262              SCM vmframe, long n, scm_t_info_frame *iframes)
 263 {
 264   scm_t_info_frame *iframe = iframes;
 265   scm_t_debug_info *info, *vect;
 266   static SCM applybody = SCM_UNDEFINED;
 267
 268   /* The value of applybody has to be setup after r4rs.scm has executed. */
 269   if (SCM_UNBNDP (applybody))
 270     applybody = get_applybody ();
 271   for (;
 272        dframe && !SCM_VOIDFRAMEP (*dframe) && n > 0;
 273        dframe = RELOC_FRAME (dframe->prev, offset))
 274     {
 275       read_frame (dframe, offset, iframe);
 276       if (SCM_EVALFRAMEP (*dframe))
 277         {
 278           /* If current frame is a macro during expansion, we should
 279              skip the previously recorded macro transformer
 280              application frame.  */
 281           if (SCM_MACROEXPP (*dframe) && iframe > iframes)
 282             {
 283               *(iframe - 1) = *iframe;
 284               --iframe;
 285             }
 286           info =  RELOC_INFO (dframe->info, offset);
 287           vect =  RELOC_INFO (dframe->vect, offset);
 288           if ((info - vect) & 1)
 289             --info;
 290           /* Data in the apply part of an eval info frame comes from
 291              previous stack frame if the scm_t_debug_info vector is
 292              overflowed. */
 293           else if (SCM_OVERFLOWP (*dframe)
 294                    && !SCM_UNBNDP (info[1].a.proc))
 295             {
 296               NEXT_FRAME (iframe, n, quit);
 297               iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC;
 298               iframe->proc = info[1].a.proc;
 299               iframe->args = info[1].a.args;
 300             }
 301           if (SCM_OVERFLOWP (*dframe))
 302             iframe->flags |= SCM_FRAMEF_OVERFLOW;
 303           info -= 2;
 304           NEXT_FRAME (iframe, n, quit);
 305           while (info >= vect)
 306             {
 307               if (!SCM_UNBNDP (info[1].a.proc))
 308                 {
 309                   iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC;
 310                   iframe->proc = info[1].a.proc;
 311                   iframe->args = info[1].a.args;
 312                 }
 313               else
 314                 iframe->flags = SCM_UNPACK (SCM_INUM0);
 315               iframe->source = scm_make_memoized (info[0].e.exp,
 316                                                   info[0].e.env);
 317               info -= 2;
 318               NEXT_FRAME (iframe, n, quit);
 319             }
 320         }
 321       else if (scm_is_eq (iframe->proc, scm_f_gsubr_apply))
 322         /* Skip gsubr apply frames. */
 323         continue;
 324       else
 325         {
 326           if (SCM_PROGRAM_P (iframe->proc))
 327             {
 328               scm_t_info_frame saved = *iframe;
 329               for (; scm_is_true (vmframe);
 330                    vmframe = scm_c_vm_frame_prev (vmframe))
 331                 {
 332                   if (is_vm_bootstrap_frame (vmframe))
 333                     { /* skip bootstrap frame, back to interpreted frames */
 334                       vmframe = scm_c_vm_frame_prev (vmframe);
 335                       break;
 336                     }
 337                   else
 338                     {
 339                       /* Oh dear, oh dear, oh dear. */
 340                       iframe->flags = SCM_UNPACK (SCM_INUM0) | SCM_FRAMEF_PROC;
 341                       iframe->source = scm_vm_frame_source (vmframe);
 342                       iframe->proc = scm_vm_frame_program (vmframe);
 343                       iframe->args = scm_vm_frame_arguments (vmframe);
 344                       ++iframe;
 345                       if (--n == 0)
 346                         goto quit;
 347                     }
 348                 }
 349               *iframe = saved;
 350             }
 351
 352           NEXT_FRAME (iframe, n, quit);
 353         }
 354     quit:
 355       if (iframe > iframes)
 356         (iframe - 1) -> flags |= SCM_FRAMEF_REAL;
 357     }
 358   return iframe - iframes;  /* Number of frames actually read */
 359 }
 360
 361 /* Narrow STACK by cutting away stackframes (mutatingly).
 362  *
 363  * Inner frames (most recent) are cut by advancing the frames pointer.
 364  * Outer frames are cut by decreasing the recorded length.
 365  *
 366  * Cut maximally INNER inner frames and OUTER outer frames using
 367  * the keys INNER_KEY and OUTER_KEY.
 368  *
 369  * Frames are cut away starting at the end points and moving towards
 370  * the center of the stack.  The key is normally compared to the
 371  * operator in application frames.  Frames up to and including the key
 372  * are cut.
 373  *
 374  * If INNER_KEY is #t a different scheme is used for inner frames:
 375  *
 376  * Frames up to but excluding the first source frame originating from
 377  * a user module are cut, except for possible application frames
 378  * between the user frame and the last system frame previously
 379  * encountered.
 380  */
 381
 382 static void
 383 narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
 384 {
 385   scm_t_stack *s = SCM_STACK (stack);
 386   unsigned long int i;
 387   long n = s->length;
 388
 389   /* Cut inner part. */
 390   if (scm_is_eq (inner_key, SCM_BOOL_T))
 391     {
 392       /* Cut all frames up to user module code */
 393       for (i = 0; inner; ++i, --inner)
 394         {
 395           SCM m = s->frames[i].source;
 396           if (SCM_MEMOIZEDP (m)
 397               && !SCM_IMP (SCM_MEMOIZED_ENV (m))
 398               && scm_is_false (scm_system_module_env_p (SCM_MEMOIZED_ENV (m))))
 399             {
 400               /* Back up in order to include any non-source frames */
 401               while (i > 0)
 402                 {
 403                   m = s->frames[i - 1].source;
 404                   if (SCM_MEMOIZEDP (m))
 405                     break;
 406
 407                   m = s->frames[i - 1].proc;
 408                   if (scm_is_true (scm_procedure_p (m))
 409                       && scm_is_true (scm_procedure_property
 410                                       (m, scm_sym_system_procedure)))
 411                     break;
 412
 413                   --i;
 414                   ++inner;
 415                 }
 416               break;
 417             }
 418         }
 419     }
 420   else
 421     /* Use standard cutting procedure. */
 422     {
 423       for (i = 0; inner; --inner)
 424         if (scm_is_eq (s->frames[i++].proc, inner_key))
 425           break;
 426     }
 427   s->frames = &s->frames[i];
 428   n -= i;
 429
 430   /* Cut outer part. */
 431   for (; n && outer; --outer)
 432     if (scm_is_eq (s->frames[--n].proc, outer_key))
 433       break;
 434
 435   s->length = n;
 436 }
 437
 438 \f
 439
 440 /* Stacks
 441  */
 442
 443 SCM scm_stack_type;
 444
 445 SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0,
 446             (SCM obj),
 447             "Return @code{#t} if @var{obj} is a calling stack.")
 448 #define FUNC_NAME s_scm_stack_p
 449 {
 450   return scm_from_bool(SCM_STACKP (obj));
 451 }
 452 #undef FUNC_NAME
 453
 454 SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
 455             (SCM obj, SCM args),
 456             "Create a new stack. If @var{obj} is @code{#t}, the current\n"
 457             "evaluation stack is used for creating the stack frames,\n"
 458             "otherwise the frames are taken from @var{obj} (which must be\n"
 459             "either a debug object or a continuation).\n\n"
 460             "@var{args} should be a list containing any combination of\n"
 461             "integer, procedure and @code{#t} values.\n\n"
 462             "These values specify various ways of cutting away uninteresting\n"
 463             "stack frames from the top and bottom of the stack that\n"
 464             "@code{make-stack} returns.  They come in pairs like this:\n"
 465             "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n"
 466             "@var{outer_cut_2} @dots{})}.\n\n"
 467             "Each @var{inner_cut_N} can be @code{#t}, an integer, or a\n"
 468             "procedure.  @code{#t} means to cut away all frames up to but\n"
 469             "excluding the first user module frame.  An integer means to cut\n"
 470             "away exactly that number of frames.  A procedure means to cut\n"
 471             "away all frames up to but excluding the application frame whose\n"
 472             "procedure matches the specified one.\n\n"
 473             "Each @var{outer_cut_N} can be an integer or a procedure.  An\n"
 474             "integer means to cut away that number of frames.  A procedure\n"
 475             "means to cut away frames down to but excluding the application\n"
 476             "frame whose procedure matches the specified one.\n\n"
 477             "If the @var{outer_cut_N} of the last pair is missing, it is\n"
 478             "taken as 0.")
 479 #define FUNC_NAME s_scm_make_stack
 480 {
 481   long n, size;
 482   int maxp;
 483   scm_t_debug_frame *dframe;
 484   scm_t_info_frame *iframe;
 485   SCM vmframe;
 486   long offset = 0;
 487   SCM stack, id;
 488   SCM inner_cut, outer_cut;
 489
 490   /* Extract a pointer to the innermost frame of whatever object
 491      scm_make_stack was given.  */
 492   if (scm_is_eq (obj, SCM_BOOL_T))
 493     {
 494       struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
 495       dframe = scm_i_last_debug_frame ();
 496       vmframe = scm_c_make_vm_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
 497     }
 498   else if (SCM_DEBUGOBJP (obj))
 499     {
 500       dframe = SCM_DEBUGOBJ_FRAME (obj);
 501       vmframe = SCM_BOOL_F;
 502     }
 503   else if (SCM_VM_FRAME_P (obj))
 504     {
 505       dframe = NULL;
 506       vmframe = obj;
 507     }
 508   else if (SCM_CONTINUATIONP (obj))
 509     {
 510       scm_t_contregs *cont = SCM_CONTREGS (obj);
 511       offset = cont->offset;
 512       dframe = RELOC_FRAME (cont->dframe, offset);
 513       if (!scm_is_null (cont->vm_conts))
 514         { SCM vm_cont;
 515           struct scm_vm_cont *data;
 516           vm_cont = scm_cdr (scm_car (cont->vm_conts));
 517           data = SCM_VM_CONT_DATA (vm_cont);
 518           vmframe = scm_c_make_vm_frame (vm_cont,
 519                                          data->stack_base + data->fp,
 520                                          data->stack_base + data->sp,
 521                                          data->ip,
 522                                          data->reloc);
 523         } else
 524           vmframe = SCM_BOOL_F;
 525     }
 526   else
 527     {
 528       SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
 529       /* not reached */
 530     }
 531
 532   /* Count number of frames.  Also get stack id tag and check whether
 533      there are more stackframes than we want to record
 534      (SCM_BACKTRACE_MAXDEPTH). */
 535   id = SCM_BOOL_F;
 536   maxp = 0;
 537   n = stack_depth (dframe, offset, vmframe, &id);
 538   /* FIXME: redo maxp? */
 539   size = n * SCM_FRAME_N_SLOTS;
 540
 541   /* Make the stack object. */
 542   stack = scm_make_struct (scm_stack_type, scm_from_long (size), SCM_EOL);
 543   SCM_STACK (stack) -> id = id;
 544   iframe = &SCM_STACK (stack) -> tail[0];
 545   SCM_STACK (stack) -> frames = iframe;
 546
 547   /* Translate the current chain of stack frames into debugging information. */
 548   n = read_frames (dframe, offset, vmframe, n, iframe);
 549   SCM_STACK (stack) -> length = n;
 550
 551   /* Narrow the stack according to the arguments given to scm_make_stack. */
 552   SCM_VALIDATE_REST_ARGUMENT (args);
 553   while (n > 0 && !scm_is_null (args))
 554     {
 555       inner_cut = SCM_CAR (args);
 556       args = SCM_CDR (args);
 557       if (scm_is_null (args))
 558         {
 559           outer_cut = SCM_INUM0;
 560         }
 561       else
 562         {
 563           outer_cut = SCM_CAR (args);
 564           args = SCM_CDR (args);
 565         }
 566
 567       narrow_stack (stack,
 568                     scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n,
 569                     scm_is_integer (inner_cut) ? 0 : inner_cut,
 570                     scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
 571                     scm_is_integer (outer_cut) ? 0 : outer_cut);
 572
 573       n = SCM_STACK (stack) -> length;
 574     }
 575
 576   if (n > 0 && maxp)
 577     iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
 578
 579   if (n > 0)
 580     return stack;
 581   else
 582     return SCM_BOOL_F;
 583 }
 584 #undef FUNC_NAME
 585
 586 SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
 587             (SCM stack),
 588             "Return the identifier given to @var{stack} by @code{start-stack}.")
 589 #define FUNC_NAME s_scm_stack_id
 590 {
 591   scm_t_debug_frame *dframe;
 592   long offset = 0;
 593   if (scm_is_eq (stack, SCM_BOOL_T))
 594     {
 595       dframe = scm_i_last_debug_frame ();
 596     }
 597   else if (SCM_DEBUGOBJP (stack))
 598     {
 599       dframe = SCM_DEBUGOBJ_FRAME (stack);
 600     }
 601   else if (SCM_CONTINUATIONP (stack))
 602     {
 603       scm_t_contregs *cont = SCM_CONTREGS (stack);
 604       offset = cont->offset;
 605       dframe = RELOC_FRAME (cont->dframe, offset);
 606     }
 607   else if (SCM_STACKP (stack))
 608     {
 609       return SCM_STACK (stack) -> id;
 610     }
 611   else
 612     {
 613       SCM_WRONG_TYPE_ARG (1, stack);
 614     }
 615
 616   while (dframe && !SCM_VOIDFRAMEP (*dframe))
 617     dframe = RELOC_FRAME (dframe->prev, offset);
 618   if (dframe && SCM_VOIDFRAMEP (*dframe))
 619     return RELOC_INFO (dframe->vect, offset)[0].id;
 620   return SCM_BOOL_F;
 621 }
 622 #undef FUNC_NAME
 623
 624 SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
 625             (SCM stack, SCM index),
 626             "Return the @var{index}'th frame from @var{stack}.")
 627 #define FUNC_NAME s_scm_stack_ref
 628 {
 629   unsigned long int c_index;
 630
 631   SCM_VALIDATE_STACK (1, stack);
 632   c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1);
 633   return scm_cons (stack, index);
 634 }
 635 #undef FUNC_NAME
 636
 637 SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
 638             (SCM stack),
 639             "Return the length of @var{stack}.")
 640 #define FUNC_NAME s_scm_stack_length
 641 {
 642   SCM_VALIDATE_STACK (1, stack);
 643   return scm_from_int (SCM_STACK_LENGTH (stack));
 644 }
 645 #undef FUNC_NAME
 646
 647 /* Frames
 648  */
 649
 650 SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
 651             (SCM obj),
 652             "Return @code{#t} if @var{obj} is a stack frame.")
 653 #define FUNC_NAME s_scm_frame_p
 654 {
 655   return scm_from_bool(SCM_FRAMEP (obj));
 656 }
 657 #undef FUNC_NAME
 658
 659 SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0,
 660             (SCM obj),
 661             "Return the last (innermost) frame of @var{obj}, which must be\n"
 662             "either a debug object or a continuation.")
 663 #define FUNC_NAME s_scm_last_stack_frame
 664 {
 665   scm_t_debug_frame *dframe;
 666   long offset = 0;
 667   SCM stack;
 668
 669   if (SCM_DEBUGOBJP (obj))
 670     {
 671       dframe = SCM_DEBUGOBJ_FRAME (obj);
 672     }
 673   else if (SCM_CONTINUATIONP (obj))
 674     {
 675       scm_t_contregs *cont = SCM_CONTREGS (obj);
 676       offset = cont->offset;
 677       dframe = RELOC_FRAME (cont->dframe, offset);
 678     }
 679   else
 680     {
 681       SCM_WRONG_TYPE_ARG (1, obj);
 682       /* not reached */
 683     }
 684
 685   if (!dframe || SCM_VOIDFRAMEP (*dframe))
 686     return SCM_BOOL_F;
 687
 688   stack = scm_make_struct (scm_stack_type, scm_from_int (SCM_FRAME_N_SLOTS),
 689                            SCM_EOL);
 690   SCM_STACK (stack) -> length = 1;
 691   SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0];
 692   read_frame (dframe, offset,
 693               (scm_t_info_frame *) &SCM_STACK (stack) -> frames[0]);
 694
 695   return scm_cons (stack, SCM_INUM0);
 696 }
 697 #undef FUNC_NAME
 698
 699 SCM_DEFINE (scm_frame_number, "frame-number", 1, 0, 0,
 700             (SCM frame),
 701             "Return the frame number of @var{frame}.")
 702 #define FUNC_NAME s_scm_frame_number
 703 {
 704   SCM_VALIDATE_FRAME (1, frame);
 705   return scm_from_int (SCM_FRAME_NUMBER (frame));
 706 }
 707 #undef FUNC_NAME
 708
 709 SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
 710             (SCM frame),
 711             "Return the source of @var{frame}.")
 712 #define FUNC_NAME s_scm_frame_source
 713 {
 714   SCM_VALIDATE_FRAME (1, frame);
 715   return SCM_FRAME_SOURCE (frame);
 716 }
 717 #undef FUNC_NAME
 718
 719 SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
 720             (SCM frame),
 721             "Return the procedure for @var{frame}, or @code{#f} if no\n"
 722             "procedure is associated with @var{frame}.")
 723 #define FUNC_NAME s_scm_frame_procedure
 724 {
 725   SCM_VALIDATE_FRAME (1, frame);
 726   return (SCM_FRAME_PROC_P (frame)
 727           ? SCM_FRAME_PROC (frame)
 728           : SCM_BOOL_F);
 729 }
 730 #undef FUNC_NAME
 731
 732 SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
 733             (SCM frame),
 734             "Return the arguments of @var{frame}.")
 735 #define FUNC_NAME s_scm_frame_arguments
 736 {
 737   SCM_VALIDATE_FRAME (1, frame);
 738   return SCM_FRAME_ARGS (frame);
 739 }
 740 #undef FUNC_NAME
 741
 742 SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
 743             (SCM frame),
 744             "Return the previous frame of @var{frame}, or @code{#f} if\n"
 745             "@var{frame} is the first frame in its stack.")
 746 #define FUNC_NAME s_scm_frame_previous
 747 {
 748   unsigned long int n;
 749   SCM_VALIDATE_FRAME (1, frame);
 750   n = scm_to_ulong (SCM_CDR (frame)) + 1;
 751   if (n >= SCM_STACK_LENGTH (SCM_CAR (frame)))
 752     return SCM_BOOL_F;
 753   else
 754     return scm_cons (SCM_CAR (frame), scm_from_ulong (n));
 755 }
 756 #undef FUNC_NAME
 757
 758 SCM_DEFINE (scm_frame_next, "frame-next", 1, 0, 0,
 759            (SCM frame),
 760             "Return the next frame of @var{frame}, or @code{#f} if\n"
 761             "@var{frame} is the last frame in its stack.")
 762 #define FUNC_NAME s_scm_frame_next
 763 {
 764   unsigned long int n;
 765   SCM_VALIDATE_FRAME (1, frame);
 766   n = scm_to_ulong (SCM_CDR (frame));
 767   if (n == 0)
 768     return SCM_BOOL_F;
 769   else
 770     return scm_cons (SCM_CAR (frame), scm_from_ulong (n - 1));
 771 }
 772 #undef FUNC_NAME
 773
 774 SCM_DEFINE (scm_frame_real_p, "frame-real?", 1, 0, 0,
 775             (SCM frame),
 776             "Return @code{#t} if @var{frame} is a real frame.")
 777 #define FUNC_NAME s_scm_frame_real_p
 778 {
 779   SCM_VALIDATE_FRAME (1, frame);
 780   return scm_from_bool(SCM_FRAME_REAL_P (frame));
 781 }
 782 #undef FUNC_NAME
 783
 784 SCM_DEFINE (scm_frame_procedure_p, "frame-procedure?", 1, 0, 0,
 785             (SCM frame),
 786             "Return @code{#t} if a procedure is associated with @var{frame}.")
 787 #define FUNC_NAME s_scm_frame_procedure_p
 788 {
 789   SCM_VALIDATE_FRAME (1, frame);
 790   return scm_from_bool(SCM_FRAME_PROC_P (frame));
 791 }
 792 #undef FUNC_NAME
 793
 794 SCM_DEFINE (scm_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0,
 795             (SCM frame),
 796             "Return @code{#t} if @var{frame} contains evaluated arguments.")
 797 #define FUNC_NAME s_scm_frame_evaluating_args_p
 798 {
 799   SCM_VALIDATE_FRAME (1, frame);
 800   return scm_from_bool(SCM_FRAME_EVAL_ARGS_P (frame));
 801 }
 802 #undef FUNC_NAME
 803
 804 SCM_DEFINE (scm_frame_overflow_p, "frame-overflow?", 1, 0, 0,
 805             (SCM frame),
 806             "Return @code{#t} if @var{frame} is an overflow frame.")
 807 #define FUNC_NAME s_scm_frame_overflow_p
 808 {
 809   SCM_VALIDATE_FRAME (1, frame);
 810   return scm_from_bool(SCM_FRAME_OVERFLOW_P (frame));
 811 }
 812 #undef FUNC_NAME
 813
 814 \f
 815
 816 void
 817 scm_init_stacks ()
 818 {
 819   scm_stack_type =
 820     scm_permanent_object
 821     (scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
 822                       SCM_UNDEFINED));
 823   scm_set_struct_vtable_name_x (scm_stack_type,
 824                                 scm_from_locale_symbol ("stack"));
 825 #include "libguile/stacks.x"
 826 }
 827
 828 /*
 829   Local Variables:
 830   c-file-style: "gnu"
 831   End:
 832 */