libguile/stacks.c

   1 /* Representation of stack frame debug information
   2  * Copyright (C) 1996,1997 Free Software Foundation
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation; either version 2, or (at your option)
   7  * any later version.
   8  *
   9  * This program 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
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this software; see the file COPYING.  If not, write to
  16  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  17  * Boston, MA 02111-1307 USA
  18  *
  19  * As a special exception, the Free Software Foundation gives permission
  20  * for additional uses of the text contained in its release of GUILE.
  21  *
  22  * The exception is that, if you link the GUILE library with other files
  23  * to produce an executable, this does not by itself cause the
  24  * resulting executable to be covered by the GNU General Public License.
  25  * Your use of that executable is in no way restricted on account of
  26  * linking the GUILE library code into it.
  27  *
  28  * This exception does not however invalidate any other reasons why
  29  * the executable file might be covered by the GNU General Public License.
  30  *
  31  * This exception applies only to the code released by the
  32  * Free Software Foundation under the name GUILE.  If you copy
  33  * code from other Free Software Foundation releases into a copy of
  34  * GUILE, as the General Public License permits, the exception does
  35  * not apply to the code that you add in this way.  To avoid misleading
  36  * anyone as to the status of such modified files, you must delete
  37  * this exception notice from them.
  38  *
  39  * If you write modifications of your own for GUILE, it is your choice
  40  * whether to permit this exception to apply to your modifications.
  41  * If you do not wish that, delete this exception notice.
  42  *
  43  * The author can be reached at djurfeldt@nada.kth.se
  44  * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
  45
  46 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  47    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  48
  49 \f
  50
  51 #include <stdio.h>
  52 #include "_scm.h"
  53 #include "eval.h"
  54 #include "debug.h"
  55 #include "continuations.h"
  56 #include "struct.h"
  57 #include "macros.h"
  58 #include "procprop.h"
  59 #include "modules.h"
  60
  61 #include "scm_validate.h"
  62 #include "stacks.h"
  63
  64 \f
  65 /* {Frames and stacks}
  66  *
  67  * The debugging evaluator creates debug frames on the stack.  These
  68  * are linked from the innermost frame and outwards.  The last frame
  69  * created can always be accessed as SCM_LAST_DEBUG_FRAME.
  70  * Continuations contain a pointer to the innermost debug frame on the
  71  * continuation stack.
  72  *
  73  * Each debug frame contains a set of flags and information about one
  74  * or more stack frames.  The case of multiple frames occurs due to
  75  * tail recursion.  The maximal number of stack frames which can be
  76  * recorded in one debug frame can be set dynamically with the debug
  77  * option FRAMES.
  78  *
  79  * Stack frame information is of two types: eval information (the
  80  * expression being evaluated and its environment) and apply
  81  * information (the procedure being applied and its arguments).  A
  82  * stack frame normally corresponds to an eval/apply pair, but macros
  83  * and special forms (which are implemented as macros in Guile) only
  84  * have eval information and apply calls leads to apply only frames.
  85  *
  86  * Since we want to record the total stack information and later
  87  * manipulate this data at the scheme level in the debugger, we need
  88  * to transform it into a new representation.  In the following code
  89  * section you'll find the functions implementing this data type.
  90  *
  91  * Representation:
  92  *
  93  * The stack is represented as a struct with an id slot and a tail
  94  * array of scm_info_frame structs.
  95  *
  96  * A frame is represented as a pair where the car contains a stack and
  97  * the cdr an inum.  The inum is an index to the first SCM value of
  98  * the scm_info_frame struct.
  99  *
 100  * Stacks
 101  *   Constructor
 102  *     make-stack
 103  *   Selectors
 104  *     stack-id
 105  *     stack-ref
 106  *   Inspector
 107  *     stack-length
 108  *
 109  * Frames
 110  *   Constructor
 111  *     last-stack-frame
 112  *   Selectors
 113  *     frame-number
 114  *     frame-source
 115  *     frame-procedure
 116  *     frame-arguments
 117  *     frame-previous
 118  *     frame-next
 119  *   Predicates
 120  *     frame-real?
 121  *     frame-procedure?
 122  *     frame-evaluating-args?
 123  *     frame-overflow?  */
 124
 125 \f
 126
 127 /* Some auxiliary functions for reading debug frames off the stack.
 128  */
 129
 130 /* Stacks often contain pointers to other items on the stack; for
 131    example, each scm_debug_frame structure contains a pointer to the
 132    next frame out.  When we capture a continuation, we copy the stack
 133    into the heap, and just leave all the pointers unchanged.  This
 134    makes it simple to restore the continuation --- just copy the stack
 135    back!  However, if we retrieve a pointer from the heap copy to
 136    another item that was originally on the stack, we have to add an
 137    offset to the pointer to discover the new referent.
 138
 139    If PTR is a pointer retrieved from a continuation, whose original
 140    target was on the stack, and OFFSET is the appropriate offset from
 141    the original stack to the continuation, then RELOC_MUMBLE (PTR,
 142    OFFSET) is a pointer to the copy in the continuation of the
 143    original referent, cast to an scm_debug_MUMBLE *.  */
 144 #define RELOC_INFO(ptr, offset) \
 145   ((scm_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset)))
 146 #define RELOC_FRAME(ptr, offset) \
 147   ((scm_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset)))
 148
 149
 150 /* Count number of debug info frames on a stack, beginning with
 151  * DFRAME.  OFFSET is used for relocation of pointers when the stack
 152  * is read from a continuation.
 153  */
 154 static int
 155 stack_depth (scm_debug_frame *dframe,long offset,SCM *id,int *maxp)
 156 {
 157   int n, size;
 158   int max_depth = SCM_BACKTRACE_MAXDEPTH;
 159   scm_debug_info *info;
 160   for (n = 0;
 161        dframe && !SCM_VOIDFRAMEP (*dframe) && n < max_depth;
 162        dframe = RELOC_FRAME (dframe->prev, offset))
 163     {
 164       if (SCM_EVALFRAMEP (*dframe))
 165         {
 166           size = dframe->status & SCM_MAX_FRAME_SIZE;
 167           info = RELOC_INFO (dframe->info, offset);
 168           n += (info - dframe->vect) / 2 + 1;
 169           /* Data in the apply part of an eval info frame comes from previous
 170              stack frame if the scm_debug_info vector is overflowed. */
 171           if ((((info - dframe->vect) & 1) == 0)
 172               && SCM_OVERFLOWP (*dframe)
 173               && !SCM_UNBNDP (info[1].a.proc))
 174             ++n;
 175         }
 176       else
 177         ++n;
 178     }
 179   if (dframe && SCM_VOIDFRAMEP (*dframe))
 180     *id = dframe->vect[0].id;
 181   else if (dframe)
 182     *maxp = 1;
 183   return n;
 184 }
 185
 186 /* Read debug info from DFRAME into IFRAME.
 187  */
 188 static void
 189 read_frame (scm_debug_frame *dframe,long offset,scm_info_frame *iframe)
 190 {
 191   SCM flags = SCM_INUM0;
 192   int size;
 193   scm_debug_info *info;
 194   if (SCM_EVALFRAMEP (*dframe))
 195     {
 196       size = dframe->status & SCM_MAX_FRAME_SIZE;
 197       info = RELOC_INFO (dframe->info, offset);
 198       if ((info - dframe->vect) & 1)
 199         {
 200           /* Debug.vect ends with apply info. */
 201           --info;
 202           if (info[1].a.proc != SCM_UNDEFINED)
 203             {
 204               flags |= SCM_FRAMEF_PROC;
 205               iframe->proc = info[1].a.proc;
 206               iframe->args = info[1].a.args;
 207               if (!SCM_ARGS_READY_P (*dframe))
 208                 flags |= SCM_FRAMEF_EVAL_ARGS;
 209             }
 210         }
 211       iframe->source = scm_make_memoized (info[0].e.exp, info[0].e.env);
 212     }
 213   else
 214     {
 215       flags |= SCM_FRAMEF_PROC;
 216       iframe->proc = dframe->vect[0].a.proc;
 217       iframe->args = dframe->vect[0].a.args;
 218     }
 219   iframe->flags = flags;
 220 }
 221
 222 /* Look up the first body form of the apply closure.  We'll use this
 223    below to prevent it from being displayed.
 224 */
 225 static SCM
 226 get_applybody ()
 227 {
 228   SCM proc = SCM_CDR (scm_sym2vcell (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F));
 229   if (SCM_CLOSUREP (proc))
 230     return SCM_CADR (SCM_CODE (proc));
 231   else
 232     return SCM_UNDEFINED;
 233 }
 234
 235 #define NEXT_FRAME(iframe, n, quit) \
 236 do { \
 237   if (SCM_NIMP (iframe->source) \
 238       && SCM_MEMOIZED_EXP (iframe->source) == applybody) \
 239     { \
 240       iframe->source = SCM_BOOL_F; \
 241       if (SCM_FALSEP (iframe->proc)) \
 242         { \
 243           --iframe; \
 244           ++n; \
 245         } \
 246     } \
 247   ++iframe; \
 248   if (--n == 0) \
 249     goto quit; \
 250 } while (0)
 251
 252
 253 /* Fill the scm_info_frame vector IFRAME with data from N stack frames
 254  * starting with the first stack frame represented by debug frame
 255  * DFRAME.
 256  */
 257
 258 static int
 259 read_frames (scm_debug_frame *dframe,long offset,int n,scm_info_frame *iframes)
 260 {
 261   int size;
 262   scm_info_frame *iframe = iframes;
 263   scm_debug_info *info;
 264   static SCM applybody = SCM_UNDEFINED;
 265
 266   /* The value of applybody has to be setup after r4rs.scm has executed. */
 267   if (SCM_UNBNDP (applybody))
 268     applybody = get_applybody ();
 269   for (;
 270        dframe && !SCM_VOIDFRAMEP (*dframe) && n > 0;
 271        dframe = RELOC_FRAME (dframe->prev, offset))
 272     {
 273       read_frame (dframe, offset, iframe);
 274       if (SCM_EVALFRAMEP (*dframe))
 275         {
 276           /* If current frame is a macro during expansion, we should
 277              skip the previously recorded macro transformer
 278              application frame.  */
 279           if (SCM_MACROEXPP (*dframe) && iframe > iframes)
 280             {
 281               *(iframe - 1) = *iframe;
 282               --iframe;
 283             }
 284           size = dframe->status & SCM_MAX_FRAME_SIZE;
 285           info =  RELOC_INFO (dframe->info, offset);
 286           if ((info - dframe->vect) & 1)
 287             --info;
 288           /* Data in the apply part of an eval info frame comes from
 289              previous stack frame if the scm_debug_info vector is overflowed. */
 290           else if (SCM_OVERFLOWP (*dframe)
 291                    && !SCM_UNBNDP (info[1].a.proc))
 292             {
 293               NEXT_FRAME (iframe, n, quit);
 294               iframe->flags = SCM_INUM0 | SCM_FRAMEF_PROC;
 295               iframe->proc = info[1].a.proc;
 296               iframe->args = info[1].a.args;
 297             }
 298           if (SCM_OVERFLOWP (*dframe))
 299             iframe->flags |= SCM_FRAMEF_OVERFLOW;
 300           info -= 2;
 301           NEXT_FRAME (iframe, n, quit);
 302           while (info >= dframe->vect)
 303             {
 304               if (!SCM_UNBNDP (info[1].a.proc))
 305                 {
 306                   iframe->flags = SCM_INUM0 | SCM_FRAMEF_PROC;
 307                   iframe->proc = info[1].a.proc;
 308                   iframe->args = info[1].a.args;
 309                 }
 310               else
 311                 iframe->flags = SCM_INUM0;
 312               iframe->source = scm_make_memoized (info[0].e.exp,
 313                                                   info[0].e.env);
 314               info -= 2;
 315               NEXT_FRAME (iframe, n, quit);
 316             }
 317         }
 318       else if (iframe->proc == scm_f_gsubr_apply)
 319         /* Skip gsubr apply frames. */
 320         continue;
 321       else
 322         {
 323           NEXT_FRAME (iframe, n, quit);
 324         }
 325     quit:
 326       if (iframe > iframes)
 327         (iframe - 1) -> flags |= SCM_FRAMEF_REAL;
 328     }
 329   return iframe - iframes;  /* Number of frames actually read */
 330 }
 331
 332 /* Narrow STACK by cutting away stackframes (mutatingly).
 333  *
 334  * Inner frames (most recent) are cut by advancing the frames pointer.
 335  * Outer frames are cut by decreasing the recorded length.
 336  *
 337  * Cut maximally INNER inner frames and OUTER outer frames using
 338  * the keys INNER_KEY and OUTER_KEY.
 339  *
 340  * Frames are cut away starting at the end points and moving towards
 341  * the center of the stack.  The key is normally compared to the
 342  * operator in application frames.  Frames up to and including the key
 343  * are cut.
 344  *
 345  * If INNER_KEY is #t a different scheme is used for inner frames:
 346  *
 347  * Frames up to but excluding the first source frame originating from
 348  * a user module are cut, except for possible application frames
 349  * between the user frame and the last system frame previously
 350  * encountered.
 351  */
 352
 353 static void
 354 narrow_stack (SCM stack,int inner,SCM inner_key,int outer,SCM outer_key)
 355 {
 356   scm_stack *s = SCM_STACK (stack);
 357   int i;
 358   int n = s->length;
 359
 360   /* Cut inner part. */
 361   if (inner_key == SCM_BOOL_T)
 362     /* Cut all frames up to user module code */
 363     {
 364       for (i = 0; inner; ++i, --inner)
 365         {
 366           SCM m = s->frames[i].source;
 367           if (   SCM_MEMOIZEDP (m)
 368               && SCM_NIMP (SCM_MEMOIZED_ENV (m))
 369               && SCM_FALSEP (scm_system_module_env_p (SCM_MEMOIZED_ENV (m))))
 370             {
 371               /* Back up in order to include any non-source frames */
 372               while (i > 0
 373                      && !((m = s->frames[i - 1].source, SCM_MEMOIZEDP (m))
 374                           || (SCM_NIMP (m = s->frames[i - 1].proc)
 375                               && SCM_NFALSEP (scm_procedure_p (m))
 376                               && SCM_NFALSEP (scm_procedure_property
 377                                               (m, scm_sym_system_procedure)))))
 378                 {
 379                   --i;
 380                   ++inner;
 381                 }
 382               break;
 383             }
 384         }
 385     }
 386   else
 387     /* Use standard cutting procedure. */
 388     {
 389       for (i = 0; inner; --inner)
 390         if (s->frames[i++].proc == inner_key)
 391           break;
 392     }
 393   s->frames = &s->frames[i];
 394   n -= i;
 395
 396   /* Cut outer part. */
 397   for (; n && outer; --outer)
 398     if (s->frames[--n].proc == outer_key)
 399       break;
 400
 401   s->length = n;
 402 }
 403
 404 \f
 405
 406 /* Stacks
 407  */
 408
 409 SCM scm_stack_type;
 410
 411 SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0,
 412             (SCM obj),
 413 "Return @code{#t} if @var{obj} is a calling stack.")
 414 #define FUNC_NAME s_scm_stack_p
 415 {
 416   return SCM_BOOL(SCM_STACKP (obj));
 417 }
 418 #undef FUNC_NAME
 419
 420 SCM_DEFINE (scm_make_stack, "make-stack", 0, 0, 1,
 421             (SCM args),
 422 "")
 423 #define FUNC_NAME s_scm_make_stack
 424 {
 425   int n, maxp, size;
 426   scm_debug_frame *dframe = scm_last_debug_frame;
 427   scm_info_frame *iframe;
 428   long offset = 0;
 429   SCM stack, id;
 430   SCM obj, inner_cut, outer_cut;
 431
 432   SCM_ASSERT (SCM_CONSP (args),
 433               SCM_FUNC_NAME, SCM_WNA, NULL);
 434   obj = SCM_CAR (args);
 435   args = SCM_CDR (args);
 436
 437   /* Extract a pointer to the innermost frame of whatever object
 438      scm_make_stack was given.  */
 439   /* just use dframe == scm_last_debug_frame
 440      (from initialization of dframe, above) if obj is #t */
 441   if (obj != SCM_BOOL_T)
 442     {
 443       SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, FUNC_NAME);
 444       if (SCM_DEBUGOBJP (obj))
 445         dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj);
 446       else if (scm_tc7_contin == SCM_TYP7 (obj))
 447         {
 448           offset = ((SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (scm_contregs))
 449                     - SCM_BASE (obj));
 450 #ifndef STACK_GROWS_UP
 451           offset += SCM_LENGTH (obj);
 452 #endif
 453           dframe = RELOC_FRAME (SCM_DFRAME (obj), offset);
 454         }
 455       else
 456         {
 457           scm_wta (obj, (char *) SCM_ARG1, FUNC_NAME);
 458           abort ();
 459         }
 460     }
 461
 462   /* Count number of frames.  Also get stack id tag and check whether
 463      there are more stackframes than we want to record
 464      (SCM_BACKTRACE_MAXDEPTH). */
 465   id = SCM_BOOL_F;
 466   maxp = 0;
 467   n = stack_depth (dframe, offset, &id, &maxp);
 468   size = n * SCM_FRAME_N_SLOTS;
 469
 470   /* Make the stack object. */
 471   stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (size), SCM_EOL);
 472   SCM_STACK (stack) -> id = id;
 473   iframe = &SCM_STACK (stack) -> tail[0];
 474   SCM_STACK (stack) -> frames = iframe;
 475
 476   /* Translate the current chain of stack frames into debugging information. */
 477   n = read_frames (RELOC_FRAME (dframe, offset), offset, n, iframe);
 478   SCM_STACK (stack) -> length = n;
 479
 480   /* Narrow the stack according to the arguments given to scm_make_stack. */
 481   while (n > 0 && SCM_CONSP (args))
 482     {
 483       inner_cut = SCM_CAR (args);
 484       args = SCM_CDR (args);
 485       if (SCM_CONSP (args))
 486         {
 487           outer_cut = SCM_CAR (args);
 488           args = SCM_CDR (args);
 489         }
 490       else
 491         outer_cut = SCM_INUM0;
 492
 493       narrow_stack (stack,
 494                     SCM_INUMP (inner_cut) ? SCM_INUM (inner_cut) : n,
 495                     SCM_INUMP (inner_cut) ? 0 : inner_cut,
 496                     SCM_INUMP (outer_cut) ? SCM_INUM (outer_cut) : n,
 497                     SCM_INUMP (outer_cut) ? 0 : outer_cut);
 498
 499       n = SCM_STACK (stack) -> length;
 500     }
 501
 502   if (n > 0)
 503     {
 504       if (maxp)
 505         iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
 506       return stack;
 507     }
 508   else
 509     return SCM_BOOL_F;
 510 }
 511 #undef FUNC_NAME
 512
 513 SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
 514             (SCM stack),
 515 "Return the identifier given to @var{stack} by @code{start-stack}.")
 516 #define FUNC_NAME s_scm_stack_id
 517 {
 518   scm_debug_frame *dframe;
 519   long offset = 0;
 520   if (stack == SCM_BOOL_T)
 521     dframe = scm_last_debug_frame;
 522   else
 523     {
 524       SCM_VALIDATE_NIM (1,stack);
 525       if (SCM_DEBUGOBJP (stack))
 526         dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (stack);
 527       else if (scm_tc7_contin == SCM_TYP7 (stack))
 528         {
 529           offset = ((SCM_STACKITEM *) (SCM_CHARS (stack) + sizeof (scm_contregs))
 530                     - SCM_BASE (stack));
 531 #ifndef STACK_GROWS_UP
 532           offset += SCM_LENGTH (stack);
 533 #endif
 534           dframe = RELOC_FRAME (SCM_DFRAME (stack), offset);
 535         }
 536       else if (SCM_STACKP (stack))
 537         return SCM_STACK (stack) -> id;
 538       else
 539         SCM_WRONG_TYPE_ARG (1, stack);
 540     }
 541   while (dframe && !SCM_VOIDFRAMEP (*dframe))
 542     dframe = RELOC_FRAME (dframe->prev, offset);
 543   if (dframe && SCM_VOIDFRAMEP (*dframe))
 544     return dframe->vect[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 i),
 551 "")
 552 #define FUNC_NAME s_scm_stack_ref
 553 {
 554   SCM_VALIDATE_STACK (1,stack);
 555   SCM_VALIDATE_INUM (2,i);
 556   SCM_ASSERT_RANGE (1,i,
 557                     SCM_INUM (i) >= 0 &&
 558                     SCM_INUM (i) < SCM_STACK_LENGTH (stack));
 559   return scm_cons (stack, i);
 560 }
 561 #undef FUNC_NAME
 562
 563 SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
 564            (SCM stack),
 565 "")
 566 #define FUNC_NAME s_scm_stack_length
 567 {
 568   SCM_VALIDATE_STACK (1,stack);
 569   return SCM_MAKINUM (SCM_STACK_LENGTH (stack));
 570 }
 571 #undef FUNC_NAME
 572
 573 /* Frames
 574  */
 575
 576 SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
 577             (SCM obj),
 578 "")
 579 #define FUNC_NAME s_scm_frame_p
 580 {
 581   return SCM_BOOL(SCM_FRAMEP (obj));
 582 }
 583 #undef FUNC_NAME
 584
 585 SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0,
 586            (SCM obj),
 587 "")
 588 #define FUNC_NAME s_scm_last_stack_frame
 589 {
 590   scm_debug_frame *dframe;
 591   long offset = 0;
 592   SCM stack;
 593
 594   SCM_VALIDATE_NIM (1,obj);
 595   if (SCM_DEBUGOBJP (obj))
 596     dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj);
 597   else if (scm_tc7_contin == SCM_TYP7 (obj))
 598     {
 599       offset = ((SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (scm_contregs))
 600                 - SCM_BASE (obj));
 601 #ifndef STACK_GROWS_UP
 602       offset += SCM_LENGTH (obj);
 603 #endif
 604       dframe = RELOC_FRAME (SCM_DFRAME (obj), offset);
 605     }
 606   else
 607     {
 608       SCM_WTA (1,obj);
 609       abort ();
 610     }
 611
 612   if (!dframe || SCM_VOIDFRAMEP (*dframe))
 613     return SCM_BOOL_F;
 614
 615   stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (SCM_FRAME_N_SLOTS),
 616                            SCM_EOL);
 617   SCM_STACK (stack) -> length = 1;
 618   SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0];
 619   read_frame (dframe, offset,
 620               (scm_info_frame *) &SCM_STACK (stack) -> frames[0]);
 621
 622   return scm_cons (stack, SCM_INUM0);;
 623 }
 624 #undef FUNC_NAME
 625
 626 SCM_DEFINE (scm_frame_number, "frame-number", 1, 0, 0,
 627            (SCM frame),
 628 "")
 629 #define FUNC_NAME s_scm_frame_number
 630 {
 631   SCM_VALIDATE_FRAME (1,frame);
 632   return SCM_MAKINUM (SCM_FRAME_NUMBER (frame));
 633 }
 634 #undef FUNC_NAME
 635
 636 SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
 637            (SCM frame),
 638 "")
 639 #define FUNC_NAME s_scm_frame_source
 640 {
 641   SCM_VALIDATE_FRAME (1,frame);
 642   return SCM_FRAME_SOURCE (frame);
 643 }
 644 #undef FUNC_NAME
 645
 646 SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
 647            (SCM frame),
 648 "")
 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 "")
 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 "")
 671 #define FUNC_NAME s_scm_frame_previous
 672 {
 673   int n;
 674   SCM_VALIDATE_FRAME (1,frame);
 675   n = SCM_INUM (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_MAKINUM (n));
 680 }
 681 #undef FUNC_NAME
 682
 683 SCM_DEFINE (scm_frame_next, "frame-next", 1, 0, 0,
 684            (SCM frame),
 685 "")
 686 #define FUNC_NAME s_scm_frame_next
 687 {
 688   int n;
 689   SCM_VALIDATE_FRAME (1,frame);
 690   n = SCM_INUM (SCM_CDR (frame)) - 1;
 691   if (n < 0)
 692     return SCM_BOOL_F;
 693   else
 694     return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n));
 695 }
 696 #undef FUNC_NAME
 697
 698 SCM_DEFINE (scm_frame_real_p, "frame-real?", 1, 0, 0,
 699            (SCM frame),
 700 "")
 701 #define FUNC_NAME s_scm_frame_real_p
 702 {
 703   SCM_VALIDATE_FRAME (1,frame);
 704   return SCM_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 "")
 711 #define FUNC_NAME s_scm_frame_procedure_p
 712 {
 713   SCM_VALIDATE_FRAME (1,frame);
 714   return SCM_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 "")
 721 #define FUNC_NAME s_scm_frame_evaluating_args_p
 722 {
 723   SCM_VALIDATE_FRAME (1,frame);
 724   return SCM_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 "")
 731 #define FUNC_NAME s_scm_frame_overflow_p
 732 {
 733   SCM_VALIDATE_FRAME (1,frame);
 734   return SCM_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 vtable_layout = scm_make_struct_layout (scm_nullstr);
 745   SCM stack_layout
 746     = scm_make_struct_layout (scm_makfrom0str (SCM_STACK_LAYOUT));
 747   vtable = scm_make_vtable_vtable (vtable_layout, 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_CAR (scm_intern0 ("stack")));
 754 #include "stacks.x"
 755 }