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