From af45e3b06accc40d2c92918d5901afb793e8b247 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 18 May 2000 08:47:52 +0000 Subject: [PATCH] * Unified some rest argument checking and handling. --- libguile/ChangeLog | 47 +++++++++++++++++++++++++++++ libguile/__scm.h | 12 ++++---- libguile/async.c | 1 + libguile/dynl.c | 44 ++++----------------------- libguile/dynl.h | 2 +- libguile/eval.c | 7 ++++- libguile/filesys.c | 14 ++++----- libguile/hooks.c | 2 -- libguile/list.c | 68 +++++++++++++++++++++++------------------- libguile/ports.c | 2 +- libguile/posix.c | 6 ++-- libguile/print.c | 2 +- libguile/ramap.c | 2 ++ libguile/regex-posix.c | 3 +- libguile/stacks.c | 22 +++++++------- libguile/stacks.h | 2 +- libguile/strings.c | 6 ++-- libguile/struct.c | 2 ++ libguile/throw.c | 4 +-- libguile/unif.c | 39 ++++++++++-------------- libguile/unif.h | 6 ++-- libguile/validate.h | 11 ++++++- 22 files changed, 164 insertions(+), 140 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 1efa6da8d..5a19d3635 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,50 @@ +2000-05-17 Dirk Herrmann + + * __scm.h (SCM_DEBUG_REST_ARGUMENT): Renamed from + SCM_DEBUG_REST_ARGUMENTS in order to clarify that we don't test + the actual arguments in the list, but rather the rest argument as + a list of arguments. + + * validate.h (SCM_VALIDATE_REST_ARGUMENT): Added. + + * async.c (scm_noop), eval.c (scm_map, scm_for_each), list.c + (scm_list_star, scm_append, scm_append_x), ports.c + (scm_close_all_ports_except), ramap.c (scm_array_map_x, + scm_array_for_each), regex-posix.c (scm_make_regexp), stacks.c + (scm_make_stack), strings.c (scm_string_append), struct.c + (scm_make_struct, scm_make_vtable_vtable): Validate rest arguments. + + * dynl.c (DYNL_GLOBAL, sysdep_dynl_link, kw_global, sym_global, + scm_dynamic_link, scm_init_dynamic_linking), dynl.h + (scm_dynamic_link): Removed possibility to pass flags to + scm_dynamic_link, as it had no effect anyway. + + * filesys.c (scm_fcntl): Made single optional rest argument into + a standard optional argument. + + * hooks.c (scm_run_hook): A list of rest arguments is never + SCM_UNBNDP. + + * list.c (scm_append, scm_append_x), stacks.c (scm_make_stack), + strings.c (scm_string_append): Don't perform half-hearted checks + to see whether the rest argument forms a proper list any more, use + SCM_VALIDATE_REST_ARGUMENTS instead. + + * ports.c (scm_close_all_ports_except): Accept empty list of rest + arguments. + + * posix.c (scm_convert_exec_args), print.c (scm_simple_format): + Simplify verification of rest argument. + + * stacks.c (scm_make_stack), stacks.h (scm_make_stack), throw.c + (ss_handler, handler_message): Make first mandatory rest argument + of scm_make_stack into a standard mandatory argument. + + * unif.c (scm_transpose_array, scm_enclose_array, + scm_array_in_bounds_p), unif.h (scm_transpose_array, + scm_enclose_array, scm_array_in_bounds_p): Make first mandatory + rest argument into a standard mandatory argument. + 2000-05-17 Dirk Herrmann * __scm.h: Added SCM_DEBUG as default debug option. (Thanks to diff --git a/libguile/__scm.h b/libguile/__scm.h index 6572fd979..fc0f5ab89 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -167,13 +167,13 @@ #define SCM_DEBUG_DEPRECATED SCM_DEBUG #endif -/* If SCM_DEBUG_REST_ARGUMENTS is set to 1, functions that take rest arguments - * will check whether the rest arguments actually form a proper list. - * Otherwise it is assumed that the rest arguments form a proper list and only - * the parameters themselves, which are given as rest arguments, are checked. +/* If SCM_DEBUG_REST_ARGUMENT is set to 1, functions that take rest arguments + * will check whether the rest arguments are actually passed as a proper list. + * Otherwise, if SCM_DEBUG_REST_ARGUMENT is 0, functions that take rest + * arguments will take it for granted that these are passed as a proper list. */ -#ifndef SCM_DEBUG_REST_ARGUMENTS -#define SCM_DEBUG_REST_ARGUMENTS SCM_DEBUG +#ifndef SCM_DEBUG_REST_ARGUMENT +#define SCM_DEBUG_REST_ARGUMENT SCM_DEBUG #endif /* Use this for _compile time_ type checking only, since the compiled result diff --git a/libguile/async.c b/libguile/async.c index d8b3a71ec..6b264fb17 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -400,6 +400,7 @@ SCM_DEFINE (scm_noop, "noop", 0, 0, 1, "") #define FUNC_NAME s_scm_noop { + SCM_VALIDATE_REST_ARGUMENT (args); return (SCM_NULLP (args) ? SCM_BOOL_F : SCM_CAR (args)); } #undef FUNC_NAME diff --git a/libguile/dynl.c b/libguile/dynl.c index 0ba0b13b8..3e839c32b 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -232,14 +232,12 @@ SCM_DEFINE (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0, * is executed, SCM_DEFER_INTS and SCM_ALLOW_INTS do not nest). */ -#define DYNL_GLOBAL 0x0001 - #ifdef DYNAMIC_LINKING #include static void * -sysdep_dynl_link (const char *fname, int flags, const char *subr) +sysdep_dynl_link (const char *fname, const char *subr) { lt_dlhandle handle; handle = lt_dlopenext (fname); @@ -298,9 +296,7 @@ no_dynl_error (const char *subr) } static void * -sysdep_dynl_link (const char *filename, - int flags, - const char *subr) +sysdep_dynl_link (const char *filename, const char *subr) { no_dynl_error (subr); return NULL; @@ -348,47 +344,18 @@ print_dynl_obj (SCM exp,SCM port,scm_print_state *pstate) return 1; } -static SCM kw_global; -SCM_SYMBOL (sym_global, "-global"); -SCM_DEFINE (scm_dynamic_link, "dynamic-link", 1, 0, 1, - (SCM fname, SCM rest), +SCM_DEFINE (scm_dynamic_link, "dynamic-link", 1, 0, 0, + (SCM fname), "Open the dynamic library @var{library-file}. A library handle\n" "representing the opened library is returned; this handle should be used\n" "as the @var{lib} argument to the following functions.") #define FUNC_NAME s_scm_dynamic_link { void *handle; - int flags = DYNL_GLOBAL; SCM_COERCE_ROSTRING (1, fname); - - /* collect flags */ - while (SCM_CONSP (rest)) - { - SCM kw, val; - - kw = SCM_CAR (rest); - rest = SCM_CDR (rest); - - if (!SCM_CONSP (rest)) - SCM_MISC_ERROR ("keyword without value", SCM_EOL); - - val = SCM_CAR (rest); - rest = SCM_CDR (rest); - - if (SCM_EQ_P (kw, kw_global)) - { - if (SCM_FALSEP (val)) - flags &= ~DYNL_GLOBAL; - } - else - SCM_MISC_ERROR ("unknown keyword argument: ~A", - scm_cons (kw, SCM_EOL)); - } - - handle = sysdep_dynl_link (SCM_CHARS (fname), flags, FUNC_NAME); - + handle = sysdep_dynl_link (SCM_CHARS (fname), FUNC_NAME); SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj, SCM_UNPACK (fname), handle); } #undef FUNC_NAME @@ -549,7 +516,6 @@ scm_init_dynamic_linking () scm_set_smob_print (scm_tc16_dynamic_obj, print_dynl_obj); sysdep_dynl_init (); #include "libguile/dynl.x" - kw_global = scm_make_keyword_from_dash_symbol (sym_global); } /* diff --git a/libguile/dynl.h b/libguile/dynl.h index 69b2ae8ae..4fbf4e9cd 100644 --- a/libguile/dynl.h +++ b/libguile/dynl.h @@ -51,7 +51,7 @@ void scm_register_module_xxx (char *module_name, void *init_func); SCM scm_registered_modules (void); SCM scm_clear_registered_modules (void); -SCM scm_dynamic_link (SCM fname, SCM rest); +SCM scm_dynamic_link (SCM fname); SCM scm_dynamic_unlink (SCM dobj); SCM scm_dynamic_object_p (SCM obj); SCM scm_dynamic_func (SCM symb, SCM dobj); diff --git a/libguile/eval.c b/libguile/eval.c index 0fa22172c..ebbf5f8d0 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3575,6 +3575,7 @@ SCM_GPROC (s_map, "map", 2, 0, 1, scm_map, g_map); SCM scm_map (SCM proc, SCM arg1, SCM args) +#define FUNC_NAME s_map { long i, len; SCM res = SCM_EOL; @@ -3584,6 +3585,7 @@ scm_map (SCM proc, SCM arg1, SCM args) len = scm_ilength (arg1); SCM_GASSERTn (len >= 0, g_map, scm_cons2 (proc, arg1, args), SCM_ARG2, s_map); + SCM_VALIDATE_REST_ARGUMENT (args); if (SCM_NULLP (args)) { while (SCM_NIMP (arg1)) @@ -3614,18 +3616,21 @@ scm_map (SCM proc, SCM arg1, SCM args) pres = SCM_CDRLOC (*pres); } } +#undef FUNC_NAME SCM_GPROC (s_for_each, "for-each", 2, 0, 1, scm_for_each, g_for_each); SCM scm_for_each (SCM proc, SCM arg1, SCM args) +#define FUNC_NAME s_for_each { SCM *ve = &args; /* Keep args from being optimized away. */ long i, len; len = scm_ilength (arg1); SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args), SCM_ARG2, s_for_each); + SCM_VALIDATE_REST_ARGUMENT (args); if SCM_NULLP (args) { while SCM_NIMP (arg1) @@ -3653,7 +3658,7 @@ scm_for_each (SCM proc, SCM arg1, SCM args) scm_apply (proc, arg1, SCM_EOL); } } - +#undef FUNC_NAME SCM diff --git a/libguile/filesys.c b/libguile/filesys.c index bb20f5b78..8073225cb 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1112,7 +1112,7 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, -SCM_DEFINE (scm_fcntl, "fcntl", 2, 0, 1, +SCM_DEFINE (scm_fcntl, "fcntl", 2, 1, 0, (SCM object, SCM cmd, SCM value), "Apply @var{command} to the specified file descriptor or the underlying\n" "file descriptor of the specified port. @var{value} is an optional\n" @@ -1153,13 +1153,13 @@ SCM_DEFINE (scm_fcntl, "fcntl", 2, 0, 1, SCM_VALIDATE_INUM (1,object); fdes = SCM_INUM (object); } - if (SCM_NULLP (value)) + + if (SCM_UNBNDP (value)) { ivalue = 0; - else - { - SCM_ASSERT (SCM_INUMP (SCM_CAR (value)), value, SCM_ARG3, FUNC_NAME); - ivalue = SCM_INUM (SCM_CAR (value)); - } + } else { + SCM_VALIDATE_INUM_COPY (SCM_ARG3, value, ivalue); + } + SCM_SYSCALL (rv = fcntl (fdes, SCM_INUM (cmd), ivalue)); if (rv == -1) SCM_SYSERROR; diff --git a/libguile/hooks.c b/libguile/hooks.c index 413648cb8..7ec54766e 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -310,8 +310,6 @@ SCM_DEFINE (scm_run_hook, "run-hook", 1, 0, 1, #define FUNC_NAME s_scm_run_hook { SCM_VALIDATE_HOOK (1,hook); - if (SCM_UNBNDP (args)) - args = SCM_EOL; if (scm_ilength (args) != SCM_HOOK_ARITY (hook)) SCM_MISC_ERROR ("Hook ~S requires ~A arguments", SCM_LIST2 (hook,SCM_MAKINUM (SCM_HOOK_ARITY (hook)))); diff --git a/libguile/list.c b/libguile/list.c index 35e6bdc1f..d31d90c01 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -94,7 +94,8 @@ SCM_DEFINE (scm_list_star, "list*", 1, 0, 1, "Return an improper list of the arguments.") #define FUNC_NAME s_scm_list_star { - if (SCM_NNULLP (rest)) + SCM_VALIDATE_REST_ARGUMENT (rest); + if (!SCM_NULLP (rest)) { SCM prev = arg = scm_cons (arg, rest); while (SCM_NNULLP (SCM_CDR (rest))) @@ -196,28 +197,27 @@ SCM_DEFINE (scm_append, "append", 0, 0, 1, " (append '() 'a) => a\n") #define FUNC_NAME s_scm_append { - SCM res = SCM_EOL; - SCM *lloc = &res, arg; - if (SCM_IMP(args)) { - SCM_VALIDATE_NULL (SCM_ARGn, args); + SCM_VALIDATE_REST_ARGUMENT (args); + if (SCM_NULLP (args)) { + return SCM_EOL; + } else { + SCM res = SCM_EOL; + SCM *lloc = &res; + SCM arg = SCM_CAR (args); + args = SCM_CDR (args); + while (!SCM_NULLP (args)) { + while (SCM_CONSP (arg)) { + *lloc = scm_cons (SCM_CAR (arg), SCM_EOL); + lloc = SCM_CDRLOC (*lloc); + arg = SCM_CDR (arg); + } + SCM_VALIDATE_NULL (SCM_ARGn, arg); + arg = SCM_CAR (args); + args = SCM_CDR (args); + }; + *lloc = arg; return res; } - SCM_VALIDATE_CONS (SCM_ARGn, args); - while (1) { - arg = SCM_CAR(args); - args = SCM_CDR(args); - if (SCM_IMP(args)) { - *lloc = arg; - SCM_VALIDATE_NULL (SCM_ARGn, args); - return res; - } - SCM_VALIDATE_CONS (SCM_ARGn, args); - for (; SCM_CONSP(arg); arg = SCM_CDR(arg)) { - *lloc = scm_cons(SCM_CAR(arg), SCM_EOL); - lloc = SCM_CDRLOC(*lloc); - } - SCM_VALIDATE_NULL (SCM_ARGn, arg); - } } #undef FUNC_NAME @@ -230,16 +230,22 @@ SCM_DEFINE (scm_append_x, "append!", 0, 0, 1, "performed. Return a pointer to the mutated list.") #define FUNC_NAME s_scm_append_x { - SCM arg; - tail: - if (SCM_NULLP(args)) return SCM_EOL; - arg = SCM_CAR(args); - args = SCM_CDR(args); - if (SCM_NULLP(args)) return arg; - if (SCM_NULLP(arg)) goto tail; - SCM_VALIDATE_CONS (SCM_ARG1,arg); - SCM_SETCDR (scm_last_pair (arg), scm_append_x (args)); - return arg; + SCM_VALIDATE_REST_ARGUMENT (args); + while (1) { + if (SCM_NULLP (args)) { + return SCM_EOL; + } else { + SCM arg = SCM_CAR (args); + args = SCM_CDR (args); + if (SCM_NULLP (args)) { + return arg; + } else if (!SCM_NULLP (arg)) { + SCM_VALIDATE_CONS (SCM_ARG1, arg); + SCM_SETCDR (scm_last_pair (arg), scm_append_x (args)); + return arg; + } + } + } } #undef FUNC_NAME diff --git a/libguile/ports.c b/libguile/ports.c index 7c3f04508..89a3bd3a3 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -675,7 +675,7 @@ SCM_DEFINE (scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1, #define FUNC_NAME s_scm_close_all_ports_except { int i = 0; - SCM_VALIDATE_CONS (1,ports); + SCM_VALIDATE_REST_ARGUMENT (ports); while (i < scm_port_table_size) { SCM thisport = scm_port_table[i]->port; diff --git a/libguile/posix.c b/libguile/posix.c index c7451bd3d..fd98dc882 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -811,13 +811,11 @@ scm_convert_exec_args (SCM args, int pos, const char *subr) int num_args; int i; - SCM_ASSERT (SCM_NULLP (args) - || (SCM_CONSP (args)), - args, pos, subr); num_args = scm_ilength (args); + SCM_ASSERT (num_args >= 0, args, pos, subr); execargv = (char **) scm_must_malloc ((num_args + 1) * sizeof (char *), subr); - for (i = 0; SCM_NNULLP (args); args = SCM_CDR (args), ++i) + for (i = 0; !SCM_NULLP (args); args = SCM_CDR (args), ++i) { scm_sizet len; char *dst; diff --git a/libguile/print.c b/libguile/print.c index 77782aaf3..a243b4ec0 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -969,7 +969,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, SCM_VALIDATE_OPORT_VALUE (1,destination); } SCM_VALIDATE_STRING(2,message); - SCM_VALIDATE_LIST(3,args); + SCM_VALIDATE_REST_ARGUMENT (args); start = SCM_ROCHARS (message); for (p = start; *p != '\0'; ++p) diff --git a/libguile/ramap.c b/libguile/ramap.c index 500611b40..cffdd18fa 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -1520,6 +1520,7 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, #define FUNC_NAME s_scm_array_map_x { SCM_VALIDATE_PROC (2,proc); + SCM_VALIDATE_REST_ARGUMENT (lra); switch (SCM_TYP7 (proc)) { default: @@ -1666,6 +1667,7 @@ SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1, #define FUNC_NAME s_scm_array_for_each { SCM_VALIDATE_PROC (1,proc); + SCM_VALIDATE_REST_ARGUMENT (lra); scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME); return SCM_UNSPECIFIED; } diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index 9e4ce3ae8..5ca9e3b10 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -185,13 +185,14 @@ SCM_DEFINE (scm_make_regexp, "make-regexp", 1, 0, 1, int status, cflags; SCM_VALIDATE_ROSTRING (1,pat); + SCM_VALIDATE_REST_ARGUMENT (flags); SCM_COERCE_SUBSTR (pat); /* Examine list of regexp flags. If REG_BASIC is supplied, then turn off REG_EXTENDED flag (on by default). */ cflags = REG_EXTENDED; flag = flags; - while (SCM_NNULLP (flag)) + while (!SCM_NULLP (flag)) { if (SCM_INUM (SCM_CAR (flag)) == REG_BASIC) cflags &= ~REG_EXTENDED; diff --git a/libguile/stacks.c b/libguile/stacks.c index 2114fdaff..17116fc01 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -412,8 +412,8 @@ SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_make_stack, "make-stack", 0, 0, 1, - (SCM args), +SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, + (SCM obj, SCM args), "") #define FUNC_NAME s_scm_make_stack { @@ -422,12 +422,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 0, 0, 1, scm_info_frame *iframe; long offset = 0; SCM stack, id; - SCM obj, inner_cut, outer_cut; - - SCM_ASSERT (SCM_CONSP (args), - SCM_FUNC_NAME, SCM_WNA, NULL); - obj = SCM_CAR (args); - args = SCM_CDR (args); + SCM inner_cut, outer_cut; /* Extract a pointer to the innermost frame of whatever object scm_make_stack was given. */ @@ -473,17 +468,20 @@ SCM_DEFINE (scm_make_stack, "make-stack", 0, 0, 1, SCM_STACK (stack) -> length = n; /* Narrow the stack according to the arguments given to scm_make_stack. */ - while (n > 0 && SCM_CONSP (args)) + SCM_VALIDATE_REST_ARGUMENT (args); + while (n > 0 && !SCM_NULLP (args)) { inner_cut = SCM_CAR (args); args = SCM_CDR (args); - if (SCM_CONSP (args)) + if (SCM_NULLP (args)) + { + outer_cut = SCM_INUM0; + } + else { outer_cut = SCM_CAR (args); args = SCM_CDR (args); } - else - outer_cut = SCM_INUM0; narrow_stack (stack, SCM_INUMP (inner_cut) ? SCM_INUM (inner_cut) : n, diff --git a/libguile/stacks.h b/libguile/stacks.h index 2a5ea828d..cbe27bbe4 100644 --- a/libguile/stacks.h +++ b/libguile/stacks.h @@ -116,7 +116,7 @@ extern SCM scm_stack_type; SCM scm_stack_p (SCM obj); -SCM scm_make_stack (SCM args); +SCM scm_make_stack (SCM obj, SCM args); SCM scm_stack_id (SCM stack); SCM scm_stack_ref (SCM stack, SCM i); SCM scm_stack_length (SCM stack); diff --git a/libguile/strings.c b/libguile/strings.c index 733667d19..70ec6f23f 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -308,13 +308,13 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, register long i = 0; register SCM l, s; register unsigned char *data; - for (l = args;SCM_CONSP (l);) { + + SCM_VALIDATE_REST_ARGUMENT (args); + for (l = args; !SCM_NULLP (l); l = SCM_CDR (l)) { s = SCM_CAR (l); SCM_VALIDATE_ROSTRING (SCM_ARGn,s); i += SCM_ROLENGTH (s); - l = SCM_CDR (l); } - SCM_ASSERT (SCM_NULLP (l), args, SCM_ARGn, FUNC_NAME); res = scm_makstr (i, 0); data = SCM_UCHARS (res); for (l = args;SCM_NIMP (l);l = SCM_CDR (l)) { diff --git a/libguile/struct.c b/libguile/struct.c index f89f2e7a9..520056c46 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -379,6 +379,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, SCM_VALIDATE_VTABLE (1,vtable); SCM_VALIDATE_INUM (2,tail_array_size); + SCM_VALIDATE_REST_ARGUMENT (init); layout = SCM_PACK (SCM_STRUCT_DATA (vtable) [scm_vtable_index_layout]); basic_size = SCM_LENGTH (layout) / 2; @@ -474,6 +475,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, SCM_VALIDATE_ROSTRING (1,extra_fields); SCM_VALIDATE_INUM (2,tail_array_size); + SCM_VALIDATE_REST_ARGUMENT (init); fields = scm_string_append (scm_listify (required_vtable_fields, extra_fields, diff --git a/libguile/throw.c b/libguile/throw.c index 80ee191a1..c63007547 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -313,7 +313,7 @@ ss_handler (void *data, SCM tag, SCM throw_args) { /* Save the stack */ scm_fluid_set_x (SCM_CDR (scm_the_last_stack_fluid), - scm_make_stack (scm_cons (SCM_BOOL_T, SCM_EOL))); + scm_make_stack (SCM_BOOL_T, SCM_EOL)); /* Throw the error */ return scm_throw (tag, throw_args); } @@ -438,7 +438,7 @@ handler_message (void *handler_data, SCM tag, SCM args) if (scm_ilength (args) >= 3) { - SCM stack = scm_make_stack (SCM_LIST1 (SCM_BOOL_T)); + SCM stack = scm_make_stack (SCM_BOOL_T, SCM_EOL); SCM subr = SCM_CAR (args); SCM message = SCM_CADR (args); SCM parts = SCM_CADDR (args); diff --git a/libguile/unif.c b/libguile/unif.c index 688e26e8d..369ece452 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -785,8 +785,8 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, /* args are RA . DIMS */ -SCM_DEFINE (scm_transpose_array, "transpose-array", 0, 0, 1, - (SCM args), +SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, + (SCM ra, SCM args), "Returns an array sharing contents with @var{array}, but with dimensions\n" "arranged in a different order. There must be one @var{dim} argument for\n" "each dimension of @var{array}. @var{dim0}, @var{dim1}, @dots{} should\n" @@ -806,14 +806,11 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 0, 0, 1, "@end example") #define FUNC_NAME s_scm_transpose_array { - SCM ra, res, vargs, *ve = &vargs; + SCM res, vargs, *ve = &vargs; scm_array_dim *s, *r; int ndim, i, k; - SCM_ASSERT (SCM_NNULLP (args), scm_makfrom0str (FUNC_NAME), - SCM_WNA, NULL); - ra = SCM_CAR (args); + SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME); - args = SCM_CDR (args); switch (SCM_TYP7 (ra)) { default: @@ -830,7 +827,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 0, 0, 1, #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: #endif - SCM_ASSERT (SCM_NIMP (args) && SCM_NULLP (SCM_CDR (args)), + SCM_ASSERT (!SCM_NULLP (args) && SCM_NULLP (SCM_CDR (args)), scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), SCM_CAR (args), SCM_ARG2, FUNC_NAME); @@ -895,8 +892,8 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 0, 0, 1, #undef FUNC_NAME /* args are RA . AXES */ -SCM_DEFINE (scm_enclose_array, "enclose-array", 0, 0, 1, - (SCM axes), +SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, + (SCM ra, SCM axes), "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n" "the rank of @var{array}. @var{enclose-array} returns an array\n" "resembling an array of shared arrays. The dimensions of each shared\n" @@ -917,16 +914,14 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 0, 0, 1, "@end example") #define FUNC_NAME s_scm_enclose_array { - SCM axv, ra, res, ra_inr; + SCM axv, res, ra_inr; scm_array_dim vdim, *s = &vdim; int ndim, j, k, ninr, noutr; - SCM_ASSERT (SCM_NIMP (axes), scm_makfrom0str (FUNC_NAME), SCM_WNA, - NULL); - ra = SCM_CAR (axes); - axes = SCM_CDR (axes); + if (SCM_NULLP (axes)) axes = scm_cons ((SCM_ARRAYP (ra) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL); ninr = scm_ilength (axes); + SCM_ASSERT (0 <= ninr, scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); ra_inr = scm_make_ra (ninr); SCM_ASRTGO (SCM_NIMP (ra), badarg1); switch SCM_TYP7 @@ -965,8 +960,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 0, 0, 1, } noutr = ndim - ninr; axv = scm_make_string (SCM_MAKINUM (ndim), SCM_MAKE_CHAR (0)); - SCM_ASSERT (0 <= noutr && 0 <= ninr, scm_makfrom0str (FUNC_NAME), - SCM_WNA, NULL); + SCM_ASSERT (0 <= noutr, scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); res = scm_make_ra (noutr); SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr); SCM_ARRAY_V (res) = ra_inr; @@ -995,20 +989,17 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 0, 0, 1, -SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 0, 0, 1, - (SCM args), +SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, + (SCM v, SCM args), "Returns @code{#t} if its arguments would be acceptable to array-ref.") #define FUNC_NAME s_scm_array_in_bounds_p { - SCM v, ind = SCM_EOL; + SCM ind = SCM_EOL; long pos = 0; register scm_sizet k; register long j; scm_array_dim *s; - SCM_ASSERT (SCM_NIMP (args), scm_makfrom0str (FUNC_NAME), - SCM_WNA, NULL); - v = SCM_CAR (args); - args = SCM_CDR (args); + SCM_ASRTGO (SCM_NIMP (v), badarg1); if (SCM_NIMP (args)) diff --git a/libguile/unif.h b/libguile/unif.h index f840c3d82..a26adc6a3 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -110,9 +110,9 @@ extern SCM scm_shap2ra (SCM args, const char *what); extern SCM scm_dimensions_to_uniform_array (SCM dims, SCM prot, SCM fill); extern void scm_ra_set_contp (SCM ra); extern SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims); -extern SCM scm_transpose_array (SCM args); -extern SCM scm_enclose_array (SCM axes); -extern SCM scm_array_in_bounds_p (SCM args); +extern SCM scm_transpose_array (SCM ra, SCM args); +extern SCM scm_enclose_array (SCM ra, SCM axes); +extern SCM scm_array_in_bounds_p (SCM v, SCM args); extern SCM scm_uniform_vector_ref (SCM v, SCM args); extern SCM scm_cvref (SCM v, scm_sizet pos, SCM last); extern SCM scm_array_set_x (SCM v, SCM obj, SCM args); diff --git a/libguile/validate.h b/libguile/validate.h index bcd7328f6..b9f81aa89 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -1,4 +1,4 @@ -/* $Id: validate.h,v 1.10 2000-05-15 11:47:48 dirk Exp $ */ +/* $Id: validate.h,v 1.11 2000-05-18 08:47:52 dirk Exp $ */ /* Copyright (C) 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify @@ -100,6 +100,15 @@ +#define SCM_VALIDATE_REST_ARGUMENT(x) \ + do { \ + if (SCM_DEBUG_REST_ARGUMENT) { \ + if (scm_ilength (x) < 0) { \ + SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL); \ + } \ + } \ + } while (0) + #define SCM_VALIDATE_NIM(pos, scm) SCM_MAKE_VALIDATE (pos, scm, NIMP) #define SCM_VALIDATE_BOOL(pos, flag) SCM_MAKE_VALIDATE(pos, flag, BOOLP) -- 2.20.1