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