X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/af45e3b06accc40d2c92918d5901afb793e8b247..3b91e017e32e1fb6b911f456c61aea6386075095:/libguile/stacks.c diff --git a/libguile/stacks.c b/libguile/stacks.c index 17116fc01..5b2eea99d 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -1,54 +1,27 @@ /* Representation of stack frame debug information - * Copyright (C) 1996,1997 Free Software Foundation + * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009 Free Software Foundation * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * This program is distributed in the hope that it will be useful, + * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ +#ifdef HAVE_CONFIG_H +# include +#endif -#include #include "libguile/_scm.h" #include "libguile/eval.h" #include "libguile/debug.h" @@ -59,9 +32,14 @@ #include "libguile/modules.h" #include "libguile/root.h" #include "libguile/strings.h" +#include "libguile/vm.h" /* to capture vm stacks */ +#include "libguile/frames.h" /* vm frames */ +#include "libguile/instructions.h" /* scm_op_halt */ #include "libguile/validate.h" #include "libguile/stacks.h" +#include "libguile/private-options.h" + /* {Frames and stacks} @@ -93,11 +71,11 @@ * Representation: * * The stack is represented as a struct with an id slot and a tail - * array of scm_info_frame structs. + * array of scm_t_info_frame structs. * * A frame is represented as a pair where the car contains a stack and * the cdr an inum. The inum is an index to the first SCM value of - * the scm_info_frame struct. + * the scm_t_info_frame struct. * * Stacks * Constructor @@ -130,7 +108,7 @@ */ /* Stacks often contain pointers to other items on the stack; for - example, each scm_debug_frame structure contains a pointer to the + example, each scm_t_debug_frame structure contains a pointer to the next frame out. When we capture a continuation, we copy the stack into the heap, and just leave all the pointers unchanged. This makes it simple to restore the continuation --- just copy the stack @@ -144,55 +122,81 @@ OFFSET) is a pointer to the copy in the continuation of the original referent, cast to an scm_debug_MUMBLE *. */ #define RELOC_INFO(ptr, offset) \ - ((scm_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset))) + ((scm_t_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset))) #define RELOC_FRAME(ptr, offset) \ - ((scm_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset))) - + ((scm_t_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset))) /* Count number of debug info frames on a stack, beginning with * DFRAME. OFFSET is used for relocation of pointers when the stack * is read from a continuation. */ -static int -stack_depth (scm_debug_frame *dframe,long offset,SCM *id,int *maxp) +static long +stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, SCM vmframe, + SCM *id) { - int n; - int max_depth = SCM_BACKTRACE_MAXDEPTH; + long n; for (n = 0; - dframe && !SCM_VOIDFRAMEP (*dframe) && n < max_depth; + dframe && !SCM_VOIDFRAMEP (*dframe); dframe = RELOC_FRAME (dframe->prev, offset)) { if (SCM_EVALFRAMEP (*dframe)) { - scm_debug_info * info = RELOC_INFO (dframe->info, offset); - n += (info - dframe->vect) / 2 + 1; + scm_t_debug_info *info = RELOC_INFO (dframe->info, offset); + scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset); + n += (info - vect) / 2 + 1; /* Data in the apply part of an eval info frame comes from previous - stack frame if the scm_debug_info vector is overflowed. */ - if ((((info - dframe->vect) & 1) == 0) + stack frame if the scm_t_debug_info vector is overflowed. */ + if ((((info - vect) & 1) == 0) && SCM_OVERFLOWP (*dframe) && !SCM_UNBNDP (info[1].a.proc)) - ++n; + ++n; } + else if (SCM_APPLYFRAMEP (*dframe)) + { + scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset); + if (SCM_PROGRAM_P (vect[0].a.proc)) + { + if (!SCM_PROGRAM_IS_BOOT (vect[0].a.proc)) + /* Programs can end up in the debug stack via deval; but we just + ignore those, because we know that the debugging VM engine + pushes one dframe per invocation, with the boot program as + the proc, so we only count those. */ + continue; + /* count vmframe back to previous boot frame */ + for (; scm_is_true (vmframe); vmframe = scm_c_vm_frame_prev (vmframe)) + { + if (!SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe))) + ++n; + else + { /* skip boot frame, cut out of the vm backtrace */ + vmframe = scm_c_vm_frame_prev (vmframe); + break; + } + } + } + else + ++n; /* increment for non-program apply frame */ + } else ++n; } if (dframe && SCM_VOIDFRAMEP (*dframe)) - *id = dframe->vect[0].id; - else if (dframe) - *maxp = 1; + *id = RELOC_INFO(dframe->vect, offset)[0].id; return n; } /* Read debug info from DFRAME into IFRAME. */ static void -read_frame (scm_debug_frame *dframe,long offset,scm_info_frame *iframe) +read_frame (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, + scm_t_info_frame *iframe) { - scm_bits_t flags = SCM_UNPACK (SCM_INUM0); /* UGh. */ + scm_t_bits flags = SCM_UNPACK (SCM_INUM0); /* UGh. */ if (SCM_EVALFRAMEP (*dframe)) { - scm_debug_info * info = RELOC_INFO (dframe->info, offset); - if ((info - dframe->vect) & 1) + scm_t_debug_info *info = RELOC_INFO (dframe->info, offset); + scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset); + if ((info - vect) & 1) { /* Debug.vect ends with apply info. */ --info; @@ -209,9 +213,10 @@ read_frame (scm_debug_frame *dframe,long offset,scm_info_frame *iframe) } else { + scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset); flags |= SCM_FRAMEF_PROC; - iframe->proc = dframe->vect[0].a.proc; - iframe->args = dframe->vect[0].a.args; + iframe->proc = vect[0].a.proc; + iframe->args = vect[0].a.args; } iframe->flags = flags; } @@ -222,20 +227,20 @@ read_frame (scm_debug_frame *dframe,long offset,scm_info_frame *iframe) static SCM get_applybody () { - SCM proc = SCM_CDR (scm_sym2vcell (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F)); - if (SCM_CLOSUREP (proc)) - return SCM_CADR (SCM_CODE (proc)); + SCM var = scm_sym2var (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F); + if (SCM_VARIABLEP (var) && SCM_CLOSUREP (SCM_VARIABLE_REF (var))) + return SCM_CAR (SCM_CLOSURE_BODY (SCM_VARIABLE_REF (var))); else return SCM_UNDEFINED; } #define NEXT_FRAME(iframe, n, quit) \ do { \ - if (SCM_NIMP (iframe->source) \ - && SCM_EQ_P (SCM_MEMOIZED_EXP (iframe->source), applybody)) \ + if (SCM_MEMOIZEDP (iframe->source) \ + && scm_is_eq (SCM_MEMOIZED_EXP (iframe->source), applybody)) \ { \ iframe->source = SCM_BOOL_F; \ - if (SCM_FALSEP (iframe->proc)) \ + if (scm_is_false (iframe->proc)) \ { \ --iframe; \ ++n; \ @@ -247,16 +252,17 @@ do { \ } while (0) -/* Fill the scm_info_frame vector IFRAME with data from N stack frames +/* Fill the scm_t_info_frame vector IFRAME with data from N stack frames * starting with the first stack frame represented by debug frame * DFRAME. */ -static int -read_frames (scm_debug_frame *dframe,long offset,int n,scm_info_frame *iframes) +static scm_t_bits +read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, + SCM vmframe, long n, scm_t_info_frame *iframes) { - scm_info_frame *iframe = iframes; - scm_debug_info *info; + scm_t_info_frame *iframe = iframes; + scm_t_debug_info *info, *vect; static SCM applybody = SCM_UNDEFINED; /* The value of applybody has to be setup after r4rs.scm has executed. */ @@ -278,10 +284,12 @@ read_frames (scm_debug_frame *dframe,long offset,int n,scm_info_frame *iframes) --iframe; } info = RELOC_INFO (dframe->info, offset); - if ((info - dframe->vect) & 1) + vect = RELOC_INFO (dframe->vect, offset); + if ((info - vect) & 1) --info; /* Data in the apply part of an eval info frame comes from - previous stack frame if the scm_debug_info vector is overflowed. */ + previous stack frame if the scm_t_debug_info vector is + overflowed. */ else if (SCM_OVERFLOWP (*dframe) && !SCM_UNBNDP (info[1].a.proc)) { @@ -294,7 +302,7 @@ read_frames (scm_debug_frame *dframe,long offset,int n,scm_info_frame *iframes) iframe->flags |= SCM_FRAMEF_OVERFLOW; info -= 2; NEXT_FRAME (iframe, n, quit); - while (info >= dframe->vect) + while (info >= vect) { if (!SCM_UNBNDP (info[1].a.proc)) { @@ -310,13 +318,39 @@ read_frames (scm_debug_frame *dframe,long offset,int n,scm_info_frame *iframes) NEXT_FRAME (iframe, n, quit); } } - else if (SCM_EQ_P (iframe->proc, scm_f_gsubr_apply)) - /* Skip gsubr apply frames. */ - continue; + else if (SCM_PROGRAM_P (iframe->proc)) + { + if (!SCM_PROGRAM_IS_BOOT (iframe->proc)) + /* Programs can end up in the debug stack via deval; but we just + ignore those, because we know that the debugging VM engine + pushes one dframe per invocation, with the boot program as + the proc, so we only count those. */ + continue; + for (; scm_is_true (vmframe); + vmframe = scm_c_vm_frame_prev (vmframe)) + { + if (SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe))) + { /* skip boot frame, back to interpreted frames */ + vmframe = scm_c_vm_frame_prev (vmframe); + break; + } + else + { + /* Oh dear, oh dear, oh dear. */ + iframe->flags = SCM_UNPACK (SCM_INUM0) | SCM_FRAMEF_PROC; + iframe->source = scm_vm_frame_source (vmframe); + iframe->proc = scm_vm_frame_program (vmframe); + iframe->args = scm_vm_frame_arguments (vmframe); + ++iframe; + if (--n == 0) + goto quit; + } + } + } else - { - NEXT_FRAME (iframe, n, quit); - } + { + NEXT_FRAME (iframe, n, quit); + } quit: if (iframe > iframes) (iframe - 1) -> flags |= SCM_FRAMEF_REAL; @@ -346,31 +380,36 @@ read_frames (scm_debug_frame *dframe,long offset,int n,scm_info_frame *iframes) */ static void -narrow_stack (SCM stack,int inner,SCM inner_key,int outer,SCM outer_key) +narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key) { - scm_stack *s = SCM_STACK (stack); - int i; - int n = s->length; + scm_t_stack *s = SCM_STACK (stack); + unsigned long int i; + long n = s->length; /* Cut inner part. */ - if (SCM_TRUE_P (inner_key)) - /* Cut all frames up to user module code */ + if (scm_is_eq (inner_key, SCM_BOOL_T)) { + /* Cut all frames up to user module code */ for (i = 0; inner; ++i, --inner) { SCM m = s->frames[i].source; - if ( SCM_MEMOIZEDP (m) - && SCM_NIMP (SCM_MEMOIZED_ENV (m)) - && SCM_FALSEP (scm_system_module_env_p (SCM_MEMOIZED_ENV (m)))) + if (SCM_MEMOIZEDP (m) + && !SCM_IMP (SCM_MEMOIZED_ENV (m)) + && scm_is_false (scm_system_module_env_p (SCM_MEMOIZED_ENV (m)))) { /* Back up in order to include any non-source frames */ - while (i > 0 - && !((m = s->frames[i - 1].source, SCM_MEMOIZEDP (m)) - || (SCM_NIMP (m = s->frames[i - 1].proc) - && SCM_NFALSEP (scm_procedure_p (m)) - && SCM_NFALSEP (scm_procedure_property - (m, scm_sym_system_procedure))))) + while (i > 0) { + m = s->frames[i - 1].source; + if (SCM_MEMOIZEDP (m)) + break; + + m = s->frames[i - 1].proc; + if (scm_is_true (scm_procedure_p (m)) + && scm_is_true (scm_procedure_property + (m, scm_sym_system_procedure))) + break; + --i; ++inner; } @@ -382,7 +421,7 @@ narrow_stack (SCM stack,int inner,SCM inner_key,int outer,SCM outer_key) /* Use standard cutting procedure. */ { for (i = 0; inner; --inner) - if (SCM_EQ_P (s->frames[i++].proc, inner_key)) + if (scm_is_eq (s->frames[i++].proc, inner_key)) break; } s->frames = &s->frames[i]; @@ -390,7 +429,7 @@ narrow_stack (SCM stack,int inner,SCM inner_key,int outer,SCM outer_key) /* Cut outer part. */ for (; n && outer; --outer) - if (SCM_EQ_P (s->frames[--n].proc, outer_key)) + if (scm_is_eq (s->frames[--n].proc, outer_key)) break; s->length = n; @@ -408,45 +447,86 @@ SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0, "Return @code{#t} if @var{obj} is a calling stack.") #define FUNC_NAME s_scm_stack_p { - return SCM_BOOL(SCM_STACKP (obj)); + return scm_from_bool(SCM_STACKP (obj)); } #undef FUNC_NAME SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, (SCM obj, SCM args), - "") + "Create a new stack. If @var{obj} is @code{#t}, the current\n" + "evaluation stack is used for creating the stack frames,\n" + "otherwise the frames are taken from @var{obj} (which must be\n" + "either a debug object or a continuation).\n\n" + "@var{args} should be a list containing any combination of\n" + "integer, procedure and @code{#t} values.\n\n" + "These values specify various ways of cutting away uninteresting\n" + "stack frames from the top and bottom of the stack that\n" + "@code{make-stack} returns. They come in pairs like this:\n" + "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n" + "@var{outer_cut_2} @dots{})}.\n\n" + "Each @var{inner_cut_N} can be @code{#t}, an integer, or a\n" + "procedure. @code{#t} means to cut away all frames up to but\n" + "excluding the first user module frame. An integer means to cut\n" + "away exactly that number of frames. A procedure means to cut\n" + "away all frames up to but excluding the application frame whose\n" + "procedure matches the specified one.\n\n" + "Each @var{outer_cut_N} can be an integer or a procedure. An\n" + "integer means to cut away that number of frames. A procedure\n" + "means to cut away frames down to but excluding the application\n" + "frame whose procedure matches the specified one.\n\n" + "If the @var{outer_cut_N} of the last pair is missing, it is\n" + "taken as 0.") #define FUNC_NAME s_scm_make_stack { - int n, maxp, size; - scm_debug_frame *dframe = scm_last_debug_frame; - scm_info_frame *iframe; + long n, size; + int maxp; + scm_t_debug_frame *dframe; + scm_t_info_frame *iframe; + SCM vmframe; long offset = 0; SCM stack, id; SCM inner_cut, outer_cut; /* Extract a pointer to the innermost frame of whatever object scm_make_stack was given. */ - /* just use dframe == scm_last_debug_frame - (from initialization of dframe, above) if obj is #t */ - if (!SCM_TRUE_P (obj)) + if (scm_is_eq (obj, SCM_BOOL_T)) { - SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, FUNC_NAME); - if (SCM_DEBUGOBJP (obj)) - dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj); - else if (scm_tc7_contin == SCM_TYP7 (obj)) - { - offset = ((SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (scm_contregs)) - - SCM_BASE (obj)); -#ifndef STACK_GROWS_UP - offset += SCM_LENGTH (obj); -#endif - dframe = RELOC_FRAME (SCM_DFRAME (obj), offset); - } - else - { - SCM_WTA (SCM_ARG1, obj); - abort (); - } + struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ()); + dframe = scm_i_last_debug_frame (); + vmframe = scm_c_make_vm_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0); + } + else if (SCM_DEBUGOBJP (obj)) + { + dframe = SCM_DEBUGOBJ_FRAME (obj); + vmframe = SCM_BOOL_F; + } + else if (SCM_VM_FRAME_P (obj)) + { + dframe = NULL; + vmframe = obj; + } + else if (SCM_CONTINUATIONP (obj)) + { + scm_t_contregs *cont = SCM_CONTREGS (obj); + offset = cont->offset; + dframe = RELOC_FRAME (cont->dframe, offset); + if (!scm_is_null (cont->vm_conts)) + { SCM vm_cont; + struct scm_vm_cont *data; + vm_cont = scm_cdr (scm_car (cont->vm_conts)); + data = SCM_VM_CONT_DATA (vm_cont); + vmframe = scm_c_make_vm_frame (vm_cont, + data->fp + data->reloc, + data->sp + data->reloc, + data->ip, + data->reloc); + } else + vmframe = SCM_BOOL_F; + } + else + { + SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); + /* not reached */ } /* Count number of frames. Also get stack id tag and check whether @@ -454,28 +534,34 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, (SCM_BACKTRACE_MAXDEPTH). */ id = SCM_BOOL_F; maxp = 0; - n = stack_depth (dframe, offset, &id, &maxp); + n = stack_depth (dframe, offset, vmframe, &id); + /* FIXME: redo maxp? */ size = n * SCM_FRAME_N_SLOTS; /* Make the stack object. */ - stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (size), SCM_EOL); + stack = scm_make_struct (scm_stack_type, scm_from_long (size), SCM_EOL); SCM_STACK (stack) -> id = id; iframe = &SCM_STACK (stack) -> tail[0]; SCM_STACK (stack) -> frames = iframe; + SCM_STACK (stack) -> length = n; /* Translate the current chain of stack frames into debugging information. */ - n = read_frames (RELOC_FRAME (dframe, offset), offset, n, iframe); - SCM_STACK (stack) -> length = n; + n = read_frames (dframe, offset, vmframe, n, iframe); + if (n != SCM_STACK (stack)->length) + { + scm_puts ("warning: stack count incorrect!\n", scm_current_error_port ()); + SCM_STACK (stack)->length = n; + } /* Narrow the stack according to the arguments given to scm_make_stack. */ SCM_VALIDATE_REST_ARGUMENT (args); - while (n > 0 && !SCM_NULLP (args)) + while (n > 0 && !scm_is_null (args)) { inner_cut = SCM_CAR (args); args = SCM_CDR (args); - if (SCM_NULLP (args)) + if (scm_is_null (args)) { - outer_cut = SCM_INUM0; + outer_cut = SCM_INUM0; } else { @@ -484,20 +570,19 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, } narrow_stack (stack, - SCM_INUMP (inner_cut) ? SCM_INUM (inner_cut) : n, - SCM_INUMP (inner_cut) ? 0 : inner_cut, - SCM_INUMP (outer_cut) ? SCM_INUM (outer_cut) : n, - SCM_INUMP (outer_cut) ? 0 : outer_cut); + scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n, + scm_is_integer (inner_cut) ? 0 : inner_cut, + scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n, + scm_is_integer (outer_cut) ? 0 : outer_cut); n = SCM_STACK (stack) -> length; } + if (n > 0 && maxp) + iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW; + if (n > 0) - { - if (maxp) - iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW; - return stack; - } + return stack; else return SCM_BOOL_F; } @@ -508,58 +593,59 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, "Return the identifier given to @var{stack} by @code{start-stack}.") #define FUNC_NAME s_scm_stack_id { - scm_debug_frame *dframe; + scm_t_debug_frame *dframe; long offset = 0; - if (SCM_TRUE_P (stack)) - dframe = scm_last_debug_frame; + if (scm_is_eq (stack, SCM_BOOL_T)) + { + dframe = scm_i_last_debug_frame (); + } + else if (SCM_DEBUGOBJP (stack)) + { + dframe = SCM_DEBUGOBJ_FRAME (stack); + } + else if (SCM_CONTINUATIONP (stack)) + { + scm_t_contregs *cont = SCM_CONTREGS (stack); + offset = cont->offset; + dframe = RELOC_FRAME (cont->dframe, offset); + } + else if (SCM_STACKP (stack)) + { + return SCM_STACK (stack) -> id; + } else { - SCM_VALIDATE_NIM (1,stack); - if (SCM_DEBUGOBJP (stack)) - dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (stack); - else if (scm_tc7_contin == SCM_TYP7 (stack)) - { - offset = ((SCM_STACKITEM *) (SCM_CHARS (stack) + sizeof (scm_contregs)) - - SCM_BASE (stack)); -#ifndef STACK_GROWS_UP - offset += SCM_LENGTH (stack); -#endif - dframe = RELOC_FRAME (SCM_DFRAME (stack), offset); - } - else if (SCM_STACKP (stack)) - return SCM_STACK (stack) -> id; - else - SCM_WRONG_TYPE_ARG (1, stack); + SCM_WRONG_TYPE_ARG (1, stack); } + while (dframe && !SCM_VOIDFRAMEP (*dframe)) dframe = RELOC_FRAME (dframe->prev, offset); if (dframe && SCM_VOIDFRAMEP (*dframe)) - return dframe->vect[0].id; + return RELOC_INFO (dframe->vect, offset)[0].id; return SCM_BOOL_F; } #undef FUNC_NAME SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0, - (SCM stack, SCM i), - "") + (SCM stack, SCM index), + "Return the @var{index}'th frame from @var{stack}.") #define FUNC_NAME s_scm_stack_ref { - SCM_VALIDATE_STACK (1,stack); - SCM_VALIDATE_INUM (2,i); - SCM_ASSERT_RANGE (1,i, - SCM_INUM (i) >= 0 && - SCM_INUM (i) < SCM_STACK_LENGTH (stack)); - return scm_cons (stack, i); + unsigned long int c_index; + + SCM_VALIDATE_STACK (1, stack); + c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1); + return scm_cons (stack, index); } #undef FUNC_NAME SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0, - (SCM stack), - "") + (SCM stack), + "Return the length of @var{stack}.") #define FUNC_NAME s_scm_stack_length { - SCM_VALIDATE_STACK (1,stack); - return SCM_MAKINUM (SCM_STACK_LENGTH (stack)); + SCM_VALIDATE_STACK (1, stack); + return scm_from_int (SCM_STACK_LENGTH (stack)); } #undef FUNC_NAME @@ -568,80 +654,80 @@ SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0, SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0, (SCM obj), - "") + "Return @code{#t} if @var{obj} is a stack frame.") #define FUNC_NAME s_scm_frame_p { - return SCM_BOOL(SCM_FRAMEP (obj)); + return scm_from_bool(SCM_FRAMEP (obj)); } #undef FUNC_NAME SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, - (SCM obj), - "") + (SCM obj), + "Return the last (innermost) frame of @var{obj}, which must be\n" + "either a debug object or a continuation.") #define FUNC_NAME s_scm_last_stack_frame { - scm_debug_frame *dframe; + scm_t_debug_frame *dframe; long offset = 0; SCM stack; - SCM_VALIDATE_NIM (1,obj); if (SCM_DEBUGOBJP (obj)) - dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj); - else if (scm_tc7_contin == SCM_TYP7 (obj)) { - offset = ((SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (scm_contregs)) - - SCM_BASE (obj)); -#ifndef STACK_GROWS_UP - offset += SCM_LENGTH (obj); -#endif - dframe = RELOC_FRAME (SCM_DFRAME (obj), offset); + dframe = SCM_DEBUGOBJ_FRAME (obj); + } + else if (SCM_CONTINUATIONP (obj)) + { + scm_t_contregs *cont = SCM_CONTREGS (obj); + offset = cont->offset; + dframe = RELOC_FRAME (cont->dframe, offset); } else { - SCM_WTA (1,obj); - abort (); + SCM_WRONG_TYPE_ARG (1, obj); + /* not reached */ } if (!dframe || SCM_VOIDFRAMEP (*dframe)) return SCM_BOOL_F; - stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (SCM_FRAME_N_SLOTS), + stack = scm_make_struct (scm_stack_type, scm_from_int (SCM_FRAME_N_SLOTS), SCM_EOL); SCM_STACK (stack) -> length = 1; SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0]; read_frame (dframe, offset, - (scm_info_frame *) &SCM_STACK (stack) -> frames[0]); + (scm_t_info_frame *) &SCM_STACK (stack) -> frames[0]); - return scm_cons (stack, SCM_INUM0);; + return scm_cons (stack, SCM_INUM0); } #undef FUNC_NAME SCM_DEFINE (scm_frame_number, "frame-number", 1, 0, 0, - (SCM frame), - "") + (SCM frame), + "Return the frame number of @var{frame}.") #define FUNC_NAME s_scm_frame_number { - SCM_VALIDATE_FRAME (1,frame); - return SCM_MAKINUM (SCM_FRAME_NUMBER (frame)); + SCM_VALIDATE_FRAME (1, frame); + return scm_from_int (SCM_FRAME_NUMBER (frame)); } #undef FUNC_NAME SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0, - (SCM frame), - "") + (SCM frame), + "Return the source of @var{frame}.") #define FUNC_NAME s_scm_frame_source { - SCM_VALIDATE_FRAME (1,frame); + SCM_VALIDATE_FRAME (1, frame); return SCM_FRAME_SOURCE (frame); } #undef FUNC_NAME SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0, - (SCM frame), - "") + (SCM frame), + "Return the procedure for @var{frame}, or @code{#f} if no\n" + "procedure is associated with @var{frame}.") #define FUNC_NAME s_scm_frame_procedure { - SCM_VALIDATE_FRAME (1,frame); + SCM_VALIDATE_FRAME (1, frame); return (SCM_FRAME_PROC_P (frame) ? SCM_FRAME_PROC (frame) : SCM_BOOL_F); @@ -649,82 +735,84 @@ SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0, - (SCM frame), - "") + (SCM frame), + "Return the arguments of @var{frame}.") #define FUNC_NAME s_scm_frame_arguments { - SCM_VALIDATE_FRAME (1,frame); + SCM_VALIDATE_FRAME (1, frame); return SCM_FRAME_ARGS (frame); } #undef FUNC_NAME SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0, - (SCM frame), - "") + (SCM frame), + "Return the previous frame of @var{frame}, or @code{#f} if\n" + "@var{frame} is the first frame in its stack.") #define FUNC_NAME s_scm_frame_previous { - int n; - SCM_VALIDATE_FRAME (1,frame); - n = SCM_INUM (SCM_CDR (frame)) + 1; + unsigned long int n; + SCM_VALIDATE_FRAME (1, frame); + n = scm_to_ulong (SCM_CDR (frame)) + 1; if (n >= SCM_STACK_LENGTH (SCM_CAR (frame))) return SCM_BOOL_F; else - return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n)); + return scm_cons (SCM_CAR (frame), scm_from_ulong (n)); } #undef FUNC_NAME SCM_DEFINE (scm_frame_next, "frame-next", 1, 0, 0, (SCM frame), - "") + "Return the next frame of @var{frame}, or @code{#f} if\n" + "@var{frame} is the last frame in its stack.") #define FUNC_NAME s_scm_frame_next { - int n; - SCM_VALIDATE_FRAME (1,frame); - n = SCM_INUM (SCM_CDR (frame)) - 1; - if (n < 0) + unsigned long int n; + SCM_VALIDATE_FRAME (1, frame); + n = scm_to_ulong (SCM_CDR (frame)); + if (n == 0) return SCM_BOOL_F; else - return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n)); + return scm_cons (SCM_CAR (frame), scm_from_ulong (n - 1)); } #undef FUNC_NAME SCM_DEFINE (scm_frame_real_p, "frame-real?", 1, 0, 0, - (SCM frame), - "") + (SCM frame), + "Return @code{#t} if @var{frame} is a real frame.") #define FUNC_NAME s_scm_frame_real_p { - SCM_VALIDATE_FRAME (1,frame); - return SCM_BOOL(SCM_FRAME_REAL_P (frame)); + SCM_VALIDATE_FRAME (1, frame); + return scm_from_bool(SCM_FRAME_REAL_P (frame)); } #undef FUNC_NAME SCM_DEFINE (scm_frame_procedure_p, "frame-procedure?", 1, 0, 0, - (SCM frame), - "") + (SCM frame), + "Return @code{#t} if a procedure is associated with @var{frame}.") #define FUNC_NAME s_scm_frame_procedure_p { - SCM_VALIDATE_FRAME (1,frame); - return SCM_BOOL(SCM_FRAME_PROC_P (frame)); + SCM_VALIDATE_FRAME (1, frame); + return scm_from_bool(SCM_FRAME_PROC_P (frame)); } #undef FUNC_NAME SCM_DEFINE (scm_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0, - (SCM frame), - "") + (SCM frame), + "Return @code{#t} if @var{frame} contains evaluated arguments.") #define FUNC_NAME s_scm_frame_evaluating_args_p { - SCM_VALIDATE_FRAME (1,frame); - return SCM_BOOL(SCM_FRAME_EVAL_ARGS_P (frame)); + SCM_VALIDATE_FRAME (1, frame); + return scm_from_bool(SCM_FRAME_EVAL_ARGS_P (frame)); } #undef FUNC_NAME SCM_DEFINE (scm_frame_overflow_p, "frame-overflow?", 1, 0, 0, - (SCM frame), - "") + (SCM frame), + "Return @code{#t} if @var{frame} is an overflow frame.") #define FUNC_NAME s_scm_frame_overflow_p { - SCM_VALIDATE_FRAME (1,frame); - return SCM_BOOL(SCM_FRAME_OVERFLOW_P (frame)); + SCM_VALIDATE_FRAME (1, frame); + return scm_from_bool(SCM_FRAME_OVERFLOW_P (frame)); } #undef FUNC_NAME @@ -733,17 +821,12 @@ SCM_DEFINE (scm_frame_overflow_p, "frame-overflow?", 1, 0, 0, void scm_init_stacks () { - SCM vtable; - SCM vtable_layout = scm_make_struct_layout (scm_nullstr); - SCM stack_layout - = scm_make_struct_layout (scm_makfrom0str (SCM_STACK_LAYOUT)); - vtable = scm_make_vtable_vtable (vtable_layout, SCM_INUM0, SCM_EOL); - scm_stack_type - = scm_permanent_object (scm_make_struct (vtable, SCM_INUM0, - scm_cons (stack_layout, - SCM_EOL))); + scm_stack_type = + scm_permanent_object + (scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT), + SCM_UNDEFINED)); scm_set_struct_vtable_name_x (scm_stack_type, - SCM_CAR (scm_intern0 ("stack"))); + scm_from_locale_symbol ("stack")); #include "libguile/stacks.x" }