-/* Representation of stack frame debug information
- * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009 Free Software Foundation
- *
- * 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 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
- * Lesser General Public License for more details.
- *
- * 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
- */
-
-
-\f
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include "libguile/_scm.h"
-#include "libguile/eval.h"
-#include "libguile/debug.h"
-#include "libguile/continuations.h"
-#include "libguile/struct.h"
-#include "libguile/macros.h"
-#include "libguile/procprop.h"
-#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"
-
-
-\f
-/* {Frames and stacks}
- *
- * The debugging evaluator creates debug frames on the stack. These
- * are linked from the innermost frame and outwards. The last frame
- * created can always be accessed as SCM_LAST_DEBUG_FRAME.
- * Continuations contain a pointer to the innermost debug frame on the
- * continuation stack.
- *
- * Each debug frame contains a set of flags and information about one
- * or more stack frames. The case of multiple frames occurs due to
- * tail recursion. The maximal number of stack frames which can be
- * recorded in one debug frame can be set dynamically with the debug
- * option FRAMES.
- *
- * Stack frame information is of two types: eval information (the
- * expression being evaluated and its environment) and apply
- * information (the procedure being applied and its arguments). A
- * stack frame normally corresponds to an eval/apply pair, but macros
- * and special forms (which are implemented as macros in Guile) only
- * have eval information and apply calls leads to apply only frames.
- *
- * Since we want to record the total stack information and later
- * manipulate this data at the scheme level in the debugger, we need
- * to transform it into a new representation. In the following code
- * section you'll find the functions implementing this data type.
- *
- * Representation:
- *
- * The stack is represented as a struct with an id slot and a tail
- * 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_t_info_frame struct.
- *
- * Stacks
- * Constructor
- * make-stack
- * Selectors
- * stack-id
- * stack-ref
- * Inspector
- * stack-length
- *
- * Frames
- * Constructor
- * last-stack-frame
- * Selectors
- * frame-number
- * frame-source
- * frame-procedure
- * frame-arguments
- * frame-previous
- * frame-next
- * Predicates
- * frame-real?
- * frame-procedure?
- * frame-evaluating-args?
- * frame-overflow? */
-
-\f
-
-/* Some auxiliary functions for reading debug frames off the stack.
- */
-
-/* Stacks often contain pointers to other items on the stack; for
- 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
- back! However, if we retrieve a pointer from the heap copy to
- another item that was originally on the stack, we have to add an
- offset to the pointer to discover the new referent.
-
- If PTR is a pointer retrieved from a continuation, whose original
- target was on the stack, and OFFSET is the appropriate offset from
- the original stack to the continuation, then RELOC_MUMBLE (PTR,
- 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_t_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset)))
-#define RELOC_FRAME(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 long
-stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, SCM vmframe,
- SCM *id)
-{
- long n;
- for (n = 0;
- dframe && !SCM_VOIDFRAMEP (*dframe);
- dframe = RELOC_FRAME (dframe->prev, offset))
- {
- if (SCM_EVALFRAMEP (*dframe))
- {
- 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_t_debug_info vector is overflowed. */
- if ((((info - vect) & 1) == 0)
- && SCM_OVERFLOWP (*dframe)
- && !SCM_UNBNDP (info[1].a.proc))
- ++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 = RELOC_INFO(dframe->vect, offset)[0].id;
- return n;
-}
-
-/* Read debug info from DFRAME into IFRAME.
- */
-static void
-read_frame (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
- scm_t_info_frame *iframe)
-{
- scm_t_bits flags = SCM_UNPACK (SCM_INUM0); /* UGh. */
- if (SCM_EVALFRAMEP (*dframe))
- {
- 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;
- if (!SCM_UNBNDP (info[1].a.proc))
- {
- flags |= SCM_FRAMEF_PROC;
- iframe->proc = info[1].a.proc;
- iframe->args = info[1].a.args;
- if (!SCM_ARGS_READY_P (*dframe))
- flags |= SCM_FRAMEF_EVAL_ARGS;
- }
- }
- iframe->source = scm_make_memoized (info[0].e.exp, info[0].e.env);
- }
- else
- {
- scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
- flags |= SCM_FRAMEF_PROC;
- iframe->proc = vect[0].a.proc;
- iframe->args = vect[0].a.args;
- }
- iframe->flags = flags;
-}
-
-/* Look up the first body form of the apply closure. We'll use this
- below to prevent it from being displayed.
-*/
-static SCM
-get_applybody ()
-{
- 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_MEMOIZEDP (iframe->source) \
- && scm_is_eq (SCM_MEMOIZED_EXP (iframe->source), applybody)) \
- { \
- iframe->source = SCM_BOOL_F; \
- if (scm_is_false (iframe->proc)) \
- { \
- --iframe; \
- ++n; \
- } \
- } \
- ++iframe; \
- if (--n == 0) \
- goto quit; \
-} while (0)
-
-
-/* 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 scm_t_bits
-read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
- SCM vmframe, long n, scm_t_info_frame *iframes)
-{
- 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. */
- if (SCM_UNBNDP (applybody))
- applybody = get_applybody ();
- for (;
- dframe && !SCM_VOIDFRAMEP (*dframe) && n > 0;
- dframe = RELOC_FRAME (dframe->prev, offset))
- {
- read_frame (dframe, offset, iframe);
- if (SCM_EVALFRAMEP (*dframe))
- {
- /* If current frame is a macro during expansion, we should
- skip the previously recorded macro transformer
- application frame. */
- if (SCM_MACROEXPP (*dframe) && iframe > iframes)
- {
- *(iframe - 1) = *iframe;
- --iframe;
- }
- info = RELOC_INFO (dframe->info, offset);
- 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_t_debug_info vector is
- overflowed. */
- else if (SCM_OVERFLOWP (*dframe)
- && !SCM_UNBNDP (info[1].a.proc))
- {
- NEXT_FRAME (iframe, n, quit);
- iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC;
- iframe->proc = info[1].a.proc;
- iframe->args = info[1].a.args;
- }
- if (SCM_OVERFLOWP (*dframe))
- iframe->flags |= SCM_FRAMEF_OVERFLOW;
- info -= 2;
- NEXT_FRAME (iframe, n, quit);
- while (info >= vect)
- {
- if (!SCM_UNBNDP (info[1].a.proc))
- {
- iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC;
- iframe->proc = info[1].a.proc;
- iframe->args = info[1].a.args;
- }
- else
- iframe->flags = SCM_UNPACK (SCM_INUM0);
- iframe->source = scm_make_memoized (info[0].e.exp,
- info[0].e.env);
- info -= 2;
- NEXT_FRAME (iframe, n, quit);
- }
- }
- 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);
- }
- quit:
- if (iframe > iframes)
- (iframe - 1) -> flags |= SCM_FRAMEF_REAL;
- }
- return iframe - iframes; /* Number of frames actually read */
-}
-
-/* Narrow STACK by cutting away stackframes (mutatingly).
- *
- * Inner frames (most recent) are cut by advancing the frames pointer.
- * Outer frames are cut by decreasing the recorded length.
- *
- * Cut maximally INNER inner frames and OUTER outer frames using
- * the keys INNER_KEY and OUTER_KEY.
- *
- * Frames are cut away starting at the end points and moving towards
- * the center of the stack. The key is normally compared to the
- * operator in application frames. Frames up to and including the key
- * are cut.
- *
- * If INNER_KEY is #t a different scheme is used for inner frames:
- *
- * Frames up to but excluding the first source frame originating from
- * a user module are cut, except for possible application frames
- * between the user frame and the last system frame previously
- * encountered.
- */
-
-static void
-narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
-{
- scm_t_stack *s = SCM_STACK (stack);
- unsigned long int i;
- long n = s->length;
-
- /* Cut inner part. */
- 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_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;
- 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;
- }
- break;
- }
- }
- }
- else
- /* Use standard cutting procedure. */
- {
- for (i = 0; inner; --inner)
- if (scm_is_eq (s->frames[i++].proc, inner_key))
- break;
- }
- s->frames = &s->frames[i];
- n -= i;
-
- /* Cut outer part. */
- for (; n && outer; --outer)
- if (scm_is_eq (s->frames[--n].proc, outer_key))
- break;
-
- s->length = n;
-}
-
-\f
-
-/* Stacks
- */
-
-SCM scm_stack_type;
-
-SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a calling stack.")
-#define FUNC_NAME s_scm_stack_p
-{
- 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
-{
- 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. */
- if (scm_is_eq (obj, SCM_BOOL_T))
- {
- 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
- there are more stackframes than we want to record
- (SCM_BACKTRACE_MAXDEPTH). */
- id = SCM_BOOL_F;
- maxp = 0;
- 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_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 (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_is_null (args))
- {
- inner_cut = SCM_CAR (args);
- args = SCM_CDR (args);
- if (scm_is_null (args))
- {
- outer_cut = SCM_INUM0;
- }
- else
- {
- outer_cut = SCM_CAR (args);
- args = SCM_CDR (args);
- }
-
- narrow_stack (stack,
- 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)
- return stack;
- else
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
- (SCM stack),
- "Return the identifier given to @var{stack} by @code{start-stack}.")
-#define FUNC_NAME s_scm_stack_id
-{
- scm_t_debug_frame *dframe;
- long offset = 0;
- 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_WRONG_TYPE_ARG (1, stack);
- }
-
- while (dframe && !SCM_VOIDFRAMEP (*dframe))
- dframe = RELOC_FRAME (dframe->prev, offset);
- if (dframe && SCM_VOIDFRAMEP (*dframe))
- 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 index),
- "Return the @var{index}'th frame from @var{stack}.")
-#define FUNC_NAME s_scm_stack_ref
-{
- 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),
- "Return the length of @var{stack}.")
-#define FUNC_NAME s_scm_stack_length
-{
- SCM_VALIDATE_STACK (1, stack);
- return scm_from_int (SCM_STACK_LENGTH (stack));
-}
-#undef FUNC_NAME
-
-/* Frames
- */
-
-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_from_bool(SCM_FRAMEP (obj));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0,
- (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_t_debug_frame *dframe;
- long offset = 0;
- SCM stack;
-
- if (SCM_DEBUGOBJP (obj))
- {
- 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_WRONG_TYPE_ARG (1, obj);
- /* not reached */
- }
-
- if (!dframe || SCM_VOIDFRAMEP (*dframe))
- return SCM_BOOL_F;
-
- 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_t_info_frame *) &SCM_STACK (stack) -> frames[0]);
-
- return scm_cons (stack, SCM_INUM0);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_number, "frame-number", 1, 0, 0,
- (SCM frame),
- "Return the frame number of @var{frame}.")
-#define FUNC_NAME s_scm_frame_number
-{
- 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),
- "Return the source of @var{frame}.")
-#define FUNC_NAME s_scm_frame_source
-{
- 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),
- "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);
- return (SCM_FRAME_PROC_P (frame)
- ? SCM_FRAME_PROC (frame)
- : SCM_BOOL_F);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
- (SCM frame),
- "Return the arguments of @var{frame}.")
-#define FUNC_NAME s_scm_frame_arguments
-{
- 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),
- "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
-{
- 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_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
-{
- 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_from_ulong (n - 1));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_real_p, "frame-real?", 1, 0, 0,
- (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_from_bool(SCM_FRAME_REAL_P (frame));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_procedure_p, "frame-procedure?", 1, 0, 0,
- (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_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),
- "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_from_bool(SCM_FRAME_EVAL_ARGS_P (frame));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_overflow_p, "frame-overflow?", 1, 0, 0,
- (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_from_bool(SCM_FRAME_OVERFLOW_P (frame));
-}
-#undef FUNC_NAME
-
-\f
-
-void
-scm_init_stacks ()
-{
- 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_from_locale_symbol ("stack"));
-#include "libguile/stacks.x"
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* A stack holds a frame chain
+ * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation
+ *
+ * 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 3 of
+ * the License, or (at your option) any later version.
+ *
+ * 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
+ * Lesser General Public License for more details.
+ *
+ * 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/control.h"
+#include "libguile/eval.h"
+#include "libguile/debug.h"
+#include "libguile/continuations.h"
+#include "libguile/struct.h"
+#include "libguile/macros.h"
+#include "libguile/procprop.h"
+#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/validate.h"
+#include "libguile/stacks.h"
+#include "libguile/private-options.h"
+
+
+static SCM scm_sys_stacks;
+
+\f
+/* {Stacks}
+ *
+ * The stack is represented as a struct that holds a frame. The frame itself is
+ * linked to the next frame, or #f.
+ *
+ * Stacks
+ * Constructor
+ * make-stack
+ * Selectors
+ * stack-id
+ * stack-ref
+ * Inspector
+ * stack-length
+ */
+
+\f
+
+/* Count number of debug info frames on a stack, beginning with FRAME.
+ */
+static long
+stack_depth (SCM frame)
+{
+ long n = 0;
+ /* count frames, skipping boot frames */
+ for (; scm_is_true (frame); frame = scm_frame_previous (frame))
+ ++n;
+ return n;
+}
+
+/* Narrow STACK by cutting away stackframes (mutatingly).
+ *
+ * Inner frames (most recent) are cut by advancing the frames pointer.
+ * Outer frames are cut by decreasing the recorded length.
+ *
+ * Cut maximally INNER inner frames and OUTER outer frames using
+ * the keys INNER_KEY and OUTER_KEY.
+ *
+ * Frames are cut away starting at the end points and moving towards
+ * the center of the stack. The key is normally compared to the
+ * operator in application frames. Frames up to and including the key
+ * are cut.
+ *
+ * If INNER_KEY is #t a different scheme is used for inner frames:
+ *
+ * Frames up to but excluding the first source frame originating from
+ * a user module are cut, except for possible application frames
+ * between the user frame and the last system frame previously
+ * encountered.
+ */
+
+static SCM
+find_prompt (SCM key)
+{
+ SCM winds;
+ for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = scm_cdr (winds))
+ {
+ SCM elt = scm_car (winds);
+ if (SCM_PROMPT_P (elt) && scm_is_eq (SCM_PROMPT_TAG (elt), key))
+ return elt;
+ }
+ scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
+ scm_list_1 (key));
+ return SCM_BOOL_F; /* not reached */
+}
+
+static void
+narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
+{
+ unsigned long int len;
+ SCM frame;
+
+ len = SCM_STACK_LENGTH (stack);
+ frame = SCM_STACK_FRAME (stack);
+
+ /* Cut inner part. */
+ if (scm_is_true (scm_procedure_p (inner_key)))
+ {
+ /* Cut until the given procedure is seen. */
+ for (; inner && len ; --inner)
+ {
+ SCM proc = scm_frame_procedure (frame);
+ len--;
+ frame = scm_frame_previous (frame);
+ if (scm_is_eq (proc, inner_key))
+ break;
+ }
+ }
+ else if (scm_is_symbol (inner_key))
+ {
+ /* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
+ symbols. */
+ SCM prompt = find_prompt (inner_key);
+ for (; len; len--, frame = scm_frame_previous (frame))
+ if (SCM_PROMPT_REGISTERS (prompt)->fp
+ == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
+ break;
+ }
+ else
+ {
+ /* Cut specified number of frames. */
+ for (; inner && len; --inner)
+ {
+ len--;
+ frame = scm_frame_previous (frame);
+ }
+ }
+
+ SCM_SET_STACK_LENGTH (stack, len);
+ SCM_SET_STACK_FRAME (stack, frame);
+
+ /* Cut outer part. */
+ if (scm_is_true (scm_procedure_p (outer_key)))
+ {
+ /* Cut until the given procedure is seen. */
+ for (; outer && len ; --outer)
+ {
+ frame = scm_stack_ref (stack, scm_from_long (len - 1));
+ len--;
+ if (scm_is_eq (scm_frame_procedure (frame), outer_key))
+ break;
+ }
+ }
+ else if (scm_is_symbol (outer_key))
+ {
+ /* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
+ symbols. */
+ SCM prompt = find_prompt (outer_key);
+ while (len)
+ {
+ frame = scm_stack_ref (stack, scm_from_long (len - 1));
+ len--;
+ if (SCM_PROMPT_REGISTERS (prompt)->fp
+ == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
+ break;
+ }
+ }
+ else
+ {
+ /* Cut specified number of frames. */
+ if (outer < len)
+ len -= outer;
+ else
+ len = 0;
+ }
+
+ SCM_SET_STACK_LENGTH (stack, len);
+}
+
+\f
+
+/* Stacks
+ */
+
+SCM scm_stack_type;
+
+SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a calling stack.")
+#define FUNC_NAME s_scm_stack_p
+{
+ 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"
+ "a continuation or a frame object).\n"
+ "\n"
+ "@var{args} should be a list containing any combination of\n"
+ "integer, procedure, prompt tag 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_i} can be @code{#t}, an integer, a prompt\n"
+ "tag, or a procedure. @code{#t} means to cut away all frames up\n"
+ "to but excluding the first user module frame. An integer means\n"
+ "to cut away exactly that number of frames. A prompt tag means\n"
+ "to cut away all frames that are inside a prompt with the given\n"
+ "tag. A procedure means to cut away all frames up to but\n"
+ "excluding the application frame whose procedure matches the\n"
+ "specified one.\n"
+ "\n"
+ "Each @var{outer_cut_i} can be an integer, a prompt tag, or a\n"
+ "procedure. An integer means to cut away that number of frames.\n"
+ "A prompt tag means to cut away all frames that are outside a\n"
+ "prompt with the given tag. A procedure means to cut away\n"
+ "frames down to but excluding the application frame whose\n"
+ "procedure matches the specified one.\n"
+ "\n"
+ "If the @var{outer_cut_i} of the last pair is missing, it is\n"
+ "taken as 0.")
+#define FUNC_NAME s_scm_make_stack
+{
+ long n;
+ SCM frame;
+ SCM stack;
+ SCM inner_cut, outer_cut;
+
+ /* Extract a pointer to the innermost frame of whatever object
+ scm_make_stack was given. */
+ if (scm_is_eq (obj, SCM_BOOL_T))
+ {
+ SCM cont;
+ struct scm_vm_cont *c;
+
+ cont = scm_i_vm_capture_continuation (scm_the_vm ());
+ c = SCM_VM_CONT_DATA (cont);
+
+ frame = scm_c_make_frame (cont, c->fp + c->reloc,
+ c->sp + c->reloc, c->ra,
+ c->reloc);
+ }
+ else if (SCM_VM_FRAME_P (obj))
+ frame = obj;
+ else if (SCM_CONTINUATIONP (obj))
+ /* FIXME: Narrowing to prompt tags should narrow with respect to the prompts
+ that were in place when the continuation was captured. */
+ frame = scm_i_continuation_to_frame (obj);
+ else
+ {
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
+ /* not reached */
+ }
+
+ /* FIXME: is this even possible? */
+ if (scm_is_true (frame)
+ && SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
+ frame = scm_frame_previous (frame);
+
+ if (scm_is_false (frame))
+ return SCM_BOOL_F;
+
+ /* Count number of frames. Also get stack id tag and check whether
+ there are more stackframes than we want to record
+ (SCM_BACKTRACE_MAXDEPTH). */
+ n = stack_depth (frame);
+
+ /* Make the stack object. */
+ stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
+ SCM_SET_STACK_LENGTH (stack, n);
+ SCM_SET_STACK_ID (stack, scm_stack_id (obj));
+ SCM_SET_STACK_FRAME (stack, frame);
+
+ /* Narrow the stack according to the arguments given to scm_make_stack. */
+ SCM_VALIDATE_REST_ARGUMENT (args);
+ while (n > 0 && !scm_is_null (args))
+ {
+ inner_cut = SCM_CAR (args);
+ args = SCM_CDR (args);
+ if (scm_is_null (args))
+ {
+ outer_cut = SCM_INUM0;
+ }
+ else
+ {
+ outer_cut = SCM_CAR (args);
+ args = SCM_CDR (args);
+ }
+
+ narrow_stack (stack,
+ scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n,
+ scm_is_integer (inner_cut) ? SCM_BOOL_T : inner_cut,
+ scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
+ scm_is_integer (outer_cut) ? SCM_BOOL_T : outer_cut);
+
+ n = SCM_STACK_LENGTH (stack);
+ }
+
+ if (n > 0)
+ return stack;
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
+ (SCM stack),
+ "Return the identifier given to @var{stack} by @code{start-stack}.")
+#define FUNC_NAME s_scm_stack_id
+{
+ if (scm_is_eq (stack, SCM_BOOL_T)
+ /* FIXME: frame case assumes frame still live on the stack, and no
+ intervening start-stack. Hmm... */
+ || SCM_VM_FRAME_P (stack))
+ {
+ /* Fetch most recent start-stack tag. */
+ SCM stacks = scm_fluid_ref (scm_sys_stacks);
+ return scm_is_pair (stacks) ? scm_caar (stacks) : SCM_BOOL_F;
+ }
+ else if (SCM_CONTINUATIONP (stack))
+ /* FIXME: implement me */
+ return SCM_BOOL_F;
+ else
+ {
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
+ /* not reached */
+ }
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
+ (SCM stack, SCM index),
+ "Return the @var{index}'th frame from @var{stack}.")
+#define FUNC_NAME s_scm_stack_ref
+{
+ unsigned long int c_index;
+ SCM frame;
+
+ SCM_VALIDATE_STACK (1, stack);
+ c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1);
+ frame = SCM_STACK_FRAME (stack);
+ while (c_index--)
+ frame = scm_frame_previous (frame);
+ return frame;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
+ (SCM stack),
+ "Return the length of @var{stack}.")
+#define FUNC_NAME s_scm_stack_length
+{
+ SCM_VALIDATE_STACK (1, stack);
+ return scm_from_long (SCM_STACK_LENGTH (stack));
+}
+#undef FUNC_NAME
+
+\f
+
+void
+scm_init_stacks ()
+{
+ scm_sys_stacks = scm_make_fluid ();
+ scm_c_define ("%stacks", scm_sys_stacks);
+
+ scm_stack_type = scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
+ SCM_UNDEFINED);
+ scm_set_struct_vtable_name_x (scm_stack_type,
+ scm_from_latin1_symbol ("stack"));
+#include "libguile/stacks.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff