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