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