summaryrefslogtreecommitdiff
path: root/libguile/stacks.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/stacks.c')
-rw-r--r--libguile/stacks.c345
1 files changed, 92 insertions, 253 deletions
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 16c851f6e..21c288fcf 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -1,4 +1,4 @@
-/* Representation of stack frame debug information
+/* A stack holds a frame chain
* Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
@@ -42,14 +42,10 @@
-/* {Frames and stacks}
+/* {Stacks}
*
- * 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.
+ * The stack is represented as a struct that holds a frame. The frame itself is
+ * linked to the next frame, or #f.
*
* Stacks
* Constructor
@@ -59,71 +55,26 @@
* 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? */
+ */
-static SCM stack_id_with_fp (SCM vmframe, SCM **fp);
+static SCM stack_id_with_fp (SCM frame, SCM **fp);
-/* Count number of debug info frames on a stack, beginning with VMFRAME.
+/* Count number of debug info frames on a stack, beginning with FRAME.
*/
static long
-stack_depth (SCM vmframe, SCM *fp)
+stack_depth (SCM frame, SCM *fp)
{
long n;
- /* count vmframes, skipping boot frames */
- for (; scm_is_true (vmframe) && SCM_VM_FRAME_FP (vmframe) > fp;
- vmframe = scm_c_vm_frame_prev (vmframe))
- if (!SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe)))
+ /* count frames, skipping boot frames */
+ for (; scm_is_true (frame) && SCM_VM_FRAME_FP (frame) > fp;
+ frame = scm_c_frame_prev (frame))
+ if (!SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
++n;
return n;
}
-/* Fill the scm_t_info_frame vector IFRAME with data from N stack frames
- * starting with the first stack frame represented by VMFRAME.
- */
-
-static scm_t_bits
-read_frames (SCM vmframe, long n, scm_t_info_frame *iframes)
-{
- scm_t_info_frame *iframe = iframes;
-
- 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 */
- continue;
- 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)
- break;
- }
- }
- 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.
@@ -148,33 +99,48 @@ read_frames (SCM vmframe, long n, scm_t_info_frame *iframes)
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;
+ unsigned long int len;
+ SCM frame;
+ len = SCM_STACK_LENGTH (stack);
+ frame = SCM_STACK_FRAME (stack);
+
/* 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)
- ;
+ /* Cut specified number of frames. */
+ for (; inner && len; --inner)
+ {
+ len--;
+ frame = scm_c_frame_prev (frame);
+ }
}
else
- /* Use standard cutting procedure. */
{
- for (i = 0; inner; --inner)
- if (scm_is_eq (s->frames[i++].proc, inner_key))
- break;
+ /* Cut until the given procedure is seen. */
+ for (; inner && len ; --inner)
+ {
+ SCM proc = scm_frame_procedure (frame);
+ len--;
+ frame = scm_c_frame_prev (frame);
+ if (scm_is_eq (proc, inner_key))
+ break;
+ }
}
- s->frames = &s->frames[i];
- n -= i;
+
+ SCM_SET_STACK_LENGTH (stack, len);
+ SCM_SET_STACK_FRAME (stack, frame);
/* Cut outer part. */
- for (; n && outer; --outer)
- if (scm_is_eq (s->frames[--n].proc, outer_key))
- break;
+ 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;
+ }
- s->length = n;
+ SCM_SET_STACK_LENGTH (stack, len);
}
@@ -220,10 +186,9 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
"taken as 0.")
#define FUNC_NAME s_scm_make_stack
{
- long n, size;
+ long n;
int maxp;
- scm_t_info_frame *iframe;
- SCM vmframe;
+ SCM frame;
SCM stack;
SCM id, *id_fp;
SCM inner_cut, outer_cut;
@@ -232,11 +197,18 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
scm_make_stack was given. */
if (scm_is_eq (obj, SCM_BOOL_T))
{
- struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
- vmframe = scm_c_make_vm_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
+ SCM cont;
+ struct scm_vm_cont *c;
+
+ cont = scm_cdar (scm_vm_capture_continuations ());
+ c = SCM_VM_CONT_DATA (cont);
+
+ frame = scm_c_make_frame (cont, c->fp + c->reloc,
+ c->sp + c->reloc, c->ip,
+ c->reloc);
}
else if (SCM_VM_FRAME_P (obj))
- vmframe = obj;
+ frame = obj;
else if (SCM_CONTINUATIONP (obj))
{
scm_t_contregs *cont = SCM_CONTREGS (obj);
@@ -245,13 +217,13 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
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);
+ frame = scm_c_make_frame (vm_cont,
+ data->fp + data->reloc,
+ data->sp + data->reloc,
+ data->ip,
+ data->reloc);
} else
- vmframe = SCM_BOOL_F;
+ frame = SCM_BOOL_F;
}
else
{
@@ -259,36 +231,25 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
/* not reached */
}
- if (scm_is_false (vmframe))
+ if (scm_is_false (frame))
return SCM_BOOL_F;
/* Get ID of the stack corresponding to the given frame. */
- id = stack_id_with_fp (vmframe, &id_fp);
+ id = stack_id_with_fp (frame, &id_fp);
/* 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 (vmframe, id_fp);
- /* FIXME: redo maxp? */
- size = n * SCM_FRAME_N_SLOTS;
+ n = stack_depth (frame, id_fp);
/* 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 (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;
- }
-
+ stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
+ SCM_SET_STACK_LENGTH (stack, n);
+ SCM_SET_STACK_ID (stack, id);
+ 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))
@@ -311,12 +272,9 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
scm_is_integer (outer_cut) ? 0 : outer_cut);
- n = SCM_STACK (stack) -> length;
+ n = SCM_STACK_LENGTH (stack);
}
- if (n > 0 && maxp)
- iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
-
if (n > 0)
return stack;
else
@@ -329,15 +287,15 @@ 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 vmframe, *id_fp;
+ SCM frame, *id_fp;
if (scm_is_eq (stack, SCM_BOOL_T))
{
struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
- vmframe = scm_c_make_vm_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
+ frame = scm_c_make_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
}
else if (SCM_VM_FRAME_P (stack))
- vmframe = stack;
+ frame = stack;
else if (SCM_CONTINUATIONP (stack))
{
scm_t_contregs *cont = SCM_CONTREGS (stack);
@@ -346,13 +304,13 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
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);
+ frame = scm_c_make_frame (vm_cont,
+ data->fp + data->reloc,
+ data->sp + data->reloc,
+ data->ip,
+ data->reloc);
} else
- vmframe = SCM_BOOL_F;
+ frame = SCM_BOOL_F;
}
else
{
@@ -360,14 +318,14 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
/* not reached */
}
- return stack_id_with_fp (vmframe, &id_fp);
+ return stack_id_with_fp (frame, &id_fp);
}
#undef FUNC_NAME
static SCM
-stack_id_with_fp (SCM vmframe, SCM **fp)
+stack_id_with_fp (SCM frame, SCM **fp)
{
- SCM holder = SCM_VM_FRAME_STACK_HOLDER (vmframe);
+ SCM holder = SCM_VM_FRAME_STACK_HOLDER (frame);
if (SCM_VM_CONT_P (holder))
{
@@ -387,10 +345,18 @@ SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
#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);
- return scm_cons (stack, index);
+ frame = SCM_STACK_FRAME (stack);
+ while (c_index--)
+ {
+ frame = scm_c_frame_prev (frame);
+ while (SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
+ frame = scm_c_frame_prev (frame);
+ }
+ return frame;
}
#undef FUNC_NAME
@@ -400,134 +366,7 @@ SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
#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_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));
+ return scm_from_long (SCM_STACK_LENGTH (stack));
}
#undef FUNC_NAME