libguile/stacks.c

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