summaryrefslogtreecommitdiff
path: root/libguile/debug.c
diff options
context:
space:
mode:
authorGreg J. Badros <gjb@cs.washington.edu>1999-12-12 02:36:16 +0000
committerGreg J. Badros <gjb@cs.washington.edu>1999-12-12 02:36:16 +0000
commit1bbd0b849f6b90f1ffe57e586e4ee5a884f84a11 (patch)
tree79120a96365e0fa3324174bfd08d731ca8311d64 /libguile/debug.c
parent6e7069385db8cf96dfbe51cf65ace161942a32c9 (diff)
downloadguile-1bbd0b849f6b90f1ffe57e586e4ee5a884f84a11.tar.gz
* *.c: Pervasive software-engineering-motivated rewrite of
function headers and argument checking. Switched SCM_PROC, SCM_PROC1 macros to be GUILE_PROC, GUILE_PROC1 (may change names later, but was useful to keep old versions around while migrate) that has docstrings and argument lists embedded in the GUILE_PROC macro invocations that expand into a function header. Use lots of new SCM_VALIDATE_* macros to simplify error checking and reduce tons of redundancy. This is very similar to what I did for Scwm. Note that none of the extraction of the docstrings, nor software engineering checks of Scwm is yet added to Guile. I'll work on that tomorrow, I expect. * Makefile.am: Added scm_validate.h to modinclude_HEADERS. * chars.c: Added docstrings for the primitives defined in here. * snarf.h: Added GUILE_PROC, GUILE_PROC1. Added SCM_REGISTER_PROC to be like old SCM_PROC, though old SCM_PROC still remains for now. Changed naming convention for the s_foo string name of the primitive to be s_scm_foo for ease of use with the macro. * scm_validate.h: Lots of new SCM_VALIDATE macros to simplify argument checking through guile. Maybe some of these should be folded into the header file for the types they check, but for now it was easiest to just stick them all in one place.
Diffstat (limited to 'libguile/debug.c')
-rw-r--r--libguile/debug.c281
1 files changed, 124 insertions, 157 deletions
diff --git a/libguile/debug.c b/libguile/debug.c
index 2df0ebe96..92fb2e138 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -43,6 +43,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>
#include "_scm.h"
#include "eval.h"
@@ -61,29 +65,29 @@
#include "dynwind.h"
#include "modules.h"
+#include "scm_validate.h"
#include "debug.h"
/* {Run time control of the debugging evaluator}
*/
-SCM_PROC (s_debug_options, "debug-options-interface", 0, 1, 0, scm_debug_options);
-
-SCM
-scm_debug_options (setting)
- SCM setting;
+GUILE_PROC (scm_debug_options, "debug-options-interface", 0, 1, 0,
+ (SCM setting),
+"")
+#define FUNC_NAME s_scm_debug_options
{
SCM ans;
SCM_DEFER_INTS;
ans = scm_options (setting,
scm_debug_opts,
SCM_N_DEBUG_OPTIONS,
- s_debug_options);
+ FUNC_NAME);
#ifndef SCM_RECKLESS
if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE))
{
- scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, s_debug_options);
- scm_out_of_range (s_debug_options, setting);
+ scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME);
+ scm_out_of_range (FUNC_NAME, setting);
}
#endif
SCM_RESET_DEBUG_MODE;
@@ -92,8 +96,7 @@ scm_debug_options (setting)
SCM_ALLOW_INTS;
return ans;
}
-
-SCM_PROC (s_with_traps, "with-traps", 1, 0, 0, scm_with_traps);
+#undef FUNC_NAME
static void
with_traps_before (void *data)
@@ -117,20 +120,20 @@ with_traps_inner (void *data)
return scm_apply (thunk, SCM_EOL, SCM_EOL);
}
-SCM
-scm_with_traps (SCM thunk)
+GUILE_PROC (scm_with_traps, "with-traps", 1, 0, 0,
+ (SCM thunk),
+"")
+#define FUNC_NAME s_scm_with_traps
{
int trap_flag;
- SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)),
- thunk,
- SCM_ARG1,
- s_with_traps);
+ SCM_VALIDATE_THUNK(1,thunk);
return scm_internal_dynamic_wind (with_traps_before,
with_traps_inner,
with_traps_after,
(void *) thunk,
&trap_flag);
}
+#undef FUNC_NAME
static SCM scm_sym_source, scm_sym_dots;
@@ -142,13 +145,8 @@ static SCM scm_sym_procname;
long scm_tc16_memoized;
-static int prinmemoized SCM_P ((SCM obj, SCM port, scm_print_state *pstate));
-
static int
-prinmemoized (obj, port, pstate)
- SCM obj;
- SCM port;
- scm_print_state *pstate;
+prinmemoized (SCM obj,SCM port,scm_print_state *pstate)
{
int writingp = SCM_WRITINGP (pstate);
scm_puts ("#<memoized ", port);
@@ -163,19 +161,17 @@ prinmemoized (obj, port, pstate)
return 1;
}
-SCM_PROC (s_memoized_p, "memoized?", 1, 0, 0, scm_memoized_p);
-
-SCM
-scm_memoized_p (obj)
- SCM obj;
+GUILE_PROC (scm_memoized_p, "memoized?", 1, 0, 0,
+ (SCM obj),
+"")
+#define FUNC_NAME s_scm_memoized_p
{
- return SCM_NIMP (obj) && SCM_MEMOIZEDP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
+ return SCM_BOOL(SCM_NIMP (obj) && SCM_MEMOIZEDP (obj));
}
+#undef FUNC_NAME
SCM
-scm_make_memoized (exp, env)
- SCM exp;
- SCM env;
+scm_make_memoized (SCM exp, SCM env)
{
/* *fixme* Check that env is a valid environment. */
register SCM z, ans;
@@ -254,77 +250,63 @@ scm_make_memoized (exp, env)
#include "variable.h"
#include "procs.h"
-SCM_PROC (s_make_gloc, "make-gloc", 1, 1, 0, scm_make_gloc);
-
-SCM
-scm_make_gloc (var, env)
- SCM var;
- SCM env;
+GUILE_PROC (scm_make_gloc, "make-gloc", 1, 1, 0,
+ (SCM var, SCM env),
+"")
+#define FUNC_NAME s_scm_make_gloc
{
#if 1 /* Unsafe */
if (SCM_NIMP (var) && SCM_CONSP (var))
var = scm_cons (SCM_BOOL_F, var);
else
#endif
- SCM_ASSERT (SCM_NIMP (var) && SCM_VARIABLEP (var),
- var,
- SCM_ARG1,
- s_make_gloc);
+ SCM_VALIDATE_VARIABLE(1,var);
if (SCM_UNBNDP (env))
env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var));
else
- SCM_ASSERT (SCM_NULLP (env) || (SCM_NIMP (env) && SCM_CONSP (env)),
- env,
- SCM_ARG2,
- s_make_gloc);
+ SCM_VALIDATE_NULLORCONS(2,env);
return scm_make_memoized (SCM_VARVCELL (var) + 1, env);
}
+#undef FUNC_NAME
-SCM_PROC (s_gloc_p, "gloc?", 1, 0, 0, scm_gloc_p);
-
-SCM
-scm_gloc_p (obj)
- SCM obj;
+GUILE_PROC (scm_gloc_p, "gloc?", 1, 0, 0,
+ (SCM obj),
+"")
+#define FUNC_NAME s_scm_gloc_p
{
- return ((SCM_NIMP (obj)
- && SCM_MEMOIZEDP (obj)
- && (SCM_MEMOIZED_EXP (obj) & 7) == 1)
- ? SCM_BOOL_T
- : SCM_BOOL_F);
+ return SCM_BOOL((SCM_NIMP (obj)
+ && SCM_MEMOIZEDP (obj)
+ && (SCM_MEMOIZED_EXP (obj) & 7) == 1));
}
+#undef FUNC_NAME
-SCM_PROC (s_make_iloc, "make-iloc", 3, 0, 0, scm_make_iloc);
-
-SCM
-scm_make_iloc (frame, binding, cdrp)
- SCM frame;
- SCM binding;
- SCM cdrp;
+GUILE_PROC (scm_make_iloc, "make-iloc", 3, 0, 0,
+ (SCM frame, SCM binding, SCM cdrp),
+"")
+#define FUNC_NAME s_scm_make_iloc
{
- SCM_ASSERT (SCM_INUMP (frame), frame, SCM_ARG1, s_make_iloc);
- SCM_ASSERT (SCM_INUMP (binding), binding, SCM_ARG2, s_make_iloc);
+ SCM_VALIDATE_INT(1,frame);
+ SCM_VALIDATE_INT(2,binding)
return (SCM_ILOC00
+ SCM_IFRINC * SCM_INUM (frame)
+ (SCM_NFALSEP (cdrp) ? SCM_ICDR : 0)
+ SCM_IDINC * SCM_INUM (binding));
}
+#undef FUNC_NAME
-SCM_PROC (s_iloc_p, "iloc?", 1, 0, 0, scm_iloc_p);
-
-SCM
-scm_iloc_p (obj)
- SCM obj;
+GUILE_PROC (scm_iloc_p, "iloc?", 1, 0, 0,
+ (SCM obj),
+"")
+#define FUNC_NAME s_scm_iGUILE_p
{
- return SCM_ILOCP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
+ return SCM_BOOL(SCM_ILOCP (obj));
}
+#undef FUNC_NAME
-SCM_PROC (s_memcons, "memcons", 2, 1, 0, scm_memcons);
-
-SCM
-scm_memcons (car, cdr, env)
- SCM car;
- SCM cdr;
- SCM env;
+GUILE_PROC (scm_memcons, "memcons", 2, 1, 0,
+ (SCM car, SCM cdr, SCM env),
+"")
+#define FUNC_NAME s_scm_memcons
{
if (SCM_NIMP (car) && SCM_MEMOIZEDP (car))
{
@@ -356,18 +338,15 @@ scm_memcons (car, cdr, env)
s_make_iloc);
return scm_make_memoized (scm_cons (car, cdr), env);
}
+#undef FUNC_NAME
-SCM_PROC (s_mem_to_proc, "mem->proc", 1, 0, 0, scm_mem_to_proc);
-
-SCM
-scm_mem_to_proc (obj)
- SCM obj;
+GUILE_PROC (scm_mem_to_proc, "mem->proc", 1, 0, 0,
+ (SCM obj),
+"")
+#define FUNC_NAME s_scm_mem_to_proc
{
SCM env;
- SCM_ASSERT (SCM_NIMP (obj) && SCM_MEMOIZEDP (obj),
- obj,
- SCM_ARG1,
- s_mem_to_proc);
+ SCM_VALIDATE_MEMOIZED(1,obj);
env = SCM_MEMOIZED_ENV (obj);
obj = SCM_MEMOIZED_EXP (obj);
if (!(SCM_NIMP (obj) && SCM_CAR (obj) == SCM_IM_LAMBDA))
@@ -376,53 +355,47 @@ scm_mem_to_proc (obj)
scm_cons (obj, SCM_EOL));
return scm_closure (SCM_CDR (obj), env);
}
+#undef FUNC_NAME
-SCM_PROC (s_proc_to_mem, "proc->mem", 1, 0, 0, scm_proc_to_mem);
-
-SCM
-scm_proc_to_mem (obj)
- SCM obj;
+GUILE_PROC (scm_proc_to_mem, "proc->mem", 1, 0, 0,
+ (SCM obj),
+"")
+#define FUNC_NAME s_scm_proc_to_mem
{
- SCM_ASSERT (SCM_NIMP (obj) && SCM_CLOSUREP (obj),
- obj,
- SCM_ARG1,
- s_proc_to_mem);
+ SCM_VALIDATE_CLOSURE(1,obj)
return scm_make_memoized (scm_cons (SCM_IM_LAMBDA, SCM_CODE (obj)),
SCM_ENV (obj));
}
+#undef FUNC_NAME
#endif /* GUILE_DEBUG */
-SCM_PROC (s_unmemoize, "unmemoize", 1, 0, 0, scm_unmemoize);
-
-SCM
-scm_unmemoize (m)
- SCM m;
+GUILE_PROC (scm_unmemoize, "unmemoize", 1, 0, 0,
+ (SCM m),
+"")
+#define FUNC_NAME s_scm_unmemoize
{
- SCM_ASSERT (SCM_NIMP (m) && SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize);
+ SCM_VALIDATE_MEMOIZED(1,m);
return scm_unmemocopy (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m));
}
+#undef FUNC_NAME
-SCM_PROC (s_memoized_environment, "memoized-environment", 1, 0, 0, scm_memoized_environment);
-
-SCM
-scm_memoized_environment (m)
- SCM m;
+GUILE_PROC (scm_memoized_environment, "memoized-environment", 1, 0, 0,
+ (SCM m),
+"")
+#define FUNC_NAME s_scm_memoized_environment
{
- SCM_ASSERT (SCM_NIMP (m) && SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize);
+ SCM_VALIDATE_MEMOIZED(1,m);
return SCM_MEMOIZED_ENV (m);
}
+#undef FUNC_NAME
-SCM_PROC (s_procedure_name, "procedure-name", 1, 0, 0, scm_procedure_name);
-
-SCM
-scm_procedure_name (proc)
- SCM proc;
+GUILE_PROC (scm_procedure_name, "procedure-name", 1, 0, 0,
+ (SCM proc),
+"")
+#define FUNC_NAME s_scm_procedure_name
{
- SCM_ASSERT(scm_procedure_p (proc) == SCM_BOOL_T,
- proc,
- SCM_ARG1,
- s_procedure_name);
+ SCM_VALIDATE_PROC(1,proc);
switch (SCM_TYP7 (proc)) {
case scm_tcs_subrs:
return SCM_SNAME (proc);
@@ -441,14 +414,14 @@ scm_procedure_name (proc)
}
}
}
+#undef FUNC_NAME
-SCM_PROC (s_procedure_source, "procedure-source", 1, 0, 0, scm_procedure_source);
-
-SCM
-scm_procedure_source (proc)
- SCM proc;
+GUILE_PROC (scm_procedure_source, "procedure-source", 1, 0, 0,
+ (SCM proc),
+"")
+#define FUNC_NAME s_scm_procedure_source
{
- SCM_ASSERT(SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_source);
+ SCM_VALIDATE_NIMP(1,proc);
switch (SCM_TYP7 (proc)) {
case scm_tcs_closures:
{
@@ -472,18 +445,18 @@ scm_procedure_source (proc)
built in procedures! */
return scm_procedure_property (proc, scm_sym_source);
default:
- scm_wta (proc, (char *) SCM_ARG1, s_procedure_source);
+ SCM_WTA(1,proc);
return 0;
}
}
+#undef FUNC_NAME
-SCM_PROC (s_procedure_environment, "procedure-environment", 1, 0, 0, scm_procedure_environment);
-
-SCM
-scm_procedure_environment (proc)
- SCM proc;
+GUILE_PROC (scm_procedure_environment, "procedure-environment", 1, 0, 0,
+ (SCM proc),
+"")
+#define FUNC_NAME s_scm_procedure_environment
{
- SCM_ASSERT (SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_environment);
+ SCM_VALIDATE_NIMP(1,proc);
switch (SCM_TYP7 (proc)) {
case scm_tcs_closures:
return SCM_ENV (proc);
@@ -494,10 +467,11 @@ scm_procedure_environment (proc)
#endif
return SCM_EOL;
default:
- scm_wta (proc, (char *) SCM_ARG1, s_procedure_environment);
+ SCM_WTA(1,proc);
return 0;
}
}
+#undef FUNC_NAME
@@ -507,23 +481,22 @@ scm_procedure_environment (proc)
* the code before evaluating. One solution would be to have eval.c
* generate yet another evaluator. They are not very big actually.
*/
-SCM_PROC (s_local_eval, "local-eval", 1, 1, 0, scm_local_eval);
-
-SCM
-scm_local_eval (exp, env)
- SCM exp;
- SCM env;
+GUILE_PROC (scm_local_eval, "local-eval", 1, 1, 0,
+ (SCM exp, SCM env),
+"")
+#define FUNC_NAME s_scm_local_eval
{
if (SCM_UNBNDP (env))
{
- SCM_ASSERT (SCM_NIMP (exp) && SCM_MEMOIZEDP (exp), exp, SCM_ARG1, s_local_eval);
+ SCM_VALIDATE_MEMOIZED(1,exp);
return scm_eval_3 (SCM_MEMOIZED_EXP (exp), 0, SCM_MEMOIZED_ENV (exp));
}
return scm_eval_3 (exp, 1, env);
}
+#undef FUNC_NAME
#if 0
-SCM_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
+SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
#endif
SCM
@@ -593,13 +566,8 @@ scm_m_start_stack (exp, env)
long scm_tc16_debugobj;
-static int prindebugobj SCM_P ((SCM obj, SCM port, scm_print_state *pstate));
-
static int
-prindebugobj (obj, port, pstate)
- SCM obj;
- SCM port;
- scm_print_state *pstate;
+prindebugobj (SCM obj,SCM port,scm_print_state *pstate)
{
scm_puts ("#<debug-object ", port);
scm_intprint (SCM_DEBUGOBJ_FRAME (obj), 16, port);
@@ -607,19 +575,18 @@ prindebugobj (obj, port, pstate)
return 1;
}
-SCM_PROC (s_debug_object_p, "debug-object?", 1, 0, 0, scm_debug_object_p);
-
-SCM
-scm_debug_object_p (obj)
- SCM obj;
+GUILE_PROC (scm_debug_object_p, "debug-object?", 1, 0, 0,
+ (SCM obj),
+"")
+#define FUNC_NAME s_scm_debug_object_p
{
- return SCM_NIMP (obj) && SCM_DEBUGOBJP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
+ return SCM_BOOL(SCM_NIMP (obj) && SCM_DEBUGOBJP (obj));
}
+#undef FUNC_NAME
SCM
-scm_make_debugobj (frame)
- scm_debug_frame *frame;
+scm_make_debugobj (scm_debug_frame *frame)
{
register SCM z;
SCM_NEWCELL (z);
@@ -634,16 +601,16 @@ scm_make_debugobj (frame)
/* Undocumented debugging procedure */
#ifdef GUILE_DEBUG
-SCM_PROC (s_debug_hang, "debug-hang", 0, 1, 0, scm_debug_hang);
-
-SCM
-scm_debug_hang (obj)
- SCM obj;
+GUILE_PROC (scm_debug_hang, "debug-hang", 0, 1, 0,
+ (SCM obj),
+"")
+#define FUNC_NAME s_scm_debug_hang
{
int go = 0;
while (!go) ;
return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
#endif