libguile/stacks.c

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