diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 3c8af2027..83d86343c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +2001-03-04 Dirk Herrmann + + * continuations.c (continuation_apply), eval.c (scm_m_lambda, + scm_m_letstar, scm_m_letrec1, scm_m_let, SCM_APPLY), eval.h + (SCM_EVALIM2), evalext.c (scm_m_generalized_set_x), gc.c + (get_bvec, MARK), goops.c (scm_primitive_generic_generic), + options.c (scm_options), ports.c (scm_remove_from_port_table), + ramap.c (scm_ramapc), read.c (skip_scsh_block_comment, scm_lreadr, + scm_lreadparen, scm_lreadrecparen), script.c (script_get_octal, + script_get_backslash, script_read_arg), unif.c (scm_cvref): Don't + call function scm_wta, call scm_misc_error or scm_wrong_type_arg + instead. + 2001-03-04 Mikael Djurfeldt * goops.c (scm_sys_pre_expand_closure_x): New procedure. diff --git a/libguile/continuations.c b/libguile/continuations.c index ee1e7cb77..3b07e1f06 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -59,6 +59,7 @@ #include "libguile/debug.h" #endif +#include "libguile/validate.h" #include "libguile/continuations.h" @@ -219,8 +220,10 @@ scm_dynthrow (SCM cont, SCM val) copy_stack_and_call (continuation, val, dst); } + +static SCM +continuation_apply (SCM cont, SCM args) #define FUNC_NAME "continuation_apply" -static SCM continuation_apply (SCM cont, SCM args) { scm_contregs *continuation = SCM_CONTREGS (cont); scm_contregs *rootcont = SCM_CONTREGS (scm_rootcont); @@ -229,7 +232,8 @@ static SCM continuation_apply (SCM cont, SCM args) /* this base comparison isn't needed */ || continuation->base != rootcont->base) { - scm_wta (cont, "continuation from wrong top level", FUNC_NAME); + SCM_MISC_ERROR ("continuation from wrong top level: ~S", + SCM_LIST1 (cont)); } scm_dowinds (continuation->dynenv, @@ -241,6 +245,7 @@ static SCM continuation_apply (SCM cont, SCM args) } #undef FUNC_NAME + void scm_init_continuations () { diff --git a/libguile/eval.c b/libguile/eval.c index f9ed72ffc..90ba9973b 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -681,13 +681,13 @@ scm_m_lambda (SCM xorig, SCM env) if (!SCM_SYMBOLP (SCM_CAR (proc))) goto badforms; else if (scm_c_improper_memq (SCM_CAR(proc), SCM_CDR(proc))) - scm_wta (xorig, scm_s_duplicate_formals, s_lambda); + scm_misc_error (s_lambda, scm_s_duplicate_formals, SCM_EOL); proc = SCM_CDR (proc); } if (SCM_NNULLP (proc)) { badforms: - scm_wta (xorig, scm_s_formals, s_lambda); + scm_misc_error (s_lambda, scm_s_formals, SCM_EOL); } memlambda: @@ -713,7 +713,7 @@ scm_m_letstar (SCM xorig, SCM env) SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, s_letstar); SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, s_letstar); if (scm_c_improper_memq (SCM_CAR (arg1), vars)) - scm_wta (xorig, scm_s_duplicate_bindings, s_letstar); + scm_misc_error (s_letstar, scm_s_duplicate_bindings, SCM_EOL); *varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL); varloc = SCM_CDRLOC (SCM_CDR (*varloc)); proc = SCM_CDR (proc); @@ -920,7 +920,7 @@ scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env) SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, what); SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, what); if (scm_c_improper_memq (SCM_CAR (arg1), vars)) - scm_wta (xorig, scm_s_duplicate_bindings, what); + scm_misc_error (what, scm_s_duplicate_bindings, SCM_EOL); vars = scm_cons (SCM_CAR (arg1), vars); *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL); initloc = SCM_CDRLOC (*initloc); @@ -982,7 +982,7 @@ scm_m_let (SCM xorig, SCM env) } if (!SCM_SYMBOLP (proc)) - scm_wta (xorig, scm_s_bindings, s_let); /* bad let */ + scm_misc_error (s_let, scm_s_bindings, SCM_EOL); /* bad let */ name = proc; /* named let, build equiv letrec */ x = SCM_CDR (x); SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_let); @@ -3559,7 +3559,7 @@ tail: scm_wrong_num_args (proc); default: badproc: - scm_wta (proc, (char *) SCM_ARG1, "apply"); + scm_wrong_type_arg ("apply", SCM_ARG1, proc); RETURN (arg1); } #ifdef DEVAL diff --git a/libguile/eval.h b/libguile/eval.h index 450a7f754..0db28526f 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -98,7 +98,7 @@ extern SCM scm_eval_options_interface (SCM setting); * For an explanation of symbols containing "EVAL", see beginning of eval.c. */ #define SCM_EVALIM2(x) (((x) == SCM_EOL) \ - ? scm_wta ((x), scm_s_expression, NULL) \ + ? scm_misc_error (NULL, scm_s_expression, SCM_EOL), 0 \ : (x)) #ifdef MEMOIZE_LOCALS #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \ diff --git a/libguile/evalext.c b/libguile/evalext.c index b9e0130c3..d24a543be 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -65,7 +65,8 @@ scm_m_generalized_set_x (SCM xorig, SCM env) else if (SCM_CONSP (SCM_CAR (x))) return scm_cons (SCM_LIST2 (scm_sym_setter, SCM_CAAR (x)), scm_append (SCM_LIST2 (SCM_CDAR (x), SCM_CDR (x)))); - return scm_wta (xorig, scm_s_variable, scm_s_set_x); + else + scm_misc_error (scm_s_set_x, scm_s_variable, SCM_EOL); } SCM_DEFINE (scm_definedp, "defined?", 1, 1, 0, diff --git a/libguile/gc.c b/libguile/gc.c index 60aaad34f..038822a50 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -408,6 +408,7 @@ static scm_mark_space_t *mark_space_head; static scm_c_bvec_limb_t * get_bvec () +#define FUNC_NAME "get_bvec" { scm_c_bvec_limb_t *res; @@ -415,7 +416,7 @@ get_bvec () { SCM_SYSCALL (current_mark_space = (scm_mark_space_t *) malloc (sizeof (scm_mark_space_t))); if (!current_mark_space) - scm_wta (SCM_UNDEFINED, "could not grow", "heap"); + SCM_MISC_ERROR ("could not grow heap", SCM_EOL); current_mark_space->bvec_space = NULL; current_mark_space->next = NULL; @@ -431,7 +432,7 @@ get_bvec () SCM_SYSCALL (current_mark_space->bvec_space = (scm_c_bvec_limb_t *) calloc (BVEC_GROW_SIZE_IN_BYTES, 1)); if (!(current_mark_space->bvec_space)) - scm_wta (SCM_UNDEFINED, "could not grow", "heap"); + SCM_MISC_ERROR ("could not grow heap", SCM_EOL); current_mark_space_offset = 0; @@ -450,6 +451,8 @@ get_bvec () return res; } +#undef FUNC_NAME + static void clear_mark_space () @@ -1143,7 +1146,7 @@ gc_mark_loop_first_time: #if (defined (GUILE_DEBUG_FREELIST)) if (SCM_GC_IN_CARD_HEADERP (SCM2PTR (ptr))) - scm_wta (ptr, "rogue pointer in heap", NULL); + SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL); #endif diff --git a/libguile/goops.c b/libguile/goops.c index d42ff2b51..e4dff3da8 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1644,7 +1644,7 @@ SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0, if (gf) return gf; } - return scm_wta (subr, (char *) SCM_ARG1, FUNC_NAME); + SCM_WRONG_TYPE_ARG (SCM_ARG1, subr); } #undef FUNC_NAME diff --git a/libguile/options.c b/libguile/options.c index 94e74d573..5bd622d30 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -190,7 +190,8 @@ scm_options (SCM arg, scm_option options[], int n, const char *s) } #ifndef SCM_RECKLESS scm_must_free ((char *) flags); - scm_wta (SCM_CAR (new_mode), "Unknown mode flag", s); + scm_misc_error (s, "Unknown mode flag: ~S", + SCM_LIST1 (SCM_CAR (new_mode))); #endif cont: new_mode = SCM_CDR (new_mode); diff --git a/libguile/ports.c b/libguile/ports.c index fd7362031..f0111671e 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -468,12 +468,13 @@ scm_add_to_port_table (SCM port) void scm_remove_from_port_table (SCM port) +#define FUNC_NAME "scm_remove_from_port_table" { scm_port *p = SCM_PTAB_ENTRY (port); int i = p->entry; if (i >= scm_port_table_size) - scm_wta (port, "Port not in table", "scm_remove_from_port_table"); + SCM_MISC_ERROR ("Port not in table: ~S", SCM_LIST1 (port)); if (p->putback_buf) free (p->putback_buf); free (p); @@ -487,6 +488,8 @@ scm_remove_from_port_table (SCM port) SCM_SETPTAB_ENTRY (port, 0); scm_port_table_size--; } +#undef FUNC_NAME + #ifdef GUILE_DEBUG /* Functions for debugging. */ diff --git a/libguile/ramap.c b/libguile/ramap.c index 1db100b0d..7ef09128d 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -329,7 +329,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) { default: case 0: - scm_wta (ra0, "array shape mismatch", what); + scm_misc_error (what, "array shape mismatch: ~S", ra0); case 2: case 3: case 4: /* Try unrolling arrays */ diff --git a/libguile/read.c b/libguile/read.c index 616134724..473562a35 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -255,6 +255,7 @@ recsexpr (SCM obj,int line,int column,SCM filename) static void skip_scsh_block_comment (SCM port) +#define FUNC_NAME "skip_scsh_block_comment" { /* Is this portable? Dear God, spare me from the non-eight-bit characters. But is it tasteful? */ @@ -265,8 +266,7 @@ skip_scsh_block_comment (SCM port) int c = scm_getc (port); if (c == EOF) - scm_wta (SCM_UNDEFINED, - "unterminated `#! ... !#' comment", "read"); + SCM_MISC_ERROR ("unterminated `#! ... !#' comment", SCM_EOL); history = ((history << 8) | (c & 0xff)) & 0xffffffff; /* Were the last four characters read "\n!#\n"? */ @@ -274,6 +274,8 @@ skip_scsh_block_comment (SCM port) return; } } +#undef FUNC_NAME + static SCM scm_get_hash_procedure(int c); @@ -281,6 +283,7 @@ static char s_list[]="list"; SCM scm_lreadr (SCM *tok_buf,SCM port,SCM *copy) +#define FUNC_NAME "scm_lreadr" { int c; scm_sizet j; @@ -299,7 +302,7 @@ tryagain_no_flush_ws: ? scm_lreadrecparen (tok_buf, port, s_list, copy) : scm_lreadparen (tok_buf, port, s_list, copy); case ')': - scm_wta (SCM_UNDEFINED, "unexpected \")\"", "read"); + SCM_MISC_ERROR ("unexpected \")\"", SCM_EOL); goto tryagain; case '\'': @@ -402,7 +405,7 @@ tryagain_no_flush_ws: if (scm_charnames[c] && (scm_casei_streq (scm_charnames[c], SCM_STRING_CHARS (*tok_buf)))) return SCM_MAKE_CHAR (scm_charnums[c]); - scm_wta (SCM_UNDEFINED, "unknown # object: #\\", SCM_STRING_CHARS (*tok_buf)); + SCM_MISC_ERROR ("unknown # object", SCM_EOL); /* #:SYMBOL is a syntax for keywords supported in all contexts. */ case ':': @@ -504,7 +507,7 @@ tryagain_no_flush_ws: c = SCM_STRING_CHARS (*tok_buf)[1]; goto callshrp; } - scm_wta (SCM_UNDEFINED, "unknown # object", SCM_STRING_CHARS (*tok_buf)); + SCM_MISC_ERROR ("unknown # object", SCM_EOL); } goto tok; @@ -524,6 +527,8 @@ tryagain_no_flush_ws: return scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j); } } +#undef FUNC_NAME + #ifdef _UNICOS _Pragma ("noopt"); /* # pragma _CRI noopt */ @@ -617,6 +622,7 @@ _Pragma ("opt"); /* # pragma _CRI opt */ SCM scm_lreadparen (SCM *tok_buf, SCM port, char *name, SCM *copy) +#define FUNC_NAME "scm_lreadparen" { SCM tmp; SCM tl; @@ -632,7 +638,7 @@ scm_lreadparen (SCM *tok_buf, SCM port, char *name, SCM *copy) ans = scm_lreadr (tok_buf, port, copy); closeit: if (')' != (c = scm_flush_ws (port, name))) - scm_wta (SCM_UNDEFINED, "missing close paren", ""); + SCM_MISC_ERROR ("missing close paren", SCM_EOL); return ans; } ans = tl = scm_cons (tmp, SCM_EOL); @@ -649,10 +655,12 @@ scm_lreadparen (SCM *tok_buf, SCM port, char *name, SCM *copy) } return ans; } +#undef FUNC_NAME SCM scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy) +#define FUNC_NAME "scm_lreadrecparen" { register int c; register SCM tmp; @@ -670,7 +678,7 @@ scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy) { ans = scm_lreadr (tok_buf, port, copy); if (')' != (c = scm_flush_ws (port, name))) - scm_wta (SCM_UNDEFINED, "missing close paren", ""); + SCM_MISC_ERROR ("missing close paren", SCM_EOL); return ans; } /* Build the head of the list structure. */ @@ -694,7 +702,7 @@ scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy) : tmp, SCM_EOL)); if (')' != (c = scm_flush_ws (port, name))) - scm_wta (SCM_UNDEFINED, "missing close paren", ""); + SCM_MISC_ERROR ("missing close paren", SCM_EOL); goto exit; } @@ -721,6 +729,7 @@ exit: SCM_EOL)); return ans; } +#undef FUNC_NAME diff --git a/libguile/script.c b/libguile/script.c index 7bbc51aec..5e56c03b3 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -51,6 +51,7 @@ #include "libguile/load.h" #include "libguile/version.h" +#include "libguile/validate.h" #include "libguile/script.h" #ifdef HAVE_STRING_H @@ -168,6 +169,7 @@ scm_find_executable (const char *name) /* Read a \nnn-style escape. We've just read the backslash. */ static int script_get_octal (FILE *f) +#define FUNC_NAME "script_get_octal" { int i; int value = 0; @@ -178,16 +180,17 @@ script_get_octal (FILE *f) if ('0' <= c && c <= '7') value = (value * 8) + (c - '0'); else - scm_wta (SCM_UNDEFINED, - "malformed script: bad octal backslash escape", - "script argument parser"); + SCM_MISC_ERROR ("malformed script: bad octal backslash escape", + SCM_EOL); } return value; } +#undef FUNC_NAME static int script_get_backslash (FILE *f) +#define FUNC_NAME "script_get_backslash" { int c = getc (f); @@ -211,24 +214,22 @@ script_get_backslash (FILE *f) case '4': case '5': case '6': case '7': ungetc (c, f); return script_get_octal (f); - + case EOF: - scm_wta (SCM_UNDEFINED, - "malformed script: backslash followed by EOF", - "script argument parser"); + SCM_MISC_ERROR ("malformed script: backslash followed by EOF", SCM_EOL); return 0; /* not reached? */ default: - scm_wta (SCM_UNDEFINED, - "malformed script: bad backslash sequence", - "script argument parser"); + SCM_MISC_ERROR ("malformed script: bad backslash sequence", SCM_EOL); return 0; /* not reached? */ } } +#undef FUNC_NAME static char * script_read_arg (FILE *f) +#define FUNC_NAME "script_read_arg" { int size = 7; char *buf = malloc (size + 1); @@ -275,13 +276,12 @@ script_read_arg (FILE *f) case '\t': free (buf); - scm_wta (SCM_UNDEFINED, - "malformed script: TAB in meta-arguments", - "argument parser"); + SCM_MISC_ERROR ("malformed script: TAB in meta-arguments", SCM_EOL); return 0; /* not reached? */ } } } +#undef FUNC_NAME static int diff --git a/libguile/unif.c b/libguile/unif.c index b9987c36d..59b3fc659 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1156,11 +1156,12 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, SCM scm_cvref (SCM v, scm_sizet pos, SCM last) +#define FUNC_NAME "scm_cvref" { switch SCM_TYP7 (v) { default: - scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref"); + SCM_WRONG_TYPE_ARG (SCM_ARG1, v); case scm_tc7_bvect: if (SCM_BITVEC_REF(v,pos)) return SCM_BOOL_T; @@ -1222,6 +1223,8 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) } } } +#undef FUNC_NAME + SCM_REGISTER_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x);