summaryrefslogtreecommitdiff
path: root/libguile/stacks.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/stacks.c')
-rw-r--r--libguile/stacks.c286
1 files changed, 122 insertions, 164 deletions
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 51d89c9ac..6b6de12a8 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -42,6 +42,10 @@
*
* The author can be reached at djurfeldt@nada.kth.se
* Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
+
+/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
+ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
+
#include <stdio.h>
@@ -54,6 +58,7 @@
#include "procprop.h"
#include "modules.h"
+#include "scm_validate.h"
#include "stacks.h"
@@ -146,13 +151,8 @@
* DFRAME. OFFSET is used for relocation of pointers when the stack
* is read from a continuation.
*/
-static int stack_depth SCM_P ((scm_debug_frame *dframe, long offset, SCM *id, int *maxp));
static int
-stack_depth (dframe, offset, id, maxp)
- scm_debug_frame *dframe;
- long offset;
- SCM *id;
- int *maxp;
+stack_depth (scm_debug_frame *dframe,long offset,SCM *id,int *maxp)
{
int n, size;
int max_depth = SCM_BACKTRACE_MAXDEPTH;
@@ -185,12 +185,8 @@ stack_depth (dframe, offset, id, maxp)
/* Read debug info from DFRAME into IFRAME.
*/
-static void read_frame SCM_P ((scm_debug_frame *dframe, long offset, scm_info_frame *iframe));
static void
-read_frame (dframe, offset, iframe)
- scm_debug_frame *dframe;
- long offset;
- scm_info_frame *iframe;
+read_frame (scm_debug_frame *dframe,long offset,scm_info_frame *iframe)
{
SCM flags = SCM_INUM0;
int size;
@@ -259,13 +255,8 @@ get_applybody ()
* DFRAME.
*/
-static int read_frames SCM_P ((scm_debug_frame *dframe, long offset, int nframes, scm_info_frame *iframes));
static int
-read_frames (dframe, offset, n, iframes)
- scm_debug_frame *dframe;
- long offset;
- int n;
- scm_info_frame *iframes;
+read_frames (scm_debug_frame *dframe,long offset,int n,scm_info_frame *iframes)
{
int size;
scm_info_frame *iframe = iframes;
@@ -338,8 +329,6 @@ read_frames (dframe, offset, n, iframes)
return iframe - iframes; /* Number of frames actually read */
}
-static void narrow_stack SCM_P ((SCM stack, int inner, SCM inner_key, int outer, SCM outer_key));
-
/* Narrow STACK by cutting away stackframes (mutatingly).
*
* Inner frames (most recent) are cut by advancing the frames pointer.
@@ -362,12 +351,7 @@ static void narrow_stack SCM_P ((SCM stack, int inner, SCM inner_key, int outer,
*/
static void
-narrow_stack (stack, inner, inner_key, outer, outer_key)
- SCM stack;
- int inner;
- SCM inner_key;
- int outer;
- SCM outer_key;
+narrow_stack (SCM stack,int inner,SCM inner_key,int outer,SCM outer_key)
{
scm_stack *s = SCM_STACK (stack);
int i;
@@ -426,18 +410,19 @@ narrow_stack (stack, inner, inner_key, outer, outer_key)
SCM scm_stack_type;
-SCM_PROC (s_stack_p, "stack?", 1, 0, 0, scm_stack_p);
-SCM
-scm_stack_p (obj)
- SCM obj;
+GUILE_PROC (scm_stack_p, "stack?", 1, 0, 0,
+ (SCM obj),
+"")
+#define FUNC_NAME s_scm_stack_p
{
- return SCM_NIMP (obj) && SCM_STACKP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
+ return SCM_BOOL(SCM_NIMP (obj) && SCM_STACKP (obj));
}
+#undef FUNC_NAME
-SCM_PROC (s_make_stack, "make-stack", 0, 0, 1, scm_make_stack);
-SCM
-scm_make_stack (args)
- SCM args;
+GUILE_PROC (scm_make_stack, "make-stack", 0, 0, 1,
+ (SCM args),
+"")
+#define FUNC_NAME s_scm_make_stack
{
int n, maxp, size;
scm_debug_frame *dframe = scm_last_debug_frame;
@@ -447,9 +432,7 @@ scm_make_stack (args)
SCM obj, inner_cut, outer_cut;
SCM_ASSERT (SCM_NIMP (args) && SCM_CONSP (args),
- scm_makfrom0str (s_make_stack),
- SCM_WNA,
- NULL);
+ SCM_FUNC_NAME, SCM_WNA, NULL);
obj = SCM_CAR (args);
args = SCM_CDR (args);
@@ -459,7 +442,7 @@ scm_make_stack (args)
(from initialization of dframe, above) if obj is #t */
if (obj != SCM_BOOL_T)
{
- SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_make_stack);
+ 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))
@@ -473,7 +456,7 @@ scm_make_stack (args)
}
else
{
- scm_wta (obj, (char *) SCM_ARG1, s_make_stack);
+ scm_wta (obj, (char *) SCM_ARG1, FUNC_NAME);
abort ();
}
}
@@ -527,11 +510,12 @@ scm_make_stack (args)
else
return SCM_BOOL_F;
}
+#undef FUNC_NAME
-SCM_PROC (s_stack_id, "stack-id", 1, 0, 0, scm_stack_id);
-SCM
-scm_stack_id (stack)
- SCM stack;
+GUILE_PROC (scm_stack_id, "stack-id", 1, 0, 0,
+ (SCM stack),
+"")
+#define FUNC_NAME s_scm_stack_id
{
scm_debug_frame *dframe;
long offset = 0;
@@ -539,7 +523,7 @@ scm_stack_id (stack)
dframe = scm_last_debug_frame;
else
{
- SCM_ASSERT (SCM_NIMP (stack), stack, SCM_ARG1, s_make_stack);
+ SCM_VALIDATE_NIMP(1,stack);
if (SCM_DEBUGOBJP (stack))
dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (stack);
else if (scm_tc7_contin == SCM_TYP7 (stack))
@@ -554,7 +538,7 @@ scm_stack_id (stack)
else if (SCM_STACKP (stack))
return SCM_STACK (stack) -> id;
else
- scm_wrong_type_arg (s_stack_id, SCM_ARG1, stack);
+ SCM_WRONG_TYPE_ARG (1, stack);
}
while (dframe && !SCM_VOIDFRAMEP (*dframe))
dframe = RELOC_FRAME (dframe->prev, offset);
@@ -562,61 +546,54 @@ scm_stack_id (stack)
return dframe->vect[0].id;
return SCM_BOOL_F;
}
+#undef FUNC_NAME
-SCM_PROC (s_stack_ref, "stack-ref", 2, 0, 0, scm_stack_ref);
-SCM
-scm_stack_ref (stack, i)
- SCM stack;
- SCM i;
+GUILE_PROC (scm_stack_ref, "stack-ref", 2, 0, 0,
+ (SCM stack, SCM i),
+"")
+#define FUNC_NAME s_scm_stack_ref
{
- SCM_ASSERT (SCM_NIMP (stack)
- && SCM_STACKP (stack),
- stack,
- SCM_ARG1,
- s_stack_ref);
- SCM_ASSERT (SCM_INUMP (i), i, SCM_ARG2, s_stack_ref);
- SCM_ASSERT (SCM_INUM (i) >= 0
- && SCM_INUM (i) < SCM_STACK_LENGTH (stack),
- i,
- SCM_OUTOFRANGE,
- s_stack_ref);
+ SCM_VALIDATE_STACK(1,stack);
+ SCM_VALIDATE_INT(2,i);
+ SCM_ASSERT_RANGE (1,i,
+ SCM_INUM (i) >= 0 &&
+ SCM_INUM (i) < SCM_STACK_LENGTH (stack));
return scm_cons (stack, i);
}
+#undef FUNC_NAME
-SCM_PROC(s_stack_length, "stack-length", 1, 0, 0, scm_stack_length);
-SCM
-scm_stack_length (stack)
- SCM stack;
+GUILE_PROC(scm_stack_length, "stack-length", 1, 0, 0,
+ (SCM stack),
+"")
+#define FUNC_NAME s_scm_stack_length
{
- SCM_ASSERT (SCM_NIMP (stack)
- && SCM_STACKP (stack),
- stack,
- SCM_ARG1,
- s_stack_length);
+ SCM_VALIDATE_STACK(1,stack);
return SCM_MAKINUM (SCM_STACK_LENGTH (stack));
}
+#undef FUNC_NAME
/* Frames
*/
-SCM_PROC (s_frame_p, "frame?", 1, 0, 0, scm_frame_p);
-SCM
-scm_frame_p (obj)
- SCM obj;
+GUILE_PROC (scm_frame_p, "frame?", 1, 0, 0,
+ (SCM obj),
+"")
+#define FUNC_NAME s_scm_frame_p
{
- return SCM_NIMP (obj) && SCM_FRAMEP (obj);
+ return SCM_BOOL(SCM_NIMP (obj) && SCM_FRAMEP (obj));
}
+#undef FUNC_NAME
-SCM_PROC(s_last_stack_frame, "last-stack-frame", 1, 0, 0, scm_last_stack_frame);
-SCM
-scm_last_stack_frame (obj)
- SCM obj;
+GUILE_PROC(scm_last_stack_frame, "last-stack-frame", 1, 0, 0,
+ (SCM obj),
+"")
+#define FUNC_NAME s_scm_last_stack_frame
{
scm_debug_frame *dframe;
long offset = 0;
SCM stack;
- SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_last_stack_frame);
+ SCM_VALIDATE_NIMP(1,obj);
if (SCM_DEBUGOBJP (obj))
dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj);
else if (scm_tc7_contin == SCM_TYP7 (obj))
@@ -630,7 +607,7 @@ scm_last_stack_frame (obj)
}
else
{
- scm_wta (obj, (char *) SCM_ARG1, s_last_stack_frame);
+ SCM_WTA (1,obj);
abort ();
}
@@ -646,138 +623,119 @@ scm_last_stack_frame (obj)
return scm_cons (stack, SCM_INUM0);;
}
+#undef FUNC_NAME
-SCM_PROC(s_frame_number, "frame-number", 1, 0, 0, scm_frame_number);
-SCM
-scm_frame_number (frame)
- SCM frame;
+GUILE_PROC(scm_frame_number, "frame-number", 1, 0, 0,
+ (SCM frame),
+"")
+#define FUNC_NAME s_scm_frame_number
{
- SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
- frame,
- SCM_ARG1,
- s_frame_number);
+ SCM_VALIDATE_FRAME(1,frame);
return SCM_MAKINUM (SCM_FRAME_NUMBER (frame));
}
+#undef FUNC_NAME
-SCM_PROC(s_frame_source, "frame-source", 1, 0, 0, scm_frame_source);
-SCM
-scm_frame_source (frame)
- SCM frame;
+GUILE_PROC(scm_frame_source, "frame-source", 1, 0, 0,
+ (SCM frame),
+"")
+#define FUNC_NAME s_scm_frame_source
{
- SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
- frame,
- SCM_ARG1,
- s_frame_source);
+ SCM_VALIDATE_FRAME(1,frame);
return SCM_FRAME_SOURCE (frame);
}
+#undef FUNC_NAME
-SCM_PROC(s_frame_procedure, "frame-procedure", 1, 0, 0, scm_frame_procedure);
-SCM
-scm_frame_procedure (frame)
- SCM frame;
+GUILE_PROC(scm_frame_procedure, "frame-procedure", 1, 0, 0,
+ (SCM frame),
+"")
+#define FUNC_NAME s_scm_frame_procedure
{
- SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
- frame,
- SCM_ARG1,
- s_frame_procedure);
+ SCM_VALIDATE_FRAME(1,frame);
return (SCM_FRAME_PROC_P (frame)
? SCM_FRAME_PROC (frame)
: SCM_BOOL_F);
}
+#undef FUNC_NAME
-SCM_PROC(s_frame_arguments, "frame-arguments", 1, 0, 0, scm_frame_arguments);
-SCM
-scm_frame_arguments (frame)
- SCM frame;
+GUILE_PROC(scm_frame_arguments, "frame-arguments", 1, 0, 0,
+ (SCM frame),
+"")
+#define FUNC_NAME s_scm_frame_arguments
{
- SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
- frame,
- SCM_ARG1,
- s_frame_arguments);
+ SCM_VALIDATE_FRAME(1,frame);
return SCM_FRAME_ARGS (frame);
}
+#undef FUNC_NAME
-SCM_PROC(s_frame_previous, "frame-previous", 1, 0, 0, scm_frame_previous);
-SCM
-scm_frame_previous (frame)
- SCM frame;
+GUILE_PROC(scm_frame_previous, "frame-previous", 1, 0, 0,
+ (SCM frame),
+"")
+#define FUNC_NAME s_scm_frame_previous
{
int n;
- SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
- frame,
- SCM_ARG1,
- s_frame_previous);
+ SCM_VALIDATE_FRAME(1,frame);
n = SCM_INUM (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));
}
+#undef FUNC_NAME
-SCM_PROC(s_frame_next, "frame-next", 1, 0, 0, scm_frame_next);
-SCM
-scm_frame_next (frame)
- SCM frame;
+GUILE_PROC(scm_frame_next, "frame-next", 1, 0, 0,
+ (SCM frame),
+"")
+#define FUNC_NAME s_scm_frame_next
{
int n;
- SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
- frame,
- SCM_ARG1,
- s_frame_next);
+ SCM_VALIDATE_FRAME(1,frame);
n = SCM_INUM (SCM_CDR (frame)) - 1;
if (n < 0)
return SCM_BOOL_F;
else
return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n));
}
+#undef FUNC_NAME
-SCM_PROC(s_frame_real_p, "frame-real?", 1, 0, 0, scm_frame_real_p);
-SCM
-scm_frame_real_p (frame)
- SCM frame;
+GUILE_PROC(scm_frame_real_p, "frame-real?", 1, 0, 0,
+ (SCM frame),
+"")
+#define FUNC_NAME s_scm_frame_real_p
{
- SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
- frame,
- SCM_ARG1,
- s_frame_real_p);
- return SCM_FRAME_REAL_P (frame) ? SCM_BOOL_T : SCM_BOOL_F;
+ SCM_VALIDATE_FRAME(1,frame);
+ return SCM_BOOL(SCM_FRAME_REAL_P (frame));
}
+#undef FUNC_NAME
-SCM_PROC(s_frame_procedure_p, "frame-procedure?", 1, 0, 0, scm_frame_procedure_p);
-SCM
-scm_frame_procedure_p (frame)
- SCM frame;
+GUILE_PROC(scm_frame_procedure_p, "frame-procedure?", 1, 0, 0,
+ (SCM frame),
+"")
+#define FUNC_NAME s_scm_frame_procedure_p
{
- SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
- frame,
- SCM_ARG1,
- s_frame_procedure_p);
- return SCM_FRAME_PROC_P (frame) ? SCM_BOOL_T : SCM_BOOL_F;
+ SCM_VALIDATE_FRAME(1,frame);
+ return SCM_BOOL(SCM_FRAME_PROC_P (frame));
}
+#undef FUNC_NAME
-SCM_PROC(s_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0, scm_frame_evaluating_args_p);
-SCM
-scm_frame_evaluating_args_p (frame)
- SCM frame;
+GUILE_PROC(scm_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0,
+ (SCM frame),
+"")
+#define FUNC_NAME s_scm_frame_evaluating_args_p
{
- SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
- frame,
- SCM_ARG1,
- s_frame_evaluating_args_p);
- return SCM_FRAME_EVAL_ARGS_P (frame) ? SCM_BOOL_T : SCM_BOOL_F;
+ SCM_VALIDATE_FRAME(1,frame);
+ return SCM_BOOL(SCM_FRAME_EVAL_ARGS_P (frame));
}
+#undef FUNC_NAME
-SCM_PROC(s_frame_overflow_p, "frame-overflow?", 1, 0, 0, scm_frame_overflow_p);
-SCM
-scm_frame_overflow_p (frame)
- SCM frame;
+GUILE_PROC(scm_frame_overflow_p, "frame-overflow?", 1, 0, 0,
+ (SCM frame),
+"")
+#define FUNC_NAME s_scm_frame_overflow_p
{
- SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
- frame,
- SCM_ARG1,
- s_frame_overflow_p);
+ SCM_VALIDATE_FRAME(1,frame);
return SCM_FRAME_OVERFLOW_P (frame) ? SCM_BOOL_T : SCM_BOOL_F;
}
+#undef FUNC_NAME