From 1bbd0b849f6b90f1ffe57e586e4ee5a884f84a11 Mon Sep 17 00:00:00 2001 From: "Greg J. Badros" Date: Sun, 12 Dec 1999 02:36:16 +0000 Subject: [PATCH] * *.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. --- libguile/ChangeLog | 41 +++ libguile/Makefile.am | 2 +- libguile/alist.c | 219 ++++++------- libguile/arbiters.c | 44 +-- libguile/async.c | 136 ++++---- libguile/backtrace.c | 112 +++---- libguile/boolean.c | 31 +- libguile/chars.c | 332 ++++++++++--------- libguile/continuations.c | 9 +- libguile/debug.c | 281 ++++++++--------- libguile/dynl-dl.c | 122 ------- libguile/dynl-dld.c | 132 -------- libguile/dynl-shl.c | 108 ------- libguile/dynl.c | 156 ++++----- libguile/dynwind.c | 27 +- libguile/eq.c | 42 +-- libguile/error.c | 93 ++---- libguile/eval.c | 170 +++++----- libguile/evalext.c | 24 +- libguile/feature.c | 131 ++++---- libguile/filesys.c | 495 ++++++++++++++--------------- libguile/fluids.c | 107 +++---- libguile/fports.c | 54 ++-- libguile/gc.c | 82 +++-- libguile/gdbint.c | 14 +- libguile/gsubr.c | 29 +- libguile/guardians.c | 16 +- libguile/hash.c | 61 ++-- libguile/hashtab.c | 324 +++++++------------ libguile/init.c | 53 ++-- libguile/ioext.c | 221 ++++++------- libguile/keywords.c | 54 ++-- libguile/lang.c | 60 ++-- libguile/list.c | 456 +++++++++++++------------- libguile/load.c | 115 +++---- libguile/macros.c | 105 +++--- libguile/mallocs.c | 21 +- libguile/net_db.c | 182 +++++------ libguile/numbers.c | 667 +++++++++++++++++---------------------- libguile/objects.c | 96 +++--- libguile/objprop.c | 48 +-- libguile/pairs.c | 62 ++-- libguile/pairs.h | 5 + libguile/ports.c | 446 +++++++++++++------------- libguile/posix.c | 588 +++++++++++++++++----------------- libguile/print.c | 142 ++++----- libguile/procprop.c | 68 ++-- libguile/procs.c | 127 ++++---- libguile/ramap.c | 302 +++++++----------- libguile/random.c | 141 ++++----- libguile/read.c | 66 ++-- libguile/regex-posix.c | 71 ++--- libguile/root.c | 49 ++- libguile/scm_validate.h | 267 ++++++++++++++++ libguile/scmsigs.c | 110 ++++--- libguile/simpos.c | 49 +-- libguile/smob.c | 6 + libguile/snarf.h | 34 +- libguile/socket.c | 422 +++++++++++-------------- libguile/sort.c | 208 ++++++------ libguile/srcprop.c | 98 +++--- libguile/stacks.c | 286 +++++++---------- libguile/stime.c | 169 +++++----- libguile/strings.c | 214 ++++++------- libguile/strop.c | 230 +++++++------- libguile/strports.c | 51 ++- libguile/struct.c | 220 ++++++------- libguile/symbols.c | 308 ++++++++---------- libguile/tag.c | 14 +- libguile/tags.h | 10 + libguile/threads.c | 24 +- libguile/throw.c | 64 ++-- libguile/unif.c | 526 ++++++++++++++---------------- libguile/variable.c | 116 +++---- libguile/vectors.c | 158 ++++------ libguile/version.c | 31 +- libguile/vports.c | 20 +- libguile/weaks.c | 121 ++++--- 78 files changed, 5262 insertions(+), 6033 deletions(-) rewrite libguile/dynl-dl.c (100%) rewrite libguile/dynl-dld.c (100%) rewrite libguile/dynl-shl.c (100%) create mode 100644 libguile/scm_validate.h diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 03db838b7..646996cc4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,44 @@ +Sat Dec 11 18:34:12 1999 Greg J. Badros + + * Makefile.am: Added scm_validate.h to modinclude_HEADERS. + + * *.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. + + * 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. + +1999-12-10 Greg Harvey (applied --12/10/99 gjb) + + * smob.c (scm_smob_prehistory): initialize allocated smob + + * tags.h: new tag: scm_tc16_allocated + + * gc.c (scm_gc_for_newcell): set the car of the new cell + to scm_tc16_allocated + * pairs.h (SCM_NEWCELL): set the car to scm_tc16_allocated + (scm_gc_mark): mark allocated cells. + 1999-12-09 Greg J. Badros * strports.h, strports.c (scm_eval_0str): Fix constness. Some diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 4d8dc2a65..0e95e1df0 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -93,7 +93,7 @@ modinclude_HEADERS = \ ioext.h keywords.h kw.h lang.h list.h load.h macros.h mallocs.h \ modules.h net_db.h numbers.h objects.h objprop.h options.h pairs.h \ ports.h posix.h regex-posix.h print.h procprop.h procs.h random.h \ - ramap.h read.h root.h scmsigs.h script.h simpos.h smob.h socket.h \ + ramap.h read.h root.h scmsigs.h scm_validate.h script.h simpos.h smob.h socket.h \ sort.h srcprop.h stackchk.h stacks.h stime.h strings.h strop.h \ strorder.h strports.h struct.h symbols.h tag.h tags.h throw.h \ unif.h variable.h vectors.h version.h vports.h weaks.h snarf.h \ diff --git a/libguile/alist.c b/libguile/alist.c index 4ba563c1d..ed560233d 100644 --- a/libguile/alist.c +++ b/libguile/alist.c @@ -38,23 +38,25 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include #include "_scm.h" #include "eq.h" #include "list.h" +#include "scm_validate.h" #include "alist.h" -SCM_PROC(s_acons, "acons", 3, 0, 0, scm_acons); - -SCM -scm_acons (w, x, y) - SCM w; - SCM x; - SCM y; +GUILE_PROC(scm_acons, "acons", 3, 0, 0, + (SCM w, SCM x, SCM y), +"") +#define FUNC_NAME s_scm_acons { register SCM z; SCM_NEWCELL (z); @@ -66,15 +68,14 @@ scm_acons (w, x, y) SCM_SETCDR (z, y); return z; } +#undef FUNC_NAME -SCM_PROC (s_sloppy_assq, "sloppy-assq", 2, 0, 0, scm_sloppy_assq); - -SCM -scm_sloppy_assq(x, alist) - SCM x; - SCM alist; +GUILE_PROC (scm_sloppy_assq, "sloppy-assq", 2, 0, 0, + (SCM x, SCM alist), +"") +#define FUNC_NAME s_scm_sloppy_assq { for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist)) @@ -85,15 +86,14 @@ scm_sloppy_assq(x, alist) } return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_sloppy_assv, "sloppy-assv", 2, 0, 0, scm_sloppy_assv); - -SCM -scm_sloppy_assv(x, alist) - SCM x; - SCM alist; +GUILE_PROC (scm_sloppy_assv, "sloppy-assv", 2, 0, 0, + (SCM x, SCM alist), +"") +#define FUNC_NAME s_scm_sloppy_assv { for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist)) { @@ -105,14 +105,13 @@ scm_sloppy_assv(x, alist) } return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_sloppy_assoc, "sloppy-assoc", 2, 0, 0, scm_sloppy_assoc); - -SCM -scm_sloppy_assoc(x, alist) - SCM x; - SCM alist; +GUILE_PROC (scm_sloppy_assoc, "sloppy-assoc", 2, 0, 0, + (SCM x, SCM alist), +"") +#define FUNC_NAME s_scm_sloppy_assoc { for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist)) { @@ -124,35 +123,31 @@ scm_sloppy_assoc(x, alist) } return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC(s_assq, "assq", 2, 0, 0, scm_assq); - -SCM -scm_assq(x, alist) - SCM x; - SCM alist; +GUILE_PROC(scm_assq, "assq", 2, 0, 0, + (SCM x, SCM alist), +"") +#define FUNC_NAME s_scm_assq { - SCM tmp; - for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) { - SCM_ASSERT(SCM_CONSP(alist), alist, SCM_ARG2, s_assq); - tmp = SCM_CAR(alist); - SCM_ASSERT(SCM_NIMP(tmp) && SCM_CONSP(tmp), alist, SCM_ARG2, s_assq); - if (SCM_CAR(tmp)==x) return tmp; - } - SCM_ASSERT(SCM_NULLP(alist), alist, SCM_ARG2, s_assq); - return SCM_BOOL_F; + SCM tmp; + for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) { + SCM_VALIDATE_ALISTCELL_COPYSCM(2,alist,tmp); + if (SCM_CAR(tmp)==x) return tmp; + } + SCM_VALIDATE_NULL(2,alist); + return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC(s_assv, "assv", 2, 0, 0, scm_assv); - -SCM -scm_assv(x, alist) - SCM x; - SCM alist; +GUILE_PROC(scm_assv, "assv", 2, 0, 0, + (SCM x, SCM alist), +"") +#define FUNC_NAME s_scm_assv { SCM tmp; for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) { @@ -163,39 +158,35 @@ scm_assv(x, alist) } # ifndef SCM_RECKLESS if (!(SCM_NULLP(alist))) - badlst: scm_wta(alist, (char *)SCM_ARG2, s_assv); + badlst: scm_wta(alist, (char *)SCM_ARG2, FUNC_NAME); # endif return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC(s_assoc, "assoc", 2, 0, 0, scm_assoc); - -SCM -scm_assoc(x, alist) - SCM x; - SCM alist; +GUILE_PROC(scm_assoc, "assoc", 2, 0, 0, + (SCM x, SCM alist), +"") +#define FUNC_NAME s_scm_assoc { - SCM tmp; - for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) { - SCM_ASSERT(SCM_CONSP(alist), alist, SCM_ARG2, s_assoc); - tmp = SCM_CAR(alist); - SCM_ASSERT(SCM_NIMP(tmp) && SCM_CONSP(tmp), alist, SCM_ARG2, s_assoc); - if SCM_NFALSEP(scm_equal_p(SCM_CAR(tmp), x)) return tmp; - } - SCM_ASSERT(SCM_NULLP(alist), alist, SCM_ARG2, s_assoc); - return SCM_BOOL_F; + SCM tmp; + for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) { + SCM_VALIDATE_ALISTCELL_COPYSCM(2,alist,tmp); + if SCM_NFALSEP(scm_equal_p(SCM_CAR(tmp), x)) return tmp; + } + SCM_VALIDATE_NULL(2,alist); + return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_assq_ref, "assq-ref", 2, 0, 0, scm_assq_ref); - -SCM -scm_assq_ref (alist, key) - SCM alist; - SCM key; +GUILE_PROC (scm_assq_ref, "assq-ref", 2, 0, 0, + (SCM alist, SCM key), +"") +#define FUNC_NAME s_scm_assq_ref { SCM handle; @@ -206,14 +197,13 @@ scm_assq_ref (alist, key) } return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_assv_ref, "assv-ref", 2, 0, 0, scm_assv_ref); - -SCM -scm_assv_ref (alist, key) - SCM alist; - SCM key; +GUILE_PROC (scm_assv_ref, "assv-ref", 2, 0, 0, + (SCM alist, SCM key), +"") +#define FUNC_NAME s_scm_assv_ref { SCM handle; @@ -224,14 +214,13 @@ scm_assv_ref (alist, key) } return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_assoc_ref, "assoc-ref", 2, 0, 0, scm_assoc_ref); - -SCM -scm_assoc_ref (alist, key) - SCM alist; - SCM key; +GUILE_PROC (scm_assoc_ref, "assoc-ref", 2, 0, 0, + (SCM alist, SCM key), +"") +#define FUNC_NAME s_scm_assoc_ref { SCM handle; @@ -242,19 +231,17 @@ scm_assoc_ref (alist, key) } return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_assq_set_x, "assq-set!", 3, 0, 0, scm_assq_set_x); - -SCM -scm_assq_set_x (alist, key, val) - SCM alist; - SCM key; - SCM val; +GUILE_PROC (scm_assq_set_x, "assq-set!", 3, 0, 0, + (SCM alist, SCM key, SCM val), +"") +#define FUNC_NAME s_scm_assq_set_x { SCM handle; @@ -267,14 +254,12 @@ scm_assq_set_x (alist, key, val) else return scm_acons (key, val, alist); } +#undef FUNC_NAME -SCM_PROC (s_assv_set_x, "assv-set!", 3, 0, 0, scm_assv_set_x); - -SCM -scm_assv_set_x (alist, key, val) - SCM alist; - SCM key; - SCM val; +GUILE_PROC (scm_assv_set_x, "assv-set!", 3, 0, 0, + (SCM alist, SCM key, SCM val), +"") +#define FUNC_NAME s_scm_assv_set_x { SCM handle; @@ -287,14 +272,12 @@ scm_assv_set_x (alist, key, val) else return scm_acons (key, val, alist); } +#undef FUNC_NAME -SCM_PROC (s_assoc_set_x, "assoc-set!", 3, 0, 0, scm_assoc_set_x); - -SCM -scm_assoc_set_x (alist, key, val) - SCM alist; - SCM key; - SCM val; +GUILE_PROC (scm_assoc_set_x, "assoc-set!", 3, 0, 0, + (SCM alist, SCM key, SCM val), +"") +#define FUNC_NAME s_scm_assoc_set_x { SCM handle; @@ -307,16 +290,15 @@ scm_assoc_set_x (alist, key, val) else return scm_acons (key, val, alist); } +#undef FUNC_NAME -SCM_PROC (s_assq_remove_x, "assq-remove!", 2, 0, 0, scm_assq_remove_x); - -SCM -scm_assq_remove_x (alist, key) - SCM alist; - SCM key; +GUILE_PROC (scm_assq_remove_x, "assq-remove!", 2, 0, 0, + (SCM alist, SCM key), +"") +#define FUNC_NAME s_scm_assq_remove_x { SCM handle; @@ -328,14 +310,13 @@ scm_assq_remove_x (alist, key) else return alist; } +#undef FUNC_NAME -SCM_PROC (s_assv_remove_x, "assv-remove!", 2, 0, 0, scm_assv_remove_x); - -SCM -scm_assv_remove_x (alist, key) - SCM alist; - SCM key; +GUILE_PROC (scm_assv_remove_x, "assv-remove!", 2, 0, 0, + (SCM alist, SCM key), +"") +#define FUNC_NAME s_scm_assv_remove_x { SCM handle; @@ -347,14 +328,13 @@ scm_assv_remove_x (alist, key) else return alist; } +#undef FUNC_NAME -SCM_PROC (s_assoc_remove_x, "assoc-remove!", 2, 0, 0, scm_assoc_remove_x); - -SCM -scm_assoc_remove_x (alist, key) - SCM alist; - SCM key; +GUILE_PROC (scm_assoc_remove_x, "assoc-remove!", 2, 0, 0, + (SCM alist, SCM key), +"") +#define FUNC_NAME s_scm_assoc_remove_x { SCM handle; @@ -366,6 +346,7 @@ scm_assoc_remove_x (alist, key) else return alist; } +#undef FUNC_NAME diff --git a/libguile/arbiters.c b/libguile/arbiters.c index 0e11b86c2..df1e34929 100644 --- a/libguile/arbiters.c +++ b/libguile/arbiters.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -45,6 +49,7 @@ #include "smob.h" #include "genio.h" +#include "scm_validate.h" #include "arbiters.h" @@ -59,10 +64,7 @@ static long scm_tc16_arbiter; static int -prinarb (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +prinarb (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("# @@ -47,6 +51,7 @@ #include "throw.h" #include "smob.h" +#include "scm_validate.h" #include "async.h" #ifdef HAVE_STRING_H @@ -123,9 +128,8 @@ scm_asyncs_pending () } #if 0 -static SCM scm_sys_tick_async_thunk SCM_P ((void)); static SCM -scm_sys_tick_async_thunk () +scm_sys_tick_async_thunk (void) { scm_deliver_signal (SCM_TICK_SIGNAL); return SCM_BOOL_F; @@ -263,11 +267,8 @@ scm_switch () -static SCM mark_async SCM_P ((SCM obj)); - static SCM -mark_async (obj) - SCM obj; +mark_async (SCM obj) { struct scm_async * it; it = SCM_ASYNC (obj); @@ -276,24 +277,23 @@ mark_async (obj) -SCM_PROC(s_async, "async", 1, 0, 0, scm_async); - -SCM -scm_async (thunk) - SCM thunk; +GUILE_PROC(scm_async, "async", 1, 0, 0, + (SCM thunk), +"") +#define FUNC_NAME s_scm_async { struct scm_async * async - = (struct scm_async *) scm_must_malloc (sizeof (*async), s_async); + = (struct scm_async *) scm_must_malloc (sizeof (*async), FUNC_NAME); async->got_it = 0; async->thunk = thunk; SCM_RETURN_NEWSMOB (scm_tc16_async, async); } +#undef FUNC_NAME -SCM_PROC(s_system_async, "system-async", 1, 0, 0, scm_system_async); - -SCM -scm_system_async (thunk) - SCM thunk; +GUILE_PROC(scm_system_async, "system-async", 1, 0, 0, + (SCM thunk), +"") +#define FUNC_NAME s_scm_system_async { SCM it; SCM list; @@ -303,30 +303,28 @@ scm_system_async (thunk) scm_asyncs = list; return it; } +#undef FUNC_NAME -SCM_PROC(s_async_mark, "async-mark", 1, 0, 0, scm_async_mark); - -SCM -scm_async_mark (a) - SCM a; +GUILE_PROC(scm_async_mark, "async-mark", 1, 0, 0, + (SCM a), +"") +#define FUNC_NAME s_scm_async_mark { struct scm_async * it; - SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark); - it = SCM_ASYNC (a); + SCM_VALIDATE_ASYNC_COPY(1,a,it); it->got_it = 1; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_system_async_mark, "system-async-mark", 1, 0, 0, scm_system_async_mark); - -SCM -scm_system_async_mark (a) - SCM a; +GUILE_PROC(scm_system_async_mark, "system-async-mark", 1, 0, 0, + (SCM a), +"") +#define FUNC_NAME s_scm_system_async_mark { struct scm_async * it; - SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark); - it = SCM_ASYNC (a); + SCM_VALIDATE_ASYNC_COPY(1,a,it); SCM_REDEFER_INTS; it->got_it = 1; scm_async_rate = 1 + scm_async_rate - scm_async_clock; @@ -334,26 +332,23 @@ scm_system_async_mark (a) SCM_REALLOW_INTS; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_run_asyncs, "run-asyncs", 1, 0, 0, scm_run_asyncs); - -SCM -scm_run_asyncs (list_of_a) - SCM list_of_a; +GUILE_PROC(scm_run_asyncs, "run-asyncs", 1, 0, 0, + (SCM list_of_a), +"") +#define FUNC_NAME s_scm_run_asyncs { - SCM pos; - if (scm_mask_ints) return SCM_BOOL_F; - pos = list_of_a; - while (pos != SCM_EOL) + while (list_of_a != SCM_EOL) { SCM a; struct scm_async * it; - SCM_ASSERT (SCM_NIMP (pos) && SCM_CONSP (pos), pos, SCM_ARG1, s_run_asyncs); - a = SCM_CAR (pos); - SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_run_asyncs); + SCM_VALIDATE_NIMCONS(1,list_of_a); + a = SCM_CAR (list_of_a); + SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, FUNC_NAME); it = SCM_ASYNC (a); scm_mask_ints = 1; if (it->got_it) @@ -362,60 +357,61 @@ scm_run_asyncs (list_of_a) scm_apply (it->thunk, SCM_EOL, SCM_EOL); } scm_mask_ints = 0; - pos = SCM_CDR (pos); + list_of_a = SCM_CDR (list_of_a); } return SCM_BOOL_T; } +#undef FUNC_NAME -SCM_PROC(s_noop, "noop", 0, 0, 1, scm_noop); - -SCM -scm_noop (args) - SCM args; +GUILE_PROC(scm_noop, "noop", 0, 0, 1, + (SCM args), +"") +#define FUNC_NAME s_scm_noop { return (SCM_NULLP (args) ? SCM_BOOL_F : SCM_CAR (args)); } +#undef FUNC_NAME -SCM_PROC(s_set_tick_rate, "set-tick-rate", 1, 0, 0, scm_set_tick_rate); - -SCM -scm_set_tick_rate (n) - SCM n; +GUILE_PROC(scm_set_tick_rate, "set-tick-rate", 1, 0, 0, + (SCM n), +"") +#define FUNC_NAME s_scm_set_tick_rate { unsigned int old_n; - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_tick_rate); + SCM_VALIDATE_INT(1,n); old_n = scm_tick_rate; scm_desired_tick_rate = SCM_INUM (n); scm_async_rate = 1 + scm_async_rate - scm_async_clock; scm_async_clock = 1; return SCM_MAKINUM (old_n); } +#undef FUNC_NAME -SCM_PROC(s_set_switch_rate, "set-switch-rate", 1, 0, 0, scm_set_switch_rate); - -SCM -scm_set_switch_rate (n) - SCM n; +GUILE_PROC(scm_set_switch_rate, "set-switch-rate", 1, 0, 0, + (SCM n), +"") +#define FUNC_NAME s_scm_set_switch_rate { unsigned int old_n; - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_switch_rate); + SCM_VALIDATE_INT(1,n); old_n = scm_switch_rate; scm_desired_switch_rate = SCM_INUM (n); scm_async_rate = 1 + scm_async_rate - scm_async_clock; scm_async_clock = 1; return SCM_MAKINUM (old_n); } +#undef FUNC_NAME @@ -442,24 +438,26 @@ scm_sys_gc_async_thunk (void) -SCM_PROC(s_unmask_signals, "unmask-signals", 0, 0, 0, scm_unmask_signals); - -SCM -scm_unmask_signals () +GUILE_PROC(scm_unmask_signals, "unmask-signals", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_unmask_signals { scm_mask_ints = 0; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_mask_signals, "mask-signals", 0, 0, 0, scm_mask_signals); - -SCM -scm_mask_signals () +GUILE_PROC(scm_mask_signals, "mask-signals", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_mask_signals { scm_mask_ints = 1; return SCM_UNSPECIFIED; } +#undef FUNC_NAME diff --git a/libguile/backtrace.c b/libguile/backtrace.c index eecbb5af8..d0e741091 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.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 #include @@ -77,11 +81,8 @@ SCM scm_the_last_stack_fluid; -static void display_header SCM_P ((SCM source, SCM port)); static void -display_header (source, port) - SCM source; - SCM port; +display_header (SCM source, SCM port) { SCM fname = (SCM_NIMP (source) && SCM_MEMOIZEDP (source) ? scm_source_property (source, scm_sym_filename) @@ -147,13 +148,8 @@ scm_display_error_message (message, args, port) scm_putc ('\n', port); } -static void display_expression SCM_P ((SCM frame, SCM pname, SCM source, SCM port)); static void -display_expression (frame, pname, source, port) - SCM frame; - SCM pname; - SCM source; - SCM port; +display_expression (SCM frame,SCM pname,SCM source,SCM port) { SCM print_state = scm_make_print_state (); scm_print_state *pstate = SCM_PRINT_STATE (print_state); @@ -255,15 +251,10 @@ display_error_handler (struct display_error_handler_data *data, return SCM_UNSPECIFIED; } -SCM_PROC(s_display_error, "display-error", 6, 0, 0, scm_display_error); -SCM -scm_display_error (stack, port, subr, message, args, rest) - SCM stack; - SCM port; - SCM subr; - SCM message; - SCM args; - SCM rest; +GUILE_PROC(scm_display_error, "display-error", 6, 0, 0, + (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest), +"") +#define FUNC_NAME s_scm_display_error { struct display_error_args a; struct display_error_handler_data data; @@ -280,6 +271,7 @@ scm_display_error (stack, port, subr, message, args, rest) (scm_catch_handler_t) display_error_handler, &data); return SCM_UNSPECIFIED; } +#undef FUNC_NAME typedef struct { int level; @@ -296,15 +288,14 @@ static print_params_t default_print_params[] = { static print_params_t *print_params = default_print_params; #ifdef GUILE_DEBUG -SCM_PROC (s_set_print_params_x, "set-print-params!", 1, 0, 0, scm_set_print_params_x); - -SCM -scm_set_print_params_x (SCM params) +GUILE_PROC(set_print_params_x, "set-print-params!", 1, 0, 0, + (SCM params) +#define FUNC_NAME s_set_print_params_x { int i, n = scm_ilength (params); SCM ls; print_params_t *new_params; - SCM_ASSERT (n >= 1, params, SCM_ARG2, s_set_print_params_x); + SCM_ASSERT (n >= 1, params, SCM_ARG2, FUNC_NAME); for (ls = params; SCM_NIMP (ls); ls = SCM_CDR (ls)) SCM_ASSERT (scm_ilength (SCM_CAR (params)) == 2 && SCM_INUMP (SCM_CAAR (ls)) @@ -315,7 +306,7 @@ scm_set_print_params_x (SCM params) SCM_ARG2, s_set_print_params_x); new_params = scm_must_malloc (n * sizeof (print_params_t), - s_set_print_params_x); + FUNC_NAME); if (print_params != default_print_params) scm_must_free (print_params); print_params = new_params; @@ -328,29 +319,19 @@ scm_set_print_params_x (SCM params) n_print_params = n; return SCM_UNSPECIFIED; } +#undef FUNC_NAME #endif -static void indent SCM_P ((int n, SCM port)); static void -indent (n, port) - int n; - SCM port; +indent (int n, SCM port) { int i; for (i = 0; i < n; ++i) scm_putc (' ', port); } -static void display_frame_expr SCM_P ((char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate)); static void -display_frame_expr (hdr, exp, tlr, indentation, sport, port, pstate) - char *hdr; - SCM exp; - char *tlr; - int indentation; - SCM sport; - SCM port; - scm_print_state *pstate; +display_frame_expr (char *hdr,SCM exp,char *tlr,int indentation,SCM sport,SCM port,scm_print_state *pstate) { SCM string; int i = 0, n; @@ -391,14 +372,8 @@ display_frame_expr (hdr, exp, tlr, indentation, sport, port, pstate) scm_lfwrite (SCM_CHARS (string), n, port); } -static void display_application SCM_P ((SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate)); static void -display_application (frame, indentation, sport, port, pstate) - SCM frame; - int indentation; - SCM sport; - SCM port; - scm_print_state *pstate; +display_application (SCM frame,int indentation,SCM sport,SCM port,scm_print_state *pstate) { SCM proc = SCM_FRAME_PROC (frame); SCM name = (SCM_NFALSEP (scm_procedure_p (proc)) @@ -414,10 +389,10 @@ display_application (frame, indentation, sport, port, pstate) pstate); } -SCM_PROC(s_display_application, "display-application", 1, 2, 0, scm_display_application); - -SCM -scm_display_application (SCM frame, SCM port, SCM indent) +GUILE_PROC(scm_display_application, "display-application", 1, 2, 0, + (SCM frame, SCM port, SCM indent), +"") +#define FUNC_NAME s_scm_display_application { SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), frame, SCM_ARG1, s_display_application); @@ -442,7 +417,7 @@ scm_display_application (SCM frame, SCM port, SCM indent) scm_make_string (SCM_MAKINUM (240), SCM_UNDEFINED), SCM_OPN | SCM_WRTNG, - s_display_application); + FUNC_NAME); /* Create a print state for printing of frames. */ print_state = scm_make_print_state (); @@ -456,16 +431,10 @@ scm_display_application (SCM frame, SCM port, SCM indent) else return SCM_BOOL_F; } +#undef FUNC_NAME -static void display_frame SCM_P ((SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate)); static void -display_frame (frame, nfield, indentation, sport, port, pstate) - SCM frame; - int nfield; - int indentation; - SCM sport; - SCM port; - scm_print_state *pstate; +display_frame (SCM frame,int nfield,int indentation,SCM sport,SCM port,scm_print_state *pstate) { int n, i, j; @@ -530,10 +499,9 @@ struct display_backtrace_args { SCM depth; }; -SCM_PROC(s_display_backtrace, "display-backtrace", 2, 2, 0, scm_display_backtrace); - static SCM -display_backtrace_body (struct display_backtrace_args *a) +display_backtrace_body(struct display_backtrace_args *a) +#define FUNC_NAME "display_backtrace_body" { int n_frames, beg, end, n, i, j; int nfield, indent_p, indentation; @@ -586,7 +554,7 @@ display_backtrace_body (struct display_backtrace_args *a) sport = scm_mkstrport (SCM_INUM0, scm_make_string (SCM_MAKINUM (240), SCM_UNDEFINED), SCM_OPN | SCM_WRTNG, - s_display_backtrace); + FUNC_NAME); /* Create a print state for printing of frames. */ print_state = scm_make_print_state (); @@ -635,13 +603,12 @@ display_backtrace_body (struct display_backtrace_args *a) return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM -scm_display_backtrace (stack, port, first, depth) - SCM stack; - SCM port; - SCM first; - SCM depth; +GUILE_PROC(scm_display_backtrace, "display-backtrace", 2, 2, 0, + (SCM stack, SCM port, SCM first, SCM depth), +"") +#define FUNC_NAME s_scm_display_backtrace { struct display_backtrace_args a; struct display_error_handler_data data; @@ -656,12 +623,14 @@ scm_display_backtrace (stack, port, first, depth) (scm_catch_handler_t) display_error_handler, &data); return SCM_UNSPECIFIED; } +#undef FUNC_NAME SCM_VCELL (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?"); -SCM_PROC(s_backtrace, "backtrace", 0, 0, 0, scm_backtrace); -SCM -scm_backtrace () +GUILE_PROC(scm_backtrace, "backtrace", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_backtrace { SCM the_last_stack = scm_fluid_ref (SCM_CDR (scm_the_last_stack_fluid)); if (SCM_NFALSEP (the_last_stack)) @@ -689,6 +658,7 @@ scm_backtrace () } return SCM_UNSPECIFIED; } +#undef FUNC_NAME diff --git a/libguile/boolean.c b/libguile/boolean.c index a9527a278..1721d94f0 100644 --- a/libguile/boolean.c +++ b/libguile/boolean.c @@ -38,35 +38,38 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include #include "_scm.h" +#include "scm_validate.h" #include "boolean.h" -SCM_PROC(s_not, "not", 1, 0, 0, scm_not); - -SCM -scm_not(x) - SCM x; +GUILE_PROC(scm_not, "not", 1, 0, 0, + (SCM x), + "") +#define FUNC_NAME s_scm_not { - return SCM_FALSEP(x) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_FALSEP(x) ? SCM_BOOL_T : SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC(s_boolean_p, "boolean?", 1, 0, 0, scm_boolean_p); - -SCM -scm_boolean_p(obj) - SCM obj; +GUILE_PROC(scm_boolean_p, "boolean?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_boolean_p { - if (SCM_BOOL_F==obj) return SCM_BOOL_T; - if (SCM_BOOL_T==obj) return SCM_BOOL_T; - return SCM_BOOL_F; + return SCM_BOOL(SCM_BOOL_F == obj || SCM_BOOL_T == obj); } +#undef FUNC_NAME diff --git a/libguile/chars.c b/libguile/chars.c index f5f7fd402..121d133ca 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -38,263 +38,259 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include #include #include "_scm.h" +#include "scm_validate.h" #include "chars.h" - - -SCM_PROC(s_char_p, "char?", 1, 0, 0, scm_char_p); - -SCM -scm_char_p(x) - SCM x; +GUILE_PROC (scm_char_p, "char?", 1, 0, 0, + (SCM x), +"Return #t iff X is a character, else #f.") +#define FUNC_NAME s_scm_char_p { return SCM_ICHRP(x) ? SCM_BOOL_T : SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC1 (s_char_eq_p, "char=?", scm_tc7_rpsubr, scm_char_eq_p); - -SCM -scm_char_eq_p(x, y) - SCM x; - SCM y; +GUILE_PROC1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr, + (SCM x, SCM y), +"Return #t iff X is the same character as Y, else #f.") +#define FUNC_NAME s_scm_char_eq_p { - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_eq_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_eq_p); - return (SCM_ICHR(x) == SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F; + SCM_VALIDATE_CHAR(1,x); + SCM_VALIDATE_CHAR(2,y); + return SCM_BOOL(SCM_ICHR(x) == SCM_ICHR(y)); } +#undef FUNC_NAME -SCM_PROC1 (s_char_less_p, "char?", scm_tc7_rpsubr, scm_char_gr_p); - -SCM -scm_char_gr_p(x, y) - SCM x; - SCM y; +GUILE_PROC1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr, + (SCM x, SCM y), +"Return #t iff X is greater than Y in the Ascii sequence, else #f.") +#define FUNC_NAME s_scm_char_gr_p { - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_gr_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_gr_p); - return (SCM_ICHR(x) > SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F; + SCM_VALIDATE_CHAR(1,x); + SCM_VALIDATE_CHAR(2,y); + return SCM_BOOL(SCM_ICHR(x) > SCM_ICHR(y)); } +#undef FUNC_NAME -SCM_PROC1 (s_char_geq_p, "char>=?", scm_tc7_rpsubr, scm_char_geq_p); - -SCM -scm_char_geq_p(x, y) - SCM x; - SCM y; +GUILE_PROC1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr, + (SCM x, SCM y), +"Return #t iff X is greater than or equal to Y in the Ascii sequence, else #f.") +#define FUNC_NAME s_scm_char_geq_p { - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_geq_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_geq_p); - return (SCM_ICHR(x) >= SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F; + SCM_VALIDATE_CHAR(1,x); + SCM_VALIDATE_CHAR(2,y); + return SCM_BOOL(SCM_ICHR(x) >= SCM_ICHR(y)); } +#undef FUNC_NAME -SCM_PROC1 (s_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr, scm_char_ci_eq_p); - -SCM -scm_char_ci_eq_p(x, y) - SCM x; - SCM y; +GUILE_PROC1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr, + (SCM x, SCM y), +"Return #t iff X is the same character as Y ignoring case, else #f.") +#define FUNC_NAME s_scm_char_ci_eq_p { - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_eq_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_eq_p); - return (scm_upcase(SCM_ICHR(x))==scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F; + SCM_VALIDATE_CHAR(1,x); + SCM_VALIDATE_CHAR(2,y); + return SCM_BOOL(scm_upcase(SCM_ICHR(x))==scm_upcase(SCM_ICHR(y))); } +#undef FUNC_NAME -SCM_PROC1 (s_char_ci_less_p, "char-ci?", scm_tc7_rpsubr, scm_char_ci_gr_p); - -SCM -scm_char_ci_gr_p(x, y) - SCM x; - SCM y; +GUILE_PROC1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr, + (SCM x, SCM y), +"Return #t iff X is greater than Y in the Ascii sequence ignoring case, else #f.") +#define FUNC_NAME s_scm_char_ci_gr_p { - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_gr_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_gr_p); - return (scm_upcase(SCM_ICHR(x)) > scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F; + SCM_VALIDATE_CHAR(1,x); + SCM_VALIDATE_CHAR(2,y); + return SCM_BOOL(scm_upcase(SCM_ICHR(x)) > scm_upcase(SCM_ICHR(y))); } +#undef FUNC_NAME -SCM_PROC1 (s_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr, scm_char_ci_geq_p); - -SCM -scm_char_ci_geq_p(x, y) - SCM x; - SCM y; +GUILE_PROC1 (scm_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr, + (SCM x, SCM y), +"Return #t iff X is greater than or equal to Y in the Ascii sequence ignoring case, else #f.") +#define FUNC_NAME s_scm_char_ci_geq_p { - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_geq_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_geq_p); - return (scm_upcase(SCM_ICHR(x)) >= scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F; + SCM_VALIDATE_CHAR(1,x); + SCM_VALIDATE_CHAR(2,y); + return SCM_BOOL(scm_upcase(SCM_ICHR(x)) >= scm_upcase(SCM_ICHR(y))); } +#undef FUNC_NAME -SCM_PROC(s_char_alphabetic_p, "char-alphabetic?", 1, 0, 0, scm_char_alphabetic_p); - -SCM -scm_char_alphabetic_p(chr) - SCM chr; +GUILE_PROC(scm_char_alphabetic_p, "char-alphabetic?", 1, 0, 0, + (SCM chr), +"Return #t iff CHR is alphabetic, else #f. +Alphabetic means the same thing as the isalpha C library function.") +#define FUNC_NAME s_scm_char_alphabetic_p { - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_alphabetic_p); - return (isascii(SCM_ICHR(chr)) && isalpha(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F; + SCM_VALIDATE_CHAR(1,chr); + return SCM_BOOL(isascii(SCM_ICHR(chr)) && isalpha(SCM_ICHR(chr))); } +#undef FUNC_NAME -SCM_PROC(s_char_numeric_p, "char-numeric?", 1, 0, 0, scm_char_numeric_p); - -SCM -scm_char_numeric_p(chr) - SCM chr; +GUILE_PROC(scm_char_numeric_p, "char-numeric?", 1, 0, 0, + (SCM chr), +"Return #t iff CHR is numeric, else #f. +Numeric means the same thing as the isdigit C library function.") +#define FUNC_NAME s_scm_char_numeric_p { - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_numeric_p); - return (isascii(SCM_ICHR(chr)) && isdigit(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F; + SCM_VALIDATE_CHAR(1,chr); + return SCM_BOOL(isascii(SCM_ICHR(chr)) && isdigit(SCM_ICHR(chr))); } +#undef FUNC_NAME -SCM_PROC(s_char_whitespace_p, "char-whitespace?", 1, 0, 0, scm_char_whitespace_p); - -SCM -scm_char_whitespace_p(chr) - SCM chr; +GUILE_PROC(scm_char_whitespace_p, "char-whitespace?", 1, 0, 0, + (SCM chr), +"Return #t iff CHR is whitespace, else #f. +Whitespace means the same thing as the isspace C library function.") +#define FUNC_NAME s_scm_char_whitespace_p { - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_whitespace_p); - return (isascii(SCM_ICHR(chr)) && isspace(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F; + SCM_VALIDATE_CHAR(1,chr); + return SCM_BOOL(isascii(SCM_ICHR(chr)) && isspace(SCM_ICHR(chr))); } +#undef FUNC_NAME -SCM_PROC(s_char_upper_case_p, "char-upper-case?", 1, 0, 0, scm_char_upper_case_p); - -SCM -scm_char_upper_case_p(chr) - SCM chr; +GUILE_PROC(scm_char_upper_case_p, "char-upper-case?", 1, 0, 0, + (SCM chr), +"Return #t iff CHR is uppercase, else #f. +Uppercase means the same thing as the isupper C library function.") +#define FUNC_NAME s_scm_char_upper_case_p { - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upper_case_p); - return (isascii(SCM_ICHR(chr)) && isupper(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F; + SCM_VALIDATE_CHAR(1,chr); + return SCM_BOOL(isascii(SCM_ICHR(chr)) && isupper(SCM_ICHR(chr))); } +#undef FUNC_NAME -SCM_PROC(s_char_lower_case_p, "char-lower-case?", 1, 0, 0, scm_char_lower_case_p); - -SCM -scm_char_lower_case_p(chr) - SCM chr; +GUILE_PROC(scm_char_lower_case_p, "char-lower-case?", 1, 0, 0, + (SCM chr), +"Return #t iff CHR is lowercase, else #f. +Lowercase means the same thing as the islower C library function.") +#define FUNC_NAME s_scm_char_lower_case_p { - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_lower_case_p); - return (isascii(SCM_ICHR(chr)) && islower(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F; + SCM_VALIDATE_CHAR(1,chr); + return SCM_BOOL(isascii(SCM_ICHR(chr)) && islower(SCM_ICHR(chr))); } +#undef FUNC_NAME -SCM_PROC (s_char_is_both_p, "char-is-both?", 1, 0, 0, scm_char_is_both_p); - -SCM -scm_char_is_both_p (chr) - SCM chr; +GUILE_PROC (scm_char_is_both_p, "char-is-both?", 1, 0, 0, + (SCM chr), +"Return #t iff CHR is either uppercase or lowercase, else #f. +Uppercase and lowercase are as defined by the isupper and islower +C library functions.") +#define FUNC_NAME s_scm_char_is_both_p { - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upper_case_p); - return ((isascii(SCM_ICHR(chr)) && (isupper(SCM_ICHR(chr)) || islower(SCM_ICHR(chr)))) - ? SCM_BOOL_T - : SCM_BOOL_F); + SCM_VALIDATE_CHAR(1,chr); + return SCM_BOOL(isascii(SCM_ICHR(chr)) && (isupper(SCM_ICHR(chr)) || islower(SCM_ICHR(chr)))); } +#undef FUNC_NAME -SCM_PROC(s_char_to_integer, "char->integer", 1, 0, 0, scm_char_to_integer); - -SCM -scm_char_to_integer(chr) - SCM chr; +GUILE_PROC (scm_char_to_integer, "char->integer", 1, 0, 0, + (SCM chr), +"Return the number corresponding to ordinal position of CHR in the Ascii sequence.") +#define FUNC_NAME s_scm_char_to_integer { - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_to_integer); + SCM_VALIDATE_CHAR(1,chr); return scm_ulong2num((unsigned long)SCM_ICHR(chr)); } +#undef FUNC_NAME -SCM_PROC(s_integer_to_char, "integer->char", 1, 0, 0, scm_integer_to_char); - -SCM -scm_integer_to_char(n) - SCM n; +GUILE_PROC(scm_integer_to_char, "integer->char", 1, 0, 0, + (SCM n), +"Return the character at position N in the Ascii sequence.") +#define FUNC_NAME s_scm_integer_to_char { - unsigned long ni; - - ni = 0xffff & scm_num2ulong (n, (char *)SCM_ARG1, s_integer_to_char); - return SCM_MAKICHR(SCM_INUM(n)); + unsigned long ni = 0xffff & scm_num2ulong (n, (char *)SCM_ARG1, FUNC_NAME); + return SCM_MAKICHR(ni); } +#undef FUNC_NAME -SCM_PROC(s_char_upcase, "char-upcase", 1, 0, 0, scm_char_upcase); - -SCM -scm_char_upcase(chr) - SCM chr; +GUILE_PROC(scm_char_upcase, "char-upcase", 1, 0, 0, + (SCM chr), +"Return the uppercase character version of CHR.") +#define FUNC_NAME s_scm_char_upcase { - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upcase); + SCM_VALIDATE_CHAR(1,chr); return SCM_MAKICHR(scm_upcase(SCM_ICHR(chr))); } +#undef FUNC_NAME -SCM_PROC(s_char_downcase, "char-downcase", 1, 0, 0, scm_char_downcase); - -SCM -scm_char_downcase(chr) - SCM chr; +GUILE_PROC(scm_char_downcase, "char-downcase", 1, 0, 0, + (SCM chr), +"Return the lowercase character version of CHR.") +#define FUNC_NAME s_scm_char_downcase { - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_downcase); + SCM_VALIDATE_CHAR(1,chr); return SCM_MAKICHR(scm_downcase(SCM_ICHR(chr))); } +#undef FUNC_NAME diff --git a/libguile/continuations.c b/libguile/continuations.c index 78b12623a..ea8393222 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -123,11 +127,8 @@ scm_make_cont (answer) /* to copy in the continuation. Then */ #ifndef CHEAP_CONTINUATIONS -static void grow_throw SCM_P ((SCM *a)); - static void -grow_throw (a) - SCM *a; +grow_throw (SCM *a) { /* retry the throw. */ SCM growth[100]; growth[0] = a[0]; 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 #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 ("#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 ("# - -#ifdef RTLD_LAZY /* Solaris 2. */ -# define DLOPEN_MODE RTLD_LAZY -#else -# define DLOPEN_MODE 1 /* Thats what it says in the man page. */ -#endif - -#ifndef RTLD_GLOBAL /* Some systems have no such flag. */ -# define RTLD_GLOBAL 0 -#endif - -static void * -sysdep_dynl_link (fname, flags, subr) - const char *fname; - int flags; - const char *subr; -{ - void *handle = dlopen (fname, (DLOPEN_MODE - | ((flags & DYNL_GLOBAL)? RTLD_GLOBAL : 0))); - if (NULL == handle) - { - SCM_ALLOW_INTS; - scm_misc_error (subr, (char *)dlerror (), SCM_EOL); - } - return handle; -} - -static void -sysdep_dynl_unlink (handle, subr) - void *handle; - const char *subr; -{ - if (dlclose (handle)) - { - SCM_ALLOW_INTS; - scm_misc_error (subr, (char *)dlerror (), SCM_EOL); - } -} - -static void * -sysdep_dynl_func (symb, handle, subr) - const char *symb; - void *handle; - const char *subr; -{ - void *fptr; - char *err; -#if defined(USCORE) && !defined(DLSYM_ADDS_USCORE) - char *usymb; -#endif - -#if defined(USCORE) && !defined(DLSYM_ADDS_USCORE) - usymb = (char *) malloc (strlen (symb) + 2); - *usymb = '_'; - strcpy (usymb + 1, symb); - fptr = dlsym (handle, usymb); - free (usymb); -#else - fptr = dlsym (handle, symb); -#endif - - err = (char *)dlerror (); - if (!fptr) - { - SCM_ALLOW_INTS; - scm_misc_error (subr, err? err : "symbol has NULL address", SCM_EOL); - } - return fptr; -} - -static void -sysdep_dynl_init () -{ -} diff --git a/libguile/dynl-dld.c b/libguile/dynl-dld.c dissimilarity index 100% index 9bbe76058..e69de29bb 100644 --- a/libguile/dynl-dld.c +++ b/libguile/dynl-dld.c @@ -1,132 +0,0 @@ -/* dynl-dld.c - dynamic linking with dld - * - * Copyright (C) 1990-1997, 1999 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ - -/* "dynl.c" dynamically link&load object files. - Author: Aubrey Jaffer - Modified for libguile by Marius Vollmer */ - -#include "dld.h" - -static void listundef SCM_P ((void)); - -static void -listundefs () -{ - int i; - char **undefs = dld_list_undefined_sym(); - puts(" undefs:"); - for(i = dld_undefined_sym_count;i--;) { - putc('"', stdout); - fputs(undefs[i], stdout); - puts("\""); - } - free(undefs); -} - -static void * -sysdep_dynl_link (fname, int flags, subr) - const char *fname; - int flags; - const char *subr; -{ - int status; - - status = dld_link (fname); - if (status) - { - SCM_ALLOW_INTS; - scm_misc_error (subr, dld_strerror (status), SCM_EOL); - } - return fname; -} - -static void -sysdep_dynl_unlink (handle, subr) - void *handle; - const char *subr; -{ - int status; - - status = dld_unlink_by_file ((char *)fname, 1); - if (status) - { - SCM_ALLOW_INTS; - scm_misc_error (s_dynamic_unlink, dld_strerror (status), SCM_EOL); - } -} - -static void * -sysdep_dynl_func (symb, handle, subr) - const char *symb; - void *handle; - const char *subr; -{ - void *func; - - func = (void *) dld_get_func (func); - if (func == 0) - scm_misc_error (subr, dld_strerror (dld_errno), SCM_EOL); - if (!dld_function_executable_p (func)) { - listundefs (); - SCM_ALLOW_INTS; - scm_misc_error (subr, "unresolved symbols remain", SCM_EOL); - } - return func; -} - -static void -sysdep_dynl_init () -{ -#ifndef RTL - if (!execpath) - execpath = dld_find_executable (SCM_CHARS (SCM_CAR (progargs))); - if (dld_init (SCM_CHARS (SCM_CAR (progargs)))) { - dld_perror("DLD"); - return; - } -#endif - -#ifdef DLD_DYNCM /* XXX - what's this? */ - add_feature("dld:dyncm"); -#endif -} diff --git a/libguile/dynl-shl.c b/libguile/dynl-shl.c dissimilarity index 100% index 8f0caf2d6..e69de29bb 100644 --- a/libguile/dynl-shl.c +++ b/libguile/dynl-shl.c @@ -1,108 +0,0 @@ -/* dynl-shl.c - dynamic linking with shl_load (HP-UX) - * - * Copyright (C) 1990-1997 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ - -/* "dynl.c" dynamically link&load object files. - Author: Aubrey Jaffer - Modified for libguile by Marius Vollmer */ - -#include "dl.h" -#include -#include - -static void * -sysdep_dynl_link (fname, flags, subr) - const char *fname; - int flags; - const char *subr; -{ - shl_t shl; - - /* Probably too much BIND_* flags */ - shl = shl_load (fname, BIND_IMMEDIATE || BIND_FIRST || - BIND_TOGETHER || - BIND_VERBOSE || DYNAMIC_PATH, 0L); - if (NULL==shl) - { - SCM_ALLOW_INTS; - scm_misc_error (subr, "dynamic linking failed", SCM_EOL); - } - return shl; -} - -static void -sysdep_dynl_unlink (handle, subr) - void *handle; - const char *subr; -{ - if (shl_unload ((shl_t) handle)) - { - SCM_ALLOW_INTS; - scm_misc_error (subr, "dynamic unlinking failed", SCM_EOL); - } -} - -static void * -sysdep_dynl_func (symb, handle, subr) - const char *symb; - void *handle; - const char *subr; -{ - int status, i; - struct shl_symbol *sym; - - status = shl_getsymbols((shl_t) handle, TYPE_PROCEDURE, - EXPORT_SYMBOLS, malloc, &sym); - - for (i=0; ifilename; } -static scm_sizet free_dynl_obj SCM_P ((SCM ptr)); static scm_sizet -free_dynl_obj (ptr) - SCM ptr; +free_dynl_obj (SCM ptr) { scm_must_free ((char *)SCM_CDR (ptr)); return sizeof (struct dynl_obj); } -static int print_dynl_obj SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); static int -print_dynl_obj (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +print_dynl_obj (SCM exp,SCM port,scm_print_state *pstate) { struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (exp); scm_puts ("#filename = fname; d->handle = handle; @@ -388,13 +362,10 @@ scm_dynamic_link (fname, rest) return z; } +#undef FUNC_NAME -static struct dynl_obj *get_dynl_obj SCM_P ((SCM obj, const char *subr, int argn)); static struct dynl_obj * -get_dynl_obj (dobj, subr, argn) - SCM dobj; - const char *subr; - int argn; +get_dynl_obj (SCM dobj,const char *subr,int argn) { struct dynl_obj *d; SCM_ASSERT (SCM_NIMP (dobj) && SCM_CAR (dobj) == scm_tc16_dynamic_obj, @@ -404,69 +375,71 @@ get_dynl_obj (dobj, subr, argn) return d; } -SCM_PROC (s_dynamic_object_p, "dynamic-object?", 1, 0, 0, scm_dynamic_object_p); - -SCM -scm_dynamic_object_p (SCM obj) +GUILE_PROC (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_dynamic_object_p { return (SCM_NIMP (obj) && SCM_CAR (obj) == scm_tc16_dynamic_obj)? SCM_BOOL_T : SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_dynamic_unlink, "dynamic-unlink", 1, 0, 0, scm_dynamic_unlink); - -SCM -scm_dynamic_unlink (dobj) - SCM dobj; +GUILE_PROC (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0, + (SCM dobj), +"") +#define FUNC_NAME s_scm_dynamic_unlink { - struct dynl_obj *d = get_dynl_obj (dobj, s_dynamic_unlink, SCM_ARG1); + struct dynl_obj *d = get_dynl_obj (dobj, FUNC_NAME, SCM_ARG1); SCM_DEFER_INTS; - sysdep_dynl_unlink (d->handle, s_dynamic_unlink); + sysdep_dynl_unlink (d->handle, FUNC_NAME); d->handle = NULL; SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_dynamic_func, "dynamic-func", 2, 0, 0, scm_dynamic_func); - -SCM -scm_dynamic_func (SCM symb, SCM dobj) +GUILE_PROC (scm_dynamic_func, "dynamic-func", 2, 0, 0, + (SCM symb, SCM dobj), +"") +#define FUNC_NAME s_scm_dynamic_func { struct dynl_obj *d; void (*func) (); - symb = scm_coerce_rostring (symb, s_dynamic_func, SCM_ARG1); - d = get_dynl_obj (dobj, s_dynamic_func, SCM_ARG2); + symb = scm_coerce_rostring (symb, FUNC_NAME, SCM_ARG1); + d = get_dynl_obj (dobj, FUNC_NAME, SCM_ARG2); SCM_DEFER_INTS; func = (void (*) ()) sysdep_dynl_func (SCM_CHARS (symb), d->handle, - s_dynamic_func); + FUNC_NAME); SCM_ALLOW_INTS; return scm_ulong2num ((unsigned long)func); } +#undef FUNC_NAME -SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call); - -SCM -scm_dynamic_call (SCM func, SCM dobj) +GUILE_PROC (scm_dynamic_call, "dynamic-call", 2, 0, 0, + (SCM func, SCM dobj), +"") +#define FUNC_NAME s_scm_dynamic_call { void (*fptr)(); if (SCM_NIMP (func) && SCM_ROSTRINGP (func)) func = scm_dynamic_func (func, dobj); - fptr = (void (*)()) scm_num2ulong (func, (char *)SCM_ARG1, s_dynamic_call); + fptr = (void (*)()) scm_num2ulong (func, (char *)SCM_ARG1, FUNC_NAME); SCM_DEFER_INTS; fptr (); SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_dynamic_args_call, "dynamic-args-call", 3, 0, 0, scm_dynamic_args_call); - -SCM -scm_dynamic_args_call (func, dobj, args) - SCM func, dobj, args; +GUILE_PROC (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0, + (SCM func, SCM dobj, SCM args), +"") +#define FUNC_NAME s_scm_dynamic_args_call { int (*fptr) (int argc, char **argv); int result, argc; @@ -476,9 +449,9 @@ scm_dynamic_args_call (func, dobj, args) func = scm_dynamic_func (func, dobj); fptr = (int (*)(int, char **)) scm_num2ulong (func, (char *)SCM_ARG1, - s_dynamic_args_call); + FUNC_NAME); SCM_DEFER_INTS; - argv = scm_make_argv_from_stringlist (args, &argc, s_dynamic_args_call, + argv = scm_make_argv_from_stringlist (args, &argc, FUNC_NAME, SCM_ARG3); result = (*fptr) (argc, argv); scm_must_free_argv (argv); @@ -486,6 +459,7 @@ scm_dynamic_args_call (func, dobj, args) return SCM_MAKINUM(0L+result); } +#undef FUNC_NAME void scm_init_dynamic_linking () diff --git a/libguile/dynwind.c b/libguile/dynwind.c index 03e5f0ad4..f00be95b2 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -66,18 +70,15 @@ -SCM_PROC(s_dynamic_wind, "dynamic-wind", 3, 0, 0, scm_dynamic_wind); - -SCM -scm_dynamic_wind (thunk1, thunk2, thunk3) - SCM thunk1; - SCM thunk2; - SCM thunk3; +GUILE_PROC(scm_dynamic_wind, "dynamic-wind", 3, 0, 0, + (SCM thunk1, SCM thunk2, SCM thunk3), +"") +#define FUNC_NAME s_scm_dynamic_wind { SCM ans; SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk3)), thunk3, - SCM_ARG3, s_dynamic_wind); + SCM_ARG3, FUNC_NAME); scm_apply (thunk1, SCM_EOL, SCM_EOL); scm_dynwinds = scm_acons (thunk1, thunk3, scm_dynwinds); ans = scm_apply (thunk2, SCM_EOL, SCM_EOL); @@ -85,6 +86,7 @@ scm_dynamic_wind (thunk1, thunk2, thunk3) scm_apply (thunk3, SCM_EOL, SCM_EOL); return ans; } +#undef FUNC_NAME /* The implementation of a C-callable dynamic-wind, * scm_internal_dynamic_wind, requires packaging of C pointers in a @@ -144,13 +146,14 @@ scm_internal_dynamic_wind (scm_guard_t before, } #ifdef GUILE_DEBUG -SCM_PROC (s_wind_chain, "wind-chain", 0, 0, 0, scm_wind_chain); - -SCM -scm_wind_chain () +GUILE_PROC (scm_wind_chain, "wind-chain", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_wind_chain { return scm_dynwinds; } +#undef FUNC_NAME #endif static void diff --git a/libguile/eq.c b/libguile/eq.c index db08c4013..4941ac826 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include #include "_scm.h" @@ -47,27 +51,23 @@ #include "smob.h" #include "unif.h" +#include "scm_validate.h" #include "eq.h" -SCM_PROC1 (s_eq_p, "eq?", scm_tc7_rpsubr, scm_eq_p); - -SCM -scm_eq_p (x, y) - SCM x; - SCM y; +GUILE_PROC1 (scm_eq_p, "eq?", scm_tc7_rpsubr, + (SCM x, SCM y), +"") +#define FUNC_NAME s_scm_eq_p { - return ((x==y) - ? SCM_BOOL_T - : SCM_BOOL_F); + return SCM_BOOL(x==y); } +#undef FUNC_NAME -SCM_PROC1 (s_eqv_p, "eqv?", scm_tc7_rpsubr, scm_eqv_p); - -SCM -scm_eqv_p (x, y) - SCM x; - SCM y; +GUILE_PROC1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr, + (SCM x, SCM y), +"") +#define FUNC_NAME s_scm_eqv_p { if (x==y) return SCM_BOOL_T; if (SCM_IMP(x)) return SCM_BOOL_F; @@ -86,14 +86,13 @@ scm_eqv_p (x, y) } return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC1 (s_equal_p, "equal?", scm_tc7_rpsubr, scm_equal_p); - -SCM -scm_equal_p (x, y) - SCM x; - SCM y; +GUILE_PROC1 (scm_equal_p, "equal?", scm_tc7_rpsubr, + (SCM x, SCM y), +"") +#define FUNC_NAME s_scm_equal_p { SCM_CHECK_STACK; tailrecurse: SCM_TICK; @@ -139,6 +138,7 @@ scm_equal_p (x, y) } return SCM_BOOL_F; } +#undef FUNC_NAME diff --git a/libguile/error.c b/libguile/error.c index 7fe02fb85..3dad73300 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -46,6 +50,7 @@ #include "genio.h" #include "throw.h" +#include "scm_validate.h" #include "error.h" #ifdef HAVE_UNISTD_H @@ -62,12 +67,7 @@ extern int errno; /* All errors should pass through here. */ void -scm_error (key, subr, message, args, rest) - SCM key; - const char *subr; - const char *message; - SCM args; - SCM rest; +scm_error (SCM key, const char *subr, const char *message, SCM args, SCM rest) { SCM arg_list; arg_list = scm_listify (subr ? scm_makfrom0str (subr) : SCM_BOOL_F, @@ -87,44 +87,36 @@ scm_error (key, subr, message, args, rest) } /* Scheme interface to scm_error. */ -SCM_PROC(s_error_scm, "scm-error", 5, 0, 0, scm_error_scm); -SCM -scm_error_scm (key, subr, message, args, rest) - SCM key; - SCM subr; - SCM message; - SCM args; - SCM rest; +GUILE_PROC(scm_error_scm, "scm-error", 5, 0, 0, + (SCM key, SCM subr, SCM message, SCM args, SCM rest), +"") +#define FUNC_NAME s_scm_error_scm { - SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1, s_error_scm); - SCM_ASSERT (SCM_FALSEP (subr) || (SCM_NIMP (subr) && SCM_ROSTRINGP (subr)), - subr, SCM_ARG2, s_error_scm); - SCM_ASSERT (SCM_FALSEP (message) - || (SCM_NIMP (message) && SCM_ROSTRINGP (message)), - message, SCM_ARG3, s_error_scm); - + char *szSubr; + char *szMessage; + SCM_VALIDATE_SYMBOL(1,key); + SCM_VALIDATE_NULLORROSTRING_COPY(2,subr,szSubr); + SCM_VALIDATE_NULLORROSTRING_COPY(3,message,szMessage); SCM_COERCE_SUBSTR (message); - scm_error (key, - (SCM_FALSEP (subr)) ? NULL : SCM_ROCHARS (subr), - (SCM_FALSEP (message)) ? NULL : SCM_ROCHARS (message), - args, - rest); + scm_error (key, szSubr, szMessage, args, rest); /* not reached. */ } +#undef FUNC_NAME -SCM_PROC (s_strerror, "strerror", 1, 0, 0, scm_strerror); -SCM -scm_strerror (SCM err) +GUILE_PROC (scm_strerror, "strerror", 1, 0, 0, + (SCM err), +"") +#define FUNC_NAME s_scm_strerror { - SCM_ASSERT (SCM_INUMP (err), err, SCM_ARG1, s_strerror); + SCM_VALIDATE_INT(1,err); return scm_makfrom0str (strerror (SCM_INUM (err))); } +#undef FUNC_NAME SCM_SYMBOL (scm_system_error_key, "system-error"); void -scm_syserror (subr) - const char *subr; +scm_syserror (const char *subr) { scm_error (scm_system_error_key, subr, @@ -134,11 +126,7 @@ scm_syserror (subr) } void -scm_syserror_msg (subr, message, args, eno) - const char *subr; - const char *message; - SCM args; - int eno; +scm_syserror_msg (const char *subr, const char *message, SCM args, int eno) { scm_error (scm_system_error_key, subr, @@ -148,8 +136,7 @@ scm_syserror_msg (subr, message, args, eno) } void -scm_sysmissing (subr) - const char *subr; +scm_sysmissing (const char *subr) { #ifdef ENOSYS scm_error (scm_system_error_key, @@ -168,8 +155,7 @@ scm_sysmissing (subr) SCM_SYMBOL (scm_num_overflow_key, "numerical-overflow"); void -scm_num_overflow (subr) - const char *subr; +scm_num_overflow (const char *subr) { scm_error (scm_num_overflow_key, subr, @@ -180,9 +166,7 @@ scm_num_overflow (subr) SCM_SYMBOL (scm_out_of_range_key, "out-of-range"); void -scm_out_of_range (subr, bad_value) - const char *subr; - SCM bad_value; +scm_out_of_range (const char *subr, SCM bad_value) { scm_error (scm_out_of_range_key, subr, @@ -193,8 +177,7 @@ scm_out_of_range (subr, bad_value) SCM_SYMBOL (scm_args_number_key, "wrong-number-of-args"); void -scm_wrong_num_args (proc) - SCM proc; +scm_wrong_num_args (SCM proc) { scm_error (scm_args_number_key, NULL, @@ -205,10 +188,7 @@ scm_wrong_num_args (proc) SCM_SYMBOL (scm_arg_type_key, "wrong-type-arg"); void -scm_wrong_type_arg (subr, pos, bad_value) - const char *subr; - int pos; - SCM bad_value; +scm_wrong_type_arg (const char *subr, int pos, SCM bad_value) { scm_error (scm_arg_type_key, subr, @@ -221,8 +201,7 @@ scm_wrong_type_arg (subr, pos, bad_value) SCM_SYMBOL (scm_memory_alloc_key, "memory-allocation-error"); void -scm_memory_error (subr) - const char *subr; +scm_memory_error (const char *subr) { scm_error (scm_memory_alloc_key, subr, @@ -233,20 +212,14 @@ scm_memory_error (subr) SCM_SYMBOL (scm_misc_error_key, "misc-error"); void -scm_misc_error (subr, message, args) - const char *subr; - const char *message; - SCM args; +scm_misc_error (const char *subr, const char *message, SCM args) { scm_error (scm_misc_error_key, subr, message, args, SCM_BOOL_F); } /* implements the SCM_ASSERT interface. */ SCM -scm_wta (arg, pos, s_subr) - SCM arg; - const char *pos; - const char *s_subr; +scm_wta (SCM arg, const char *pos, const char *s_subr) { if (!s_subr || !*s_subr) s_subr = NULL; diff --git a/libguile/eval.c b/libguile/eval.c index 586c884c2..f92a3c8de 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + /* This file is read twice in order to produce debugging versions of @@ -92,6 +96,7 @@ char *alloca (); #include "feature.h" #include "modules.h" +#include "scm_validate.h" #include "eval.h" SCM (*scm_memoize_method) (SCM, SCM); @@ -831,7 +836,7 @@ scm_m_do (xorig, env) #define evalcar scm_eval_car -static SCM iqq SCM_P ((SCM form, SCM env, int depth)); +static SCM iqq (SCM form, SCM env, int depth); SCM_SYNTAX(s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote); SCM_GLOBAL_SYMBOL(scm_sym_quasiquote, s_quasiquote); @@ -848,10 +853,7 @@ scm_m_quasiquote (xorig, env) static SCM -iqq (form, env, depth) - SCM form; - SCM env; - int depth; +iqq (SCM form,SCM env,int depth) { SCM tmp; int edepth = depth; @@ -1350,12 +1352,8 @@ scm_macroexp (SCM x, SCM env) * readable style... :) */ -static SCM unmemocopy SCM_P ((SCM x, SCM env)); - static SCM -unmemocopy (x, env) - SCM x; - SCM env; +unmemocopy (SCM x, SCM env) { SCM ls, z; #ifdef DEBUG_EXTENSIONS @@ -1714,7 +1712,7 @@ scm_eval_body (SCM code, SCM env) */ -SCM (*scm_ceval_ptr) SCM_P ((SCM x, SCM env)); +SCM (*scm_ceval_ptr) (SCM x, SCM env); /* scm_last_debug_frame contains a pointer to the last debugging * information stack frame. It is accessed very often from the @@ -1769,38 +1767,39 @@ scm_option scm_evaluator_trap_table[] = { { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." } }; -SCM_PROC (s_eval_options_interface, "eval-options-interface", 0, 1, 0, scm_eval_options_interface); - -SCM -scm_eval_options_interface (SCM setting) +GUILE_PROC (scm_eval_options_interface, "eval-options-interface", 0, 1, 0, + (SCM setting), +"") +#define FUNC_NAME s_scm_eval_options_interface { SCM ans; SCM_DEFER_INTS; ans = scm_options (setting, scm_eval_opts, SCM_N_EVAL_OPTIONS, - s_eval_options_interface); + FUNC_NAME); scm_eval_stack = SCM_EVAL_STACK * sizeof (void *); SCM_ALLOW_INTS; return ans; } +#undef FUNC_NAME -SCM_PROC (s_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, scm_evaluator_traps); - -SCM -scm_evaluator_traps (setting) - SCM setting; +GUILE_PROC (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, + (SCM setting), +"") +#define FUNC_NAME s_scm_evaluator_traps { SCM ans; SCM_DEFER_INTS; ans = scm_options (setting, scm_evaluator_trap_table, SCM_N_EVALUATOR_TRAPS, - s_evaluator_traps); + FUNC_NAME); SCM_RESET_DEBUG_MODE; SCM_ALLOW_INTS; return ans; } +#undef FUNC_NAME SCM scm_deval_args (l, env, proc, lloc) @@ -1866,24 +1865,18 @@ scm_deval_args (l, env, proc, lloc) #if 0 SCM -scm_ceval (x, env) - SCM x; - SCM env; +scm_ceval (SCM x, SCM env) {} #endif #if 0 SCM -scm_deval (x, env) - SCM x; - SCM env; +scm_deval (SCM x, SCM env) {} #endif SCM -SCM_CEVAL (x, env) - SCM x; - SCM env; +SCM_CEVAL (SCM x, SCM env) { union { @@ -3256,21 +3249,21 @@ ret: you if you do (scm_apply scm_apply '( ... ))" If you know what they're referring to, send me a patch to this comment. */ -SCM_PROC(s_nconc2last, "apply:nconc2last", 1, 0, 0, scm_nconc2last); - -SCM -scm_nconc2last (lst) - SCM lst; +GUILE_PROC(scm_nconc2last, "apply:nconc2last", 1, 0, 0, + (SCM lst), +"") +#define FUNC_NAME s_scm_nconc2last { SCM *lloc; - SCM_ASSERT (scm_ilength (lst) > 0, lst, SCM_ARG1, s_nconc2last); + SCM_VALIDATE_LIST(1,lst); lloc = &lst; while (SCM_NNULLP (SCM_CDR (*lloc))) lloc = SCM_CDRLOC (*lloc); - SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, s_nconc2last); + SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME); *lloc = SCM_CAR (*lloc); return lst; } +#undef FUNC_NAME #endif /* !DEVAL */ @@ -3311,10 +3304,7 @@ scm_dapply (proc, arg1, args) onto the front of your argument list, and pass that as ARGS. */ SCM -SCM_APPLY (proc, arg1, args) - SCM proc; - SCM arg1; - SCM args; +SCM_APPLY (SCM proc, SCM arg1, SCM args) { #ifdef DEBUG_EXTENSIONS #ifdef DEVAL @@ -3662,10 +3652,7 @@ SCM_GPROC (s_map, "map", 2, 0, 1, scm_map, g_map); */ SCM -scm_map (proc, arg1, args) - SCM proc; - SCM arg1; - SCM args; +scm_map (SCM proc, SCM arg1, SCM args) { long i, len; SCM res = SCM_EOL; @@ -3713,10 +3700,7 @@ scm_map (proc, arg1, args) SCM_GPROC (s_for_each, "for-each", 2, 0, 1, scm_for_each, g_for_each); SCM -scm_for_each (proc, arg1, args) - SCM proc; - SCM arg1; - SCM args; +scm_for_each (SCM proc, SCM arg1, SCM args) { SCM *ve = &args; /* Keep args from being optimized away. */ long i, len; @@ -3781,13 +3765,8 @@ scm_makprom (code) -static int prinprom SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - static int -prinprom (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +prinprom (SCM exp,SCM port,scm_print_state *pstate) { int writingp = SCM_WRITINGP (pstate); scm_puts ("# @@ -47,6 +51,7 @@ #include "procprop.h" #include "smob.h" +#include "scm_validate.h" #include "feature.h" #ifdef HAVE_STRING_H @@ -66,13 +71,15 @@ scm_add_feature (str) -SCM_PROC(s_program_arguments, "program-arguments", 0, 0, 0, scm_program_arguments); -SCM -scm_program_arguments () +GUILE_PROC(scm_program_arguments, "program-arguments", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_program_arguments { return scm_progargs; } +#undef FUNC_NAME /* Set the value returned by program-arguments, given ARGC and ARGV. @@ -81,10 +88,7 @@ scm_program_arguments () arguments, but we still want the script name to be the first element. */ void -scm_set_program_arguments (argc, argv, first) - int argc; - char **argv; - char *first; +scm_set_program_arguments (int argc, char **argv, char *first) { scm_progargs = scm_makfromstrs (argc, argv); if (first) @@ -176,61 +180,63 @@ scm_make_named_hook (const char* name, int n_args) } -SCM_PROC (s_make_hook_with_name, "make-hook-with-name", 1, 1, 0, scm_make_hook_with_name); - -SCM -scm_make_hook_with_name (SCM name, SCM n_args) +GUILE_PROC (scm_make_hook_with_name, "make-hook-with-name", 1, 1, 0, + (SCM name, SCM n_args), +"") +#define FUNC_NAME s_scm_make_hook_with_name { - return make_hook (name, n_args, s_make_hook_with_name); + return make_hook (name, n_args, FUNC_NAME); } +#undef FUNC_NAME -SCM_PROC (s_make_hook, "make-hook", 0, 1, 0, scm_make_hook); - -SCM -scm_make_hook (SCM n_args) +GUILE_PROC (scm_make_hook, "make-hook", 0, 1, 0, + (SCM n_args), +"") +#define FUNC_NAME s_scm_make_hook { - return make_hook (SCM_BOOL_F, n_args, s_make_hook); + return make_hook (SCM_BOOL_F, n_args, FUNC_NAME); } +#undef FUNC_NAME -SCM_PROC (s_hook_p, "hook?", 1, 0, 0, scm_hook_p); - -SCM -scm_hook_p (SCM x) +GUILE_PROC (scm_hook_p, "hook?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_hook_p { - return SCM_NIMP (x) && SCM_HOOKP (x) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(SCM_NIMP (x) && SCM_HOOKP (x)); } +#undef FUNC_NAME -SCM_PROC (s_hook_empty_p, "hook-empty?", 1, 0, 0, scm_hook_empty_p); - -SCM -scm_hook_empty_p (SCM hook) +GUILE_PROC (scm_hook_empty_p, "hook-empty?", 1, 0, 0, + (SCM hook), +"") +#define FUNC_NAME s_scm_hook_empty_p { - SCM_ASSERT (SCM_NIMP (hook) && SCM_HOOKP (hook), - hook, SCM_ARG1, s_hook_empty_p); - return SCM_NULLP (SCM_HOOK_PROCEDURES (hook)) ? SCM_BOOL_T : SCM_BOOL_F; + SCM_VALIDATE_HOOK(1,hook); + return SCM_BOOL(SCM_NULLP (SCM_HOOK_PROCEDURES (hook))); } +#undef FUNC_NAME -SCM_PROC (s_add_hook_x, "add-hook!", 2, 1, 0, scm_add_hook_x); - -SCM -scm_add_hook_x (SCM hook, SCM proc, SCM append_p) +GUILE_PROC (scm_add_hook_x, "add-hook!", 2, 1, 0, + (SCM hook, SCM proc, SCM append_p), +"") +#define FUNC_NAME s_scm_add_hook_x { SCM arity, rest; int n_args; - SCM_ASSERT (SCM_NIMP (hook) && SCM_HOOKP (hook), - hook, SCM_ARG1, s_add_hook_x); + SCM_VALIDATE_HOOK(1,hook); SCM_ASSERT (SCM_NFALSEP (arity = scm_i_procedure_arity (proc)), - proc, SCM_ARG2, s_add_hook_x); + proc, SCM_ARG2, FUNC_NAME); n_args = SCM_HOOK_ARITY (hook); if (SCM_INUM (SCM_CAR (arity)) > n_args || (SCM_FALSEP (SCM_CADDR (arity)) && (SCM_INUM (SCM_CAR (arity)) + SCM_INUM (SCM_CADR (arity)) < n_args))) - scm_misc_error (s_add_hook_x, + scm_misc_error (FUNC_NAME, "This hook requires %s arguments", SCM_LIST1 (SCM_MAKINUM (SCM_HOOK_ARITY (hook)))); rest = scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook)); @@ -240,49 +246,50 @@ scm_add_hook_x (SCM hook, SCM proc, SCM append_p) : scm_cons (proc, rest))); return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_remove_hook_x, "remove-hook!", 2, 0, 0, scm_remove_hook_x); - -SCM -scm_remove_hook_x (SCM hook, SCM proc) +GUILE_PROC (scm_remove_hook_x, "remove-hook!", 2, 0, 0, + (SCM hook, SCM proc), +"") +#define FUNC_NAME s_scm_remove_hook_x { - SCM_ASSERT (SCM_NIMP (hook) && SCM_HOOKP (hook), - hook, SCM_ARG1, s_remove_hook_x); + SCM_VALIDATE_HOOK(1,hook); SCM_SET_HOOK_PROCEDURES (hook, scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook))); return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_reset_hook_x, "reset-hook!", 1, 0, 0, scm_reset_hook_x); - -SCM -scm_reset_hook_x (SCM hook) +GUILE_PROC (scm_reset_hook_x, "reset-hook!", 1, 0, 0, + (SCM hook), +"") +#define FUNC_NAME s_scm_reset_hook_x { - SCM_ASSERT (SCM_NIMP (hook) && SCM_HOOKP (hook), - hook, SCM_ARG1, s_reset_hook_x); + SCM_VALIDATE_HOOK(1,hook); SCM_SET_HOOK_PROCEDURES (hook, SCM_EOL); return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_run_hook, "run-hook", 1, 0, 1, scm_run_hook); - -SCM -scm_run_hook (SCM hook, SCM args) +GUILE_PROC (scm_run_hook, "run-hook", 1, 0, 1, + (SCM hook, SCM args), +"") +#define FUNC_NAME s_scm_run_hook { - SCM_ASSERT (SCM_NIMP (hook) && SCM_HOOKP (hook), - hook, SCM_ARG1, s_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 (s_add_hook_x, + scm_misc_error (FUNC_NAME, "This hook requires %s arguments", SCM_LIST1 (SCM_MAKINUM (SCM_HOOK_ARITY (hook)))); scm_c_run_hook (hook, args); return SCM_UNSPECIFIED; } +#undef FUNC_NAME void @@ -297,15 +304,15 @@ scm_c_run_hook (SCM hook, SCM args) } -SCM_PROC (s_hook_to_list, "hook->list", 1, 0, 0, scm_hook_to_list); - -SCM -scm_hook_to_list (SCM hook) +GUILE_PROC (scm_hook_to_list, "hook->list", 1, 0, 0, + (SCM hook), + "") +#define FUNC_NAME s_scm_hook_to_list { - SCM_ASSERT (SCM_NIMP (hook) && SCM_HOOKP (hook), - hook, SCM_ARG1, s_hook_to_list); + SCM_VALIDATE_HOOK(1,hook); return scm_list_copy (SCM_HOOK_PROCEDURES (hook)); } +#undef FUNC_NAME diff --git a/libguile/filesys.c b/libguile/filesys.c index 1d857dbed..258d8f7a1 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include #include "_scm.h" @@ -47,6 +51,7 @@ #include "fports.h" #include "iselect.h" +#include "scm_validate.h" #include "filesys.h" @@ -117,21 +122,18 @@ /* {Permissions} */ -SCM_PROC (s_chown, "chown", 3, 0, 0, scm_chown); - -SCM -scm_chown (object, owner, group) - SCM object; - SCM owner; - SCM group; +GUILE_PROC (scm_chown, "chown", 3, 0, 0, + (SCM object, SCM owner, SCM group), +"") +#define FUNC_NAME s_scm_chown { int rv; int fdes; object = SCM_COERCE_OUTPORT (object); - SCM_ASSERT (SCM_INUMP (owner), owner, SCM_ARG2, s_chown); - SCM_ASSERT (SCM_INUMP (group), group, SCM_ARG3, s_chown); + SCM_VALIDATE_INT(2,owner); + SCM_VALIDATE_INT(3,group); if (SCM_INUMP (object) || (SCM_NIMP (object) && SCM_OPFPORTP (object))) { if (SCM_INUMP (object)) @@ -143,30 +145,29 @@ scm_chown (object, owner, group) else { SCM_ASSERT (SCM_NIMP (object) && SCM_ROSTRINGP (object), - object, SCM_ARG1, s_chown); + object, SCM_ARG1, FUNC_NAME); SCM_COERCE_SUBSTR (object); SCM_SYSCALL (rv = chown (SCM_ROCHARS (object), SCM_INUM (owner), SCM_INUM (group))); } if (rv == -1) - scm_syserror (s_chown); + SCM_SYSERROR; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_chmod, "chmod", 2, 0, 0, scm_chmod); - -SCM -scm_chmod (object, mode) - SCM object; - SCM mode; +GUILE_PROC (scm_chmod, "chmod", 2, 0, 0, + (SCM object, SCM mode), +"") +#define FUNC_NAME s_scm_chmod { int rv; int fdes; object = SCM_COERCE_OUTPORT (object); - SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_chmod); + SCM_VALIDATE_INT(2,mode); if (SCM_INUMP (object) || (SCM_NIMP (object) && SCM_OPFPORTP (object))) { if (SCM_INUMP (object)) @@ -177,21 +178,20 @@ scm_chmod (object, mode) } else { - SCM_ASSERT (SCM_NIMP (object) && SCM_ROSTRINGP (object), - object, SCM_ARG1, s_chmod); + SCM_VALIDATE_ROSTRING(1,object); SCM_COERCE_SUBSTR (object); SCM_SYSCALL (rv = chmod (SCM_ROCHARS (object), SCM_INUM (mode))); } if (rv == -1) - scm_syserror (s_chmod); + SCM_SYSERROR; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_umask, "umask", 0, 1, 0, scm_umask); - -SCM -scm_umask (mode) - SCM mode; +GUILE_PROC (scm_umask, "umask", 0, 1, 0, + (SCM mode), +"") +#define FUNC_NAME s_scm_umask { mode_t mask; if (SCM_UNBNDP (mode)) @@ -201,43 +201,39 @@ scm_umask (mode) } else { - SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG1, s_umask); + SCM_VALIDATE_INT(1,mode); mask = umask (SCM_INUM (mode)); } return SCM_MAKINUM (mask); } +#undef FUNC_NAME -SCM_PROC (s_open_fdes, "open-fdes", 2, 1, 0, scm_open_fdes); -SCM -scm_open_fdes (SCM path, SCM flags, SCM mode) +GUILE_PROC (scm_open_fdes, "open-fdes", 2, 1, 0, + (SCM path, SCM flags, SCM mode), +"") +#define FUNC_NAME s_scm_open_fdes { int fd; int iflags; int imode; - SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, - s_open_fdes); + SCM_VALIDATE_ROSTRING(1,path); SCM_COERCE_SUBSTR (path); - iflags = scm_num2long (flags, (char *) SCM_ARG2, s_open_fdes); - - if (SCM_UNBNDP (mode)) - imode = 0666; - else - { - SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG3, s_open_fdes); - imode = SCM_INUM (mode); - } + SCM_VALIDATE_INT_COPY(2,flags,iflags); + SCM_VALIDATE_INT_DEF_COPY(3,mode,0666,imode); SCM_SYSCALL (fd = open (SCM_ROCHARS (path), iflags, imode)); if (fd == -1) - scm_syserror (s_open_fdes); + SCM_SYSERROR; return SCM_MAKINUM (fd); } +#undef FUNC_NAME -SCM_PROC (s_open, "open", 2, 1, 0, scm_open); -SCM -scm_open (SCM path, SCM flags, SCM mode) +GUILE_PROC (scm_open, "open", 2, 1, 0, + (SCM path, SCM flags, SCM mode), +"") +#define FUNC_NAME s_scm_open { SCM newpt; char *port_mode; @@ -245,7 +241,7 @@ scm_open (SCM path, SCM flags, SCM mode) int iflags; fd = SCM_INUM (scm_open_fdes (path, flags, mode)); - iflags = scm_num2long (flags, (char *) SCM_ARG2, s_open_fdes); + SCM_VALIDATE_INT_COPY(2,flags,iflags); if (iflags & O_RDWR) { if (iflags & O_APPEND) @@ -266,10 +262,12 @@ scm_open (SCM path, SCM flags, SCM mode) newpt = scm_fdes_to_port (fd, port_mode, path); return newpt; } +#undef FUNC_NAME -SCM_PROC (s_close, "close", 1, 0, 0, scm_close); -SCM -scm_close (SCM fd_or_port) +GUILE_PROC (scm_close, "close", 1, 0, 0, + (SCM fd_or_port), +"") +#define FUNC_NAME s_scm_close { int rv; int fd; @@ -278,16 +276,17 @@ scm_close (SCM fd_or_port) if (SCM_NIMP (fd_or_port) && SCM_PORTP (fd_or_port)) return scm_close_port (fd_or_port); - SCM_ASSERT (SCM_INUMP (fd_or_port), fd_or_port, SCM_ARG1, s_close); + SCM_VALIDATE_INT(1,fd_or_port); fd = SCM_INUM (fd_or_port); scm_evict_ports (fd); /* see scsh manual. */ SCM_SYSCALL (rv = close (fd)); /* following scsh, closing an already closed file descriptor is not an error. */ if (rv < 0 && errno != EBADF) - scm_syserror (s_close); - return (rv < 0) ? SCM_BOOL_F : SCM_BOOL_T; + SCM_SYSERROR; + return SCM_NEGATE_BOOL(rv < 0); } +#undef FUNC_NAME /* {Files} @@ -304,11 +303,8 @@ SCM_SYMBOL (scm_sym_fifo, "fifo"); SCM_SYMBOL (scm_sym_sock, "socket"); SCM_SYMBOL (scm_sym_unknown, "unknown"); -static SCM scm_stat2scm SCM_P ((struct stat *stat_temp)); - static SCM -scm_stat2scm (stat_temp) - struct stat *stat_temp; +scm_stat2scm (struct stat *stat_temp) { SCM ans = scm_make_vector (SCM_MAKINUM (15), SCM_UNSPECIFIED); SCM *ve = SCM_VELTS (ans); @@ -397,11 +393,10 @@ scm_stat2scm (stat_temp) return ans; } -SCM_PROC (s_stat, "stat", 1, 0, 0, scm_stat); - -SCM -scm_stat (object) - SCM object; +GUILE_PROC (scm_stat, "stat", 1, 0, 0, + (SCM object), +"") +#define FUNC_NAME s_scm_stat { int rv; int fdes; @@ -411,7 +406,7 @@ scm_stat (object) SCM_SYSCALL (rv = fstat (SCM_INUM (object), &stat_temp)); else { - SCM_ASSERT (SCM_NIMP (object), object, SCM_ARG1, s_stat); + SCM_VALIDATE_NIMP(1,object); if (SCM_ROSTRINGP (object)) { SCM_COERCE_SUBSTR (object); @@ -420,7 +415,7 @@ scm_stat (object) else { object = SCM_COERCE_OUTPORT (object); - SCM_ASSERT (SCM_OPFPORTP (object), object, SCM_ARG1, s_stat); + SCM_ASSERT (SCM_OPFPORTP (object), object, SCM_ARG1, FUNC_NAME); fdes = SCM_FPORT_FDES (object); SCM_SYSCALL (rv = fstat (fdes, &stat_temp)); } @@ -429,7 +424,7 @@ scm_stat (object) { int en = errno; - scm_syserror_msg (s_stat, "%s: %S", + scm_syserror_msg (FUNC_NAME, "%s: %S", scm_listify (scm_makfrom0str (strerror (errno)), object, SCM_UNDEFINED), @@ -437,50 +432,44 @@ scm_stat (object) } return scm_stat2scm (&stat_temp); } +#undef FUNC_NAME /* {Modifying Directories} */ -SCM_PROC (s_link, "link", 2, 0, 0, scm_link); - -SCM -scm_link (oldpath, newpath) - SCM oldpath; - SCM newpath; +GUILE_PROC (scm_link, "link", 2, 0, 0, + (SCM oldpath, SCM newpath), +"") +#define FUNC_NAME s_scm_link { int val; - SCM_ASSERT (SCM_NIMP (oldpath) && SCM_ROSTRINGP (oldpath), oldpath, - SCM_ARG1, s_link); + SCM_VALIDATE_ROSTRING(1,oldpath); if (SCM_SUBSTRP (oldpath)) oldpath = scm_makfromstr (SCM_ROCHARS (oldpath), SCM_ROLENGTH (oldpath), 0); - SCM_ASSERT (SCM_NIMP (newpath) && SCM_ROSTRINGP (newpath), newpath, - SCM_ARG2, s_link); + SCM_VALIDATE_ROSTRING(2,newpath); if (SCM_SUBSTRP (newpath)) newpath = scm_makfromstr (SCM_ROCHARS (newpath), SCM_ROLENGTH (newpath), 0); SCM_SYSCALL (val = link (SCM_ROCHARS (oldpath), SCM_ROCHARS (newpath))); if (val != 0) - scm_syserror (s_link); + SCM_SYSERROR; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_rename, "rename-file", 2, 0, 0, scm_rename); - -SCM -scm_rename (oldname, newname) - SCM oldname; - SCM newname; +GUILE_PROC (scm_rename, "rename-file", 2, 0, 0, + (SCM oldname, SCM newname), +"") +#define FUNC_NAME s_scm_rename { int rv; - SCM_ASSERT (SCM_NIMP (oldname) && SCM_ROSTRINGP (oldname), oldname, SCM_ARG1, - s_rename); - SCM_ASSERT (SCM_NIMP (newname) && SCM_ROSTRINGP (newname), newname, SCM_ARG2, - s_rename); + SCM_VALIDATE_ROSTRING(1,oldname); + SCM_VALIDATE_ROSTRING(2,newname); SCM_COERCE_SUBSTR (oldname); SCM_COERCE_SUBSTR (newname); #ifdef HAVE_RENAME @@ -496,39 +485,36 @@ scm_rename (oldname, newname) } #endif if (rv != 0) - scm_syserror (s_rename); + SCM_SYSERROR; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_delete_file, "delete-file", 1, 0, 0, scm_delete_file); - -SCM -scm_delete_file (str) - SCM str; +GUILE_PROC(scm_delete_file, "delete-file", 1, 0, 0, + (SCM str), +"") +#define FUNC_NAME s_scm_delete_file { int ans; - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, - s_delete_file); + SCM_VALIDATE_ROSTRING(1,str); SCM_COERCE_SUBSTR (str); SCM_SYSCALL (ans = unlink (SCM_ROCHARS (str))); if (ans != 0) - scm_syserror (s_delete_file); + SCM_SYSERROR; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_mkdir, "mkdir", 1, 1, 0, scm_mkdir); - -SCM -scm_mkdir (path, mode) - SCM path; - SCM mode; +GUILE_PROC (scm_mkdir, "mkdir", 1, 1, 0, + (SCM path, SCM mode), +"") +#define FUNC_NAME s_scm_mkdir { #ifdef HAVE_MKDIR int rv; mode_t mask; - SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, - s_mkdir); + SCM_VALIDATE_ROSTRING(1,path); SCM_COERCE_SUBSTR (path); if (SCM_UNBNDP (mode)) { @@ -538,42 +524,42 @@ scm_mkdir (path, mode) } else { - SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_mkdir); + SCM_VALIDATE_INT(2,mode); SCM_SYSCALL (rv = mkdir (SCM_ROCHARS (path), SCM_INUM (mode))); } if (rv != 0) - scm_syserror (s_mkdir); + SCM_SYSERROR; return SCM_UNSPECIFIED; #else - scm_sysmissing (s_mkdir); + SCM_SYSMISSING; /* not reached. */ return SCM_BOOL_F; #endif } +#undef FUNC_NAME -SCM_PROC (s_rmdir, "rmdir", 1, 0, 0, scm_rmdir); - -SCM -scm_rmdir (path) - SCM path; +GUILE_PROC (scm_rmdir, "rmdir", 1, 0, 0, + (SCM path), +"") +#define FUNC_NAME s_scm_rmdir { #ifdef HAVE_RMDIR int val; - SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, - s_rmdir); + SCM_VALIDATE_ROSTRING(1,path); SCM_COERCE_SUBSTR (path); SCM_SYSCALL (val = rmdir (SCM_ROCHARS (path))); if (val != 0) - scm_syserror (s_rmdir); + SCM_SYSERROR; return SCM_UNSPECIFIED; #else - scm_sysmissing (s_rmdir); + SCM_SYSMISSING; /* not reached. */ return SCM_BOOL_F; #endif } +#undef FUNC_NAME /* {Examining Directories} @@ -581,86 +567,85 @@ scm_rmdir (path) long scm_tc16_dir; -SCM_PROC (s_directory_stream_p, "directory-stream?", 1, 0, 0, scm_directory_stream_p); -SCM -scm_directory_stream_p (SCM obj) +GUILE_PROC (scm_directory_stream_p, "directory-stream?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_directory_stream_p { - return SCM_NIMP (obj) && SCM_DIRP (obj) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(SCM_NIMP (obj) && SCM_DIRP (obj)); } +#undef FUNC_NAME -SCM_PROC (s_opendir, "opendir", 1, 0, 0, scm_opendir); - -SCM -scm_opendir (dirname) - SCM dirname; +GUILE_PROC (scm_opendir, "opendir", 1, 0, 0, + (SCM dirname), +"") +#define FUNC_NAME s_scm_opendir { DIR *ds; - SCM_ASSERT (SCM_NIMP (dirname) && SCM_ROSTRINGP (dirname), dirname, SCM_ARG1, - s_opendir); + SCM_VALIDATE_ROSTRING(1,dirname); SCM_COERCE_SUBSTR (dirname); SCM_SYSCALL (ds = opendir (SCM_ROCHARS (dirname))); if (ds == NULL) - scm_syserror (s_opendir); + SCM_SYSERROR; SCM_RETURN_NEWSMOB (scm_tc16_dir | SCM_OPN, ds); } +#undef FUNC_NAME -SCM_PROC (s_readdir, "readdir", 1, 0, 0, scm_readdir); - -SCM -scm_readdir (port) - SCM port; +GUILE_PROC (scm_readdir, "readdir", 1, 0, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_readdir { struct dirent *rdent; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPDIRP (port), port, SCM_ARG1, s_readdir); + SCM_VALIDATE_OPDIR(1,port); errno = 0; SCM_SYSCALL (rdent = readdir ((DIR *) SCM_CDR (port))); if (errno != 0) - scm_syserror (s_readdir); + SCM_SYSERROR; return (rdent ? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0) : SCM_EOF_VAL); } +#undef FUNC_NAME -SCM_PROC (s_rewinddir, "rewinddir", 1, 0, 0, scm_rewinddir); - -SCM -scm_rewinddir (port) - SCM port; +GUILE_PROC (scm_rewinddir, "rewinddir", 1, 0, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_rewinddir { - SCM_ASSERT (SCM_NIMP (port) && SCM_OPDIRP (port), port, SCM_ARG1, s_rewinddir); + SCM_VALIDATE_OPDIR(1,port); rewinddir ((DIR *) SCM_CDR (port)); return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_closedir, "closedir", 1, 0, 0, scm_closedir); - -SCM -scm_closedir (port) - SCM port; +GUILE_PROC (scm_closedir, "closedir", 1, 0, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_closedir { int sts; - SCM_ASSERT (SCM_NIMP (port) && SCM_DIRP (port), port, SCM_ARG1, s_closedir); + SCM_VALIDATE_DIR(1,port); if (SCM_CLOSEDP (port)) { return SCM_UNSPECIFIED; } SCM_SYSCALL (sts = closedir ((DIR *) SCM_CDR (port))); if (sts != 0) - scm_syserror (s_closedir); + SCM_SYSERROR; SCM_SETCAR (port, scm_tc16_dir); return SCM_UNSPECIFIED; } +#undef FUNC_NAME -static int scm_dir_print SCM_P ((SCM sexp, SCM port, scm_print_state *pstate)); - static int scm_dir_print (SCM exp, SCM port, scm_print_state *pstate) { @@ -674,11 +659,8 @@ scm_dir_print (SCM exp, SCM port, scm_print_state *pstate) } -static scm_sizet scm_dir_free SCM_P ((SCM p)); - static scm_sizet -scm_dir_free (p) - SCM p; +scm_dir_free (SCM p) { if (SCM_OPENP (p)) closedir ((DIR *) SCM_CDR (p)); @@ -690,28 +672,28 @@ scm_dir_free (p) */ -SCM_PROC (s_chdir, "chdir", 1, 0, 0, scm_chdir); - -SCM -scm_chdir (str) - SCM str; +GUILE_PROC (scm_chdir, "chdir", 1, 0, 0, + (SCM str), +"") +#define FUNC_NAME s_scm_chdir { int ans; - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_chdir); + SCM_VALIDATE_ROSTRING(1,str); SCM_COERCE_SUBSTR (str); SCM_SYSCALL (ans = chdir (SCM_ROCHARS (str))); if (ans != 0) - scm_syserror (s_chdir); + SCM_SYSERROR; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_getcwd, "getcwd", 0, 0, 0, scm_getcwd); - -SCM -scm_getcwd () +GUILE_PROC (scm_getcwd, "getcwd", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_getcwd { #ifdef HAVE_GETCWD char *rv; @@ -720,30 +702,28 @@ scm_getcwd () char *wd; SCM result; - wd = scm_must_malloc (size, s_getcwd); + wd = scm_must_malloc (size, FUNC_NAME); while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE) { scm_must_free (wd); size *= 2; - wd = scm_must_malloc (size, s_getcwd); + wd = scm_must_malloc (size, FUNC_NAME); } if (rv == 0) - scm_syserror (s_getcwd); + SCM_SYSERROR; result = scm_makfromstr (wd, strlen (wd), 0); scm_must_free (wd); return result; #else - scm_sysmissing (s_getcwd); + SCM_SYSMISSING; /* not reached. */ return SCM_BOOL_F; #endif } +#undef FUNC_NAME -SCM_PROC (s_select, "select", 3, 2, 0, scm_select); - - static int set_element (SELECT_TYPE *set, SCM element, int arg) { @@ -752,7 +732,7 @@ set_element (SELECT_TYPE *set, SCM element, int arg) if (SCM_NIMP (element) && SCM_OPFPORTP (element)) fd = SCM_FPORT_FDES (element); else { - SCM_ASSERT (SCM_INUMP (element), element, arg, s_select); + SCM_ASSERT (SCM_INUMP (element), element, arg, "select"); fd = SCM_INUM (element); } FD_SET (fd, set); @@ -836,14 +816,11 @@ retrieve_select_type (SELECT_TYPE *set, SCM list) } } - -SCM -scm_select (reads, writes, excepts, secs, usecs) - SCM reads; - SCM writes; - SCM excepts; - SCM secs; - SCM usecs; +/* Static helper functions above refer to s_scm_select directly as s_select */ +GUILE_PROC (scm_select, "select", 3, 2, 0, + (SCM reads, SCM writes, SCM excepts, SCM secs, SCM usecs), +"") +#define FUNC_NAME s_scm_select { #ifdef HAVE_SELECT struct timeval timeout; @@ -855,8 +832,8 @@ scm_select (reads, writes, excepts, secs, usecs) int sreturn; #define assert_set(x, arg) \ - SCM_ASSERT (scm_ilength (x) > -1 || (SCM_NIMP (x) && SCM_VECTORP (x)), \ - x, arg, s_select) + SCM_ASSERT (scm_ilength (x) >= 0 || (SCM_NIMP (x) && SCM_VECTORP (x)), \ + x, arg, FUNC_NAME) assert_set (reads, SCM_ARG1); assert_set (writes, SCM_ARG2); assert_set (excepts, SCM_ARG3); @@ -885,19 +862,18 @@ scm_select (reads, writes, excepts, secs, usecs) timeout.tv_usec = 0; else { - SCM_ASSERT (SCM_INUMP (usecs), usecs, SCM_ARG5, s_select); - + SCM_VALIDATE_INT(5,usecs); timeout.tv_usec = SCM_INUM (usecs); } } else { - double fl = scm_num2dbl (secs, s_select); + double fl = scm_num2dbl (secs, FUNC_NAME); if (!SCM_UNBNDP (usecs)) - scm_wrong_type_arg (s_select, 4, secs); + scm_wrong_type_arg (FUNC_NAME, 4, secs); if (fl > LONG_MAX) - scm_out_of_range (s_select, secs); + scm_out_of_range (FUNC_NAME, secs); timeout.tv_sec = (long) fl; timeout.tv_usec = (long) ((fl - timeout.tv_sec) * 1000000); } @@ -912,23 +888,25 @@ scm_select (reads, writes, excepts, secs, usecs) &read_set, &write_set, &except_set, time_p); #endif if (sreturn < 0) - scm_syserror (s_select); + SCM_SYSERROR; return scm_listify (retrieve_select_type (&read_set, reads), retrieve_select_type (&write_set, writes), retrieve_select_type (&except_set, excepts), SCM_UNDEFINED); #else - scm_sysmissing (s_select); + SCM_SYSMISSING; /* not reached. */ return SCM_BOOL_F; #endif } +#undef FUNC_NAME -SCM_PROC (s_fcntl, "fcntl", 2, 0, 1, scm_fcntl); -SCM -scm_fcntl (SCM object, SCM cmd, SCM value) +GUILE_PROC (scm_fcntl, "fcntl", 2, 0, 1, + (SCM object, SCM cmd, SCM value), +"") +#define FUNC_NAME s_scm_fcntl { int rv; int fdes; @@ -936,30 +914,32 @@ scm_fcntl (SCM object, SCM cmd, SCM value) object = SCM_COERCE_OUTPORT (object); - SCM_ASSERT (SCM_INUMP (cmd), cmd, SCM_ARG2, s_fcntl); + SCM_VALIDATE_INT(2,cmd); if (SCM_NIMP (object) && SCM_OPFPORTP (object)) fdes = SCM_FPORT_FDES (object); else { - SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_fcntl); + SCM_VALIDATE_INT(1,object); fdes = SCM_INUM (object); } if (SCM_NULLP (value)) ivalue = 0; else { - SCM_ASSERT (SCM_INUMP (SCM_CAR (value)), value, SCM_ARG3, s_fcntl); + SCM_ASSERT (SCM_INUMP (SCM_CAR (value)), value, SCM_ARG3, FUNC_NAME); ivalue = SCM_INUM (SCM_CAR (value)); } SCM_SYSCALL (rv = fcntl (fdes, SCM_INUM (cmd), ivalue)); if (rv == -1) - scm_syserror (s_fcntl); + SCM_SYSERROR; return SCM_MAKINUM (rv); } +#undef FUNC_NAME -SCM_PROC (s_fsync, "fsync", 1, 0, 0, scm_fsync); -SCM -scm_fsync (SCM object) +GUILE_PROC (scm_fsync, "fsync", 1, 0, 0, + (SCM object), +"") +#define FUNC_NAME s_scm_fsync { int fdes; @@ -972,95 +952,90 @@ scm_fsync (SCM object) } else { - SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_fsync); + SCM_VALIDATE_INT(1,object); fdes = SCM_INUM (object); } if (fsync (fdes) == -1) - scm_syserror (s_fsync); + SCM_SYSERROR; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_symlink, "symlink", 2, 0, 0, scm_symlink); - -SCM -scm_symlink(oldpath, newpath) - SCM oldpath; - SCM newpath; +GUILE_PROC (scm_symlink, "symlink", 2, 0, 0, + (SCM oldpath, SCM newpath), +"") +#define FUNC_NAME s_scm_symlink { #ifdef HAVE_SYMLINK int val; - SCM_ASSERT (SCM_NIMP (oldpath) && SCM_ROSTRINGP (oldpath), oldpath, SCM_ARG1, - s_symlink); - SCM_ASSERT (SCM_NIMP (newpath) && SCM_ROSTRINGP (newpath), newpath, SCM_ARG2, - s_symlink); + SCM_VALIDATE_ROSTRING(1,oldpath); + SCM_VALIDATE_ROSTRING(2,newpath); SCM_COERCE_SUBSTR (oldpath); SCM_COERCE_SUBSTR (newpath); SCM_SYSCALL (val = symlink(SCM_ROCHARS(oldpath), SCM_ROCHARS(newpath))); if (val != 0) - scm_syserror (s_symlink); + SCM_SYSERROR; return SCM_UNSPECIFIED; #else - scm_sysmissing (s_symlink); + SCM_SYSMISSING; /* not reached. */ return SCM_BOOL_F; #endif } +#undef FUNC_NAME -SCM_PROC (s_readlink, "readlink", 1, 0, 0, scm_readlink); - -SCM -scm_readlink(path) - SCM path; +GUILE_PROC (scm_readlink, "readlink", 1, 0, 0, + (SCM path), +"") +#define FUNC_NAME s_scm_readlink { #ifdef HAVE_READLINK int rv; int size = 100; char *buf; SCM result; - SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, (char *) SCM_ARG1, - s_readlink); + SCM_VALIDATE_ROSTRING(1,path); SCM_COERCE_SUBSTR (path); - buf = scm_must_malloc (size, s_readlink); + buf = scm_must_malloc (size, FUNC_NAME); while ((rv = readlink (SCM_ROCHARS (path), buf, size)) == size) { scm_must_free (buf); size *= 2; - buf = scm_must_malloc (size, s_readlink); + buf = scm_must_malloc (size, FUNC_NAME); } if (rv == -1) - scm_syserror (s_readlink); + SCM_SYSERROR; result = scm_makfromstr (buf, rv, 0); scm_must_free (buf); return result; #else - scm_sysmissing (s_readlink); + SCM_SYSMISSING; /* not reached. */ return SCM_BOOL_F; #endif } +#undef FUNC_NAME -SCM_PROC (s_lstat, "lstat", 1, 0, 0, scm_lstat); - -SCM -scm_lstat(str) - SCM str; +GUILE_PROC (scm_lstat, "lstat", 1, 0, 0, + (SCM str), +"") +#define FUNC_NAME s_scm_lstat { #ifdef HAVE_LSTAT int rv; struct stat stat_temp; - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, (char *) SCM_ARG1, - s_lstat); + SCM_VALIDATE_ROSTRING(1,str); SCM_COERCE_SUBSTR (str); SCM_SYSCALL(rv = lstat(SCM_ROCHARS(str), &stat_temp)); if (rv != 0) { int en = errno; - scm_syserror_msg (s_lstat, "%s: %S", + scm_syserror_msg (FUNC_NAME, "%s: %S", scm_listify (scm_makfrom0str (strerror (errno)), str, SCM_UNDEFINED), @@ -1068,72 +1043,69 @@ scm_lstat(str) } return scm_stat2scm(&stat_temp); #else - scm_sysmissing (s_lstat); + SCM_SYSMISSING; /* not reached. */ return SCM_BOOL_F; #endif } +#undef FUNC_NAME -SCM_PROC (s_copy_file, "copy-file", 2, 0, 0, scm_copy_file); - -SCM -scm_copy_file (oldfile, newfile) - SCM oldfile; - SCM newfile; +GUILE_PROC (scm_copy_file, "copy-file", 2, 0, 0, + (SCM oldfile, SCM newfile), +"") +#define FUNC_NAME s_scm_copy_file { int oldfd, newfd; int n; char buf[BUFSIZ]; struct stat oldstat; - SCM_ASSERT (SCM_NIMP (oldfile) && SCM_ROSTRINGP (oldfile), oldfile, SCM_ARG1, s_copy_file); + SCM_VALIDATE_ROSTRING(1,oldfile); if (SCM_SUBSTRP (oldfile)) oldfile = scm_makfromstr (SCM_ROCHARS (oldfile), SCM_ROLENGTH (oldfile), 0); - SCM_ASSERT (SCM_NIMP (newfile) && SCM_ROSTRINGP (newfile), newfile, SCM_ARG2, s_copy_file); + SCM_VALIDATE_ROSTRING(2,newfile); if (SCM_SUBSTRP (newfile)) newfile = scm_makfromstr (SCM_ROCHARS (newfile), SCM_ROLENGTH (newfile), 0); if (stat (SCM_ROCHARS (oldfile), &oldstat) == -1) - scm_syserror (s_copy_file); + SCM_SYSERROR; oldfd = open (SCM_ROCHARS (oldfile), O_RDONLY); if (oldfd == -1) - scm_syserror (s_copy_file); + SCM_SYSERROR; /* use POSIX flags instead of 07777?. */ newfd = open (SCM_ROCHARS (newfile), O_WRONLY | O_CREAT | O_TRUNC, oldstat.st_mode & 07777); if (newfd == -1) - scm_syserror (s_copy_file); + SCM_SYSERROR; while ((n = read (oldfd, buf, sizeof buf)) > 0) if (write (newfd, buf, n) != n) { close (oldfd); close (newfd); - scm_syserror (s_copy_file); + SCM_SYSERROR; } close (oldfd); if (close (newfd) == -1) - scm_syserror (s_copy_file); + SCM_SYSERROR; return SCM_UNSPECIFIED; } +#undef FUNC_NAME /* Filename manipulation */ SCM scm_dot_string; -SCM_PROC (s_dirname, "dirname", 1, 0, 0, scm_dirname); - -SCM -scm_dirname (SCM filename) +GUILE_PROC (scm_dirname, "dirname", 1, 0, 0, + (SCM filename), +"") +#define FUNC_NAME s_scm_dirname { char *s; int i, len; - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), - filename, - SCM_ARG1, - s_dirname); + SCM_VALIDATE_ROSTRING(1,filename); s = SCM_ROCHARS (filename); len = SCM_LENGTH (filename); i = len - 1; @@ -1150,23 +1122,21 @@ scm_dirname (SCM filename) else return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (i + 1)); } +#undef FUNC_NAME -SCM_PROC (s_basename, "basename", 1, 1, 0, scm_basename); - -SCM -scm_basename (SCM filename, SCM suffix) +GUILE_PROC (scm_basename, "basename", 1, 1, 0, + (SCM filename, SCM suffix), +"") +#define FUNC_NAME s_scm_basename { char *f, *s = 0; int i, j, len, end; - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), - filename, - SCM_ARG1, - s_basename); + SCM_VALIDATE_ROSTRING(1,filename); SCM_ASSERT (SCM_UNBNDP (suffix) || (SCM_NIMP (suffix) && SCM_ROSTRINGP (suffix)), suffix, SCM_ARG2, - s_basename); + FUNC_NAME); f = SCM_ROCHARS (filename); if (SCM_UNBNDP (suffix)) j = -1; @@ -1195,6 +1165,7 @@ scm_basename (SCM filename, SCM suffix) SCM_MAKINUM (i + 1), SCM_MAKINUM (end + 1)); } +#undef FUNC_NAME diff --git a/libguile/fluids.c b/libguile/fluids.c index ee7651d5f..edcaa199c 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -39,6 +39,10 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + + #include "_scm.h" #include "print.h" #include "smob.h" @@ -49,6 +53,7 @@ #include "eval.h" #define INITIAL_FLUIDS 10 +#include "scm_validate.h" static volatile int n_fluids; long scm_tc16_fluid; @@ -60,11 +65,8 @@ scm_make_initial_fluids () SCM_BOOL_F); } -static void grow_fluids SCM_P ((scm_root_state *, int new_length)); static void -grow_fluids (root_state, new_length) - scm_root_state *root_state; - int new_length; +grow_fluids (scm_root_state *root_state,int new_length) { SCM old_fluids, new_fluids; int old_length, i; @@ -94,12 +96,8 @@ scm_copy_fluids (root_state) grow_fluids (root_state, SCM_LENGTH(root_state->fluids)); } -static int print_fluid SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); static int -print_fluid (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +print_fluid (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#fluids)[n]; } +#undef FUNC_NAME -SCM_PROC (s_fluid_set_x, "fluid-set!", 2, 0, 0, scm_fluid_set_x); - -SCM -scm_fluid_set_x (fl, val) - SCM fl; - SCM val; +GUILE_PROC (scm_fluid_set_x, "fluid-set!", 2, 0, 0, + (SCM fl, SCM val), +"") +#define FUNC_NAME s_scm_fluid_set_x { int n; - SCM_ASSERT (SCM_NIMP (fl) && SCM_FLUIDP (fl), fl, SCM_ARG1, s_fluid_set_x); - + SCM_VALIDATE_FLUID(1,fl); n = SCM_FLUID_NUM (fl); if (SCM_LENGTH (scm_root->fluids) <= n) @@ -177,10 +173,10 @@ scm_fluid_set_x (fl, val) SCM_VELTS(scm_root->fluids)[n] = val; return val; } +#undef FUNC_NAME void -scm_swap_fluids (fluids, vals) - SCM fluids, vals; +scm_swap_fluids (SCM fluids, SCM vals) { while (SCM_NIMP (fluids)) { @@ -197,8 +193,7 @@ scm_swap_fluids (fluids, vals) same fluid appears multiple times in the fluids list. */ void -scm_swap_fluids_reverse (fluids, vals) - SCM fluids, vals; +scm_swap_fluids_reverse (SCM fluids, SCM vals) { if (SCM_NIMP (fluids)) { @@ -212,22 +207,33 @@ scm_swap_fluids_reverse (fluids, vals) } } -SCM_PROC (s_with_fluids, "with-fluids*", 3, 0, 0, scm_with_fluids); + +static SCM +apply_thunk (void *thunk) +{ + return scm_apply ((SCM) thunk, SCM_EOL, SCM_EOL); +} + +GUILE_PROC (scm_with_fluids, "with-fluids*", 3, 0, 0, + (SCM fluids, SCM vals, SCM thunk), +"") +#define FUNC_NAME s_scm_with_fluids +{ + return scm_internal_with_fluids (fluids, vals, apply_thunk, (void *)thunk); +} +#undef FUNC_NAME SCM -scm_internal_with_fluids (fluids, vals, cproc, cdata) - SCM fluids, vals; - SCM (*cproc) (); - void *cdata; +scm_internal_with_fluids (SCM fluids, SCM vals, SCM (*cproc) (), void *cdata) { SCM ans; int flen = scm_ilength (fluids); int vlen = scm_ilength (vals); - SCM_ASSERT (flen >= 0, fluids, SCM_ARG1, s_with_fluids); - SCM_ASSERT (vlen >= 0, vals, SCM_ARG2, s_with_fluids); + SCM_ASSERT (flen >= 0, fluids, SCM_ARG1, s_scm_with_fluids); + SCM_ASSERT (vlen >= 0, vals, SCM_ARG2, s_scm_with_fluids); if (flen != vlen) - scm_out_of_range (s_with_fluids, vals); + scm_out_of_range (s_scm_with_fluids, vals); scm_swap_fluids (fluids, vals); scm_dynwinds = scm_acons (fluids, vals, scm_dynwinds); @@ -237,18 +243,7 @@ scm_internal_with_fluids (fluids, vals, cproc, cdata) return ans; } -static SCM -apply_thunk (void *thunk) -{ - return scm_apply ((SCM) thunk, SCM_EOL, SCM_EOL); -} -SCM -scm_with_fluids (fluids, vals, thunk) - SCM fluids, vals, thunk; -{ - return scm_internal_with_fluids (fluids, vals, apply_thunk, (void *)thunk); -} void scm_init_fluids () diff --git a/libguile/fports.c b/libguile/fports.c index 4a22639d7..494dd1d58 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -38,12 +38,17 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include #include #include "_scm.h" +#include "scm_validate.h" #include "fports.h" #ifdef HAVE_STRING_H @@ -124,21 +129,20 @@ scm_fport_buffer_add (SCM port, int read_size, int write_size) SCM_SETCAR (port, (SCM_CAR (port) | SCM_BUF0)); } -SCM_PROC (s_setvbuf, "setvbuf", 2, 1, 0, scm_setvbuf); -SCM -scm_setvbuf (SCM port, SCM mode, SCM size) +GUILE_PROC (scm_setvbuf, "setvbuf", 2, 1, 0, + (SCM port, SCM mode, SCM size), +"") +#define FUNC_NAME s_scm_setvbuf { int cmode, csize; scm_port *pt; port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, - s_setvbuf); - SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_setvbuf); - cmode = SCM_INUM (mode); + SCM_VALIDATE_OPFPORT(1,port); + SCM_VALIDATE_INT_COPY(2,mode,cmode); if (cmode != _IONBF && cmode != _IOFBF && cmode != _IOLBF) - scm_out_of_range (s_setvbuf, mode); + scm_out_of_range (FUNC_NAME, mode); if (cmode == _IOLBF) { @@ -159,10 +163,9 @@ scm_setvbuf (SCM port, SCM mode, SCM size) } else { - SCM_ASSERT (SCM_INUMP (size), size, SCM_ARG3, s_setvbuf); - csize = SCM_INUM (size); + SCM_VALIDATE_INT_COPY(3,size,csize); if (csize < 0 || (cmode == _IONBF && csize > 0)) - scm_out_of_range (s_setvbuf, size); + scm_out_of_range (FUNC_NAME, size); } pt = SCM_PTAB_ENTRY (port); @@ -176,6 +179,7 @@ scm_setvbuf (SCM port, SCM mode, SCM size) scm_fport_buffer_add (port, csize, csize); return SCM_UNSPECIFIED; } +#undef FUNC_NAME /* Move ports with the specified file descriptor to new descriptors, * reseting the revealed count to 0. @@ -214,12 +218,10 @@ scm_evict_ports (fd) * * Return the new port. */ -SCM_PROC(s_open_file, "open-file", 2, 0, 0, scm_open_file); - -SCM -scm_open_file (filename, modes) - SCM filename; - SCM modes; +GUILE_PROC(scm_open_file, "open-file", 2, 0, 0, + (SCM filename, SCM modes), +"") +#define FUNC_NAME s_scm_open_file { SCM port; int fdes; @@ -228,8 +230,8 @@ scm_open_file (filename, modes) char *mode; char *ptr; - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_open_file); - SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_file); + SCM_VALIDATE_ROSTRING(1,filename); + SCM_VALIDATE_ROSTRING(2,modes); if (SCM_SUBSTRP (filename)) filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0); if (SCM_SUBSTRP (modes)) @@ -250,7 +252,7 @@ scm_open_file (filename, modes) flags |= O_WRONLY | O_CREAT | O_APPEND; break; default: - scm_out_of_range (s_open_file, modes); + scm_out_of_range (FUNC_NAME, modes); } ptr = mode + 1; while (*ptr != '\0') @@ -265,7 +267,7 @@ scm_open_file (filename, modes) case 'l': /* line buffered: handled during output. */ break; default: - scm_out_of_range (s_open_file, modes); + scm_out_of_range (FUNC_NAME, modes); } ptr++; } @@ -274,7 +276,7 @@ scm_open_file (filename, modes) { int en = errno; - scm_syserror_msg (s_open_file, "%s: %S", + scm_syserror_msg (FUNC_NAME, "%s: %S", scm_cons (scm_makfrom0str (strerror (en)), scm_cons (filename, SCM_EOL)), en); @@ -282,6 +284,7 @@ scm_open_file (filename, modes) port = scm_fdes_to_port (fdes, mode, filename); return port; } +#undef FUNC_NAME /* Building Guile ports from a file descriptor. */ @@ -361,13 +364,8 @@ fport_input_waiting (SCM port) } -static int prinfport SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - static int -prinfport (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +prinfport (SCM exp,SCM port,scm_print_state *pstate) { scm_puts ("#<", port); scm_print_port_mode (exp, port); diff --git a/libguile/gc.c b/libguile/gc.c index 9591e86ce..141c548e0 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include #include "_scm.h" @@ -51,6 +55,7 @@ #include "unif.h" #include "async.h" +#include "scm_validate.h" #include "gc.h" #ifdef HAVE_MALLOC_H @@ -212,9 +217,9 @@ struct scm_heap_seg_data -static void scm_mark_weak_vector_spines SCM_P ((void)); -static scm_sizet init_heap_seg SCM_P ((SCM_CELLPTR, scm_sizet, int, SCM *)); -static void alloc_some_heap SCM_P ((int, SCM *)); +static void scm_mark_weak_vector_spines(void); +static scm_sizet init_heap_seg(SCM_CELLPTR, scm_sizet, int, SCM *); +static void alloc_some_heap(int, SCM *); @@ -238,9 +243,10 @@ which_seg (SCM cell) } -SCM_PROC (s_map_free_list, "map-free-list", 0, 0, 0, scm_map_free_list); -SCM -scm_map_free_list () +GUILE_PROC (scm_map_free_list, "map-free-list", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_map_free_list { int last_seg = -1, count = 0; SCM f; @@ -266,6 +272,7 @@ scm_map_free_list () return SCM_UNSPECIFIED; } +#undef FUNC_NAME /* Number of calls to SCM_NEWCELL since startup. */ @@ -291,15 +298,15 @@ scm_check_freelist () static int scm_debug_check_freelist = 0; -SCM_PROC (s_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1, 0, 0, scm_gc_set_debug_check_freelist_x); -SCM -scm_gc_set_debug_check_freelist_x (SCM flag) +GUILE_PROC (scm_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1, 0, 0, + (SCM flag), +"") +#define FUNC_NAME s_scm_gc_set_debug_check_freelist_x { - SCM_ASSERT(SCM_BOOL_T == flag || SCM_BOOL_F == flag, - flag, 1, s_gc_set_debug_check_freelist_x); - scm_debug_check_freelist = (SCM_BOOL_T==flag)? 1: 0; + SCM_VALIDATE_BOOL_COPY(1,flag,scm_debug_check_freelist); return SCM_UNSPECIFIED; } +#undef FUNC_NAME SCM @@ -334,9 +341,10 @@ scm_debug_newcell (void) /* {Scheme Interface to GC} */ -SCM_PROC (s_gc_stats, "gc-stats", 0, 0, 0, scm_gc_stats); -SCM -scm_gc_stats () +GUILE_PROC (scm_gc_stats, "gc-stats", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_gc_stats { int i; int n; @@ -377,6 +385,7 @@ scm_gc_stats () SCM_ALLOW_INTS; return answer; } +#undef FUNC_NAME void @@ -398,24 +407,27 @@ scm_gc_end () } -SCM_PROC (s_object_address, "object-address", 1, 0, 0, scm_object_address); -SCM -scm_object_address (obj) - SCM obj; +GUILE_PROC (scm_object_address, "object-address", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_object_address { return scm_ulong2num ((unsigned long)obj); } +#undef FUNC_NAME -SCM_PROC(s_gc, "gc", 0, 0, 0, scm_gc); -SCM -scm_gc () +GUILE_PROC(scm_gc, "gc", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_gc { SCM_DEFER_INTS; scm_igc ("call"); SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } +#undef FUNC_NAME @@ -423,9 +435,7 @@ scm_gc () */ void -scm_gc_for_alloc (ncells, freelistp) - int ncells; - SCM * freelistp; +scm_gc_for_alloc (int ncells, SCM *freelistp) { SCM_REDEFER_INTS; scm_igc ("cells"); @@ -444,12 +454,12 @@ scm_gc_for_newcell () scm_gc_for_alloc (1, &scm_freelist); fl = scm_freelist; scm_freelist = SCM_CDR (fl); + SCM_SETCAR(fl, scm_tc16_allocated); return fl; } void -scm_igc (what) - const char *what; +scm_igc (const char *what) { int j; @@ -609,8 +619,7 @@ scm_igc (what) /* Mark an object precisely. */ void -scm_gc_mark (p) - SCM p; +scm_gc_mark (SCM p) { register long i; register SCM ptr; @@ -873,7 +882,9 @@ gc_mark_nimp: { /* should be faster than going through scm_smobs */ case scm_tc_free_cell: /* printf("found free_cell %X ", ptr); fflush(stdout); */ - SCM_SETCDR (ptr, SCM_EOL); + break; + case scm_tc16_allocated: + SCM_SETGC8MARK (ptr); break; case scm_tcs_bignums: case scm_tc16_flo: @@ -1757,14 +1768,14 @@ alloc_some_heap (ncells, freelistp) -SCM_PROC (s_unhash_name, "unhash-name", 1, 0, 0, scm_unhash_name); -SCM -scm_unhash_name (name) - SCM name; +GUILE_PROC (scm_unhash_name, "unhash-name", 1, 0, 0, + (SCM name), +"") +#define FUNC_NAME s_scm_unhash_name { int x; int bound; - SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name), name, SCM_ARG1, s_unhash_name); + SCM_VALIDATE_SYMBOL(1,name); SCM_DEFER_INTS; bound = scm_n_heap_segs; for (x = 0; x < bound; ++x) @@ -1793,6 +1804,7 @@ scm_unhash_name (name) SCM_ALLOW_INTS; return name; } +#undef FUNC_NAME diff --git a/libguile/gdbint.c b/libguile/gdbint.c index c3c6cdd38..647e38504 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.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 "_scm.h" #include @@ -132,11 +136,8 @@ static SCM gdb_output_port; static int old_ints, old_gc; -static void unmark_port SCM_P ((SCM port)); - static void -unmark_port (port) - SCM port; +unmark_port (SCM port) { SCM stream, string; port_mark_p = SCM_GC8MARKP (port); @@ -150,11 +151,8 @@ unmark_port (port) } -static void remark_port SCM_P ((SCM port)); - static void -remark_port (port) - SCM port; +remark_port (SCM port) { SCM stream = SCM_STREAM (port); SCM string = SCM_CDR (stream); diff --git a/libguile/gsubr.c b/libguile/gsubr.c index af2e6d892..399129343 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -59,12 +63,7 @@ SCM scm_sym_name; SCM scm_f_gsubr_apply; SCM -scm_make_gsubr(name, req, opt, rst, fcn) - const char *name; - int req; - int opt; - int rst; - SCM (*fcn)(); +scm_make_gsubr(const char *name,int req,int opt,int rst,SCM (*fcn)()) { switch SCM_GSUBR_MAKTYPE(req, opt, rst) { case SCM_GSUBR_MAKTYPE(0, 0, 0): return scm_make_subr(name, scm_tc7_subr_0, fcn); @@ -130,11 +129,10 @@ scm_make_gsubr_with_generic (const char *name, } -SCM_PROC(s_gsubr_apply, "gsubr-apply", 0, 0, 1, scm_gsubr_apply); - -SCM -scm_gsubr_apply(args) - SCM args; +GUILE_PROC(scm_gsubr_apply, "gsubr-apply", 0, 0, 1, + (SCM args), +"") +#define FUNC_NAME s_scm_gsubr_apply { SCM self = SCM_CAR(args); SCM (*fcn)() = SCM_SUBRF(SCM_GSUBR_PROC(self)); @@ -143,7 +141,7 @@ scm_gsubr_apply(args) int i, n = SCM_GSUBR_REQ(typ) + SCM_GSUBR_OPT(typ) + SCM_GSUBR_REST(typ); #if 0 SCM_ASSERT(n <= sizeof(v)/sizeof(SCM), - self, "internal programming error", s_gsubr_apply); + self, "internal programming error", FUNC_NAME); #endif args = SCM_CDR(args); for (i = 0; i < SCM_GSUBR_REQ(typ); i++) { @@ -179,6 +177,7 @@ scm_gsubr_apply(args) } return 0; /* Never reached. */ } +#undef FUNC_NAME #ifdef GSUBR_TEST @@ -186,8 +185,7 @@ scm_gsubr_apply(args) a scm_list of rest args */ SCM -gsubr_21l(req1, req2, opt, rst) - SCM req1, req2, opt, rst; +gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst) { scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp); scm_display(req1, scm_cur_outp); @@ -207,7 +205,8 @@ gsubr_21l(req1, req2, opt, rst) void scm_init_gsubr() { - scm_f_gsubr_apply = scm_make_subr(s_gsubr_apply, scm_tc7_lsubr, scm_gsubr_apply); + /* GJB:FIXME:: why is this file not including the .x file? */ + scm_f_gsubr_apply = scm_make_subr(s_scm_gsubr_apply, scm_tc7_lsubr, scm_gsubr_apply); scm_sym_name = SCM_CAR (scm_sysintern ("name", SCM_UNDEFINED)); scm_permanent_object (scm_sym_name); #ifdef GSUBR_TEST diff --git a/libguile/guardians.c b/libguile/guardians.c index 2bfdf6c7f..32a5db184 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + /* This is an implementation of guardians as described in @@ -58,6 +62,7 @@ #include "smob.h" #include "genio.h" +#include "scm_validate.h" #include "guardians.h" static long scm_tc16_guardian; @@ -144,13 +149,13 @@ guard (SCM cclo, SCM arg) static SCM guard1; -SCM_PROC (s_make_guardian, "make-guardian", 0, 0, 0, scm_make_guardian); -SCM -scm_make_guardian () +GUILE_PROC (scm_make_guardian, "make-guardian", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_make_guardian { SCM cclo = scm_makcclo (guard1, 2L); - guardian_t *g = (guardian_t *) scm_must_malloc (sizeof (guardian_t), - s_make_guardian); + guardian_t *g = SCM_MUST_MALLOC_TYPE(guardian_t); SCM z1 = scm_cons (SCM_BOOL_F, SCM_BOOL_F); SCM z2 = scm_cons (SCM_BOOL_F, SCM_BOOL_F); SCM z; @@ -164,6 +169,7 @@ scm_make_guardian () return cclo; } +#undef FUNC_NAME void scm_guardian_gc_init() diff --git a/libguile/hash.c b/libguile/hash.c index 40cf94ad9..abb1a61bd 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -38,12 +38,17 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include #include "_scm.h" #include "chars.h" +#include "scm_validate.h" #include "hash.h" @@ -53,10 +58,7 @@ extern double floor(); unsigned long -scm_hasher(obj, n, d) - SCM obj; - unsigned long n; - scm_sizet d; +scm_hasher(SCM obj, unsigned long n, scm_sizet d) { switch (7 & (int) obj) { case 2: case 6: /* SCM_INUMP(obj) */ @@ -136,33 +138,28 @@ scm_hasher(obj, n, d) unsigned int -scm_ihashq (obj, n) - SCM obj; - unsigned int n; +scm_ihashq (SCM obj, unsigned int n) { return (((unsigned int) obj) >> 1) % n; } -SCM_PROC(s_hashq, "hashq", 2, 0, 0, scm_hashq); - -SCM -scm_hashq(obj, n) - SCM obj; - SCM n; +GUILE_PROC(scm_hashq, "hashq", 2, 0, 0, + (SCM obj, SCM n), +"") +#define FUNC_NAME s_scm_hashq { - SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hashq); + SCM_VALIDATE_INT_MIN(2,n,0); return SCM_MAKINUM(scm_ihashq (obj, SCM_INUM (n))); } +#undef FUNC_NAME unsigned int -scm_ihashv (obj, n) - SCM obj; - unsigned int n; +scm_ihashv (SCM obj, unsigned int n) { if (SCM_ICHRP(obj)) return ((unsigned int)(scm_downcase(SCM_ICHR(obj)))) % n; /* downcase!?!! */ @@ -174,39 +171,35 @@ scm_ihashv (obj, n) } -SCM_PROC(s_hashv, "hashv", 2, 0, 0, scm_hashv); - -SCM -scm_hashv(obj, n) - SCM obj; - SCM n; +GUILE_PROC(scm_hashv, "hashv", 2, 0, 0, + (SCM obj, SCM n), +"") +#define FUNC_NAME s_scm_hashv { - SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hashv); + SCM_VALIDATE_INT_MIN(2,n,0); return SCM_MAKINUM(scm_ihashv (obj, SCM_INUM (n))); } +#undef FUNC_NAME unsigned int -scm_ihash (obj, n) - SCM obj; - unsigned int n; +scm_ihash (SCM obj, unsigned int n) { return (unsigned int)scm_hasher (obj, n, 10); } -SCM_PROC(s_hash, "hash", 2, 0, 0, scm_hash); - -SCM -scm_hash(obj, n) - SCM obj; - SCM n; +GUILE_PROC(scm_hash, "hash", 2, 0, 0, + (SCM obj, SCM n), +"") +#define FUNC_NAME s_scm_hash { - SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hash); + SCM_VALIDATE_INT_MIN(2,n,0); return SCM_MAKINUM(scm_ihash(obj, SCM_INUM(n))); } +#undef FUNC_NAME diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 2d56708f1..1b438886d 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -46,17 +50,13 @@ #include "hash.h" #include "eval.h" +#include "scm_validate.h" #include "hashtab.h" SCM -scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure) - SCM table; - SCM obj; - unsigned int (*hash_fn)(); - SCM (*assoc_fn)(); - void * closure; +scm_hash_fn_get_handle (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_fn)(),void * closure) { unsigned int k; SCM h; @@ -76,13 +76,8 @@ scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure) SCM -scm_hash_fn_create_handle_x (table, obj, init, hash_fn, assoc_fn, closure) - SCM table; - SCM obj; - SCM init; - unsigned int (*hash_fn)(); - SCM (*assoc_fn)(); - void * closure; +scm_hash_fn_create_handle_x (SCM table,SCM obj,SCM init,unsigned int (*hash_fn)(), + SCM (*assoc_fn)(),void * closure) { unsigned int k; SCM it; @@ -116,13 +111,8 @@ scm_hash_fn_create_handle_x (table, obj, init, hash_fn, assoc_fn, closure) SCM -scm_hash_fn_ref (table, obj, dflt, hash_fn, assoc_fn, closure) - SCM table; - SCM obj; - SCM dflt; - unsigned int (*hash_fn)(); - SCM (*assoc_fn)(); - void * closure; +scm_hash_fn_ref (SCM table,SCM obj,SCM dflt,unsigned int (*hash_fn)(), + SCM (*assoc_fn)(),void * closure) { SCM it; @@ -137,13 +127,8 @@ scm_hash_fn_ref (table, obj, dflt, hash_fn, assoc_fn, closure) SCM -scm_hash_fn_set_x (table, obj, val, hash_fn, assoc_fn, closure) - SCM table; - SCM obj; - SCM val; - unsigned int (*hash_fn)(); - SCM (*assoc_fn)(); - void * closure; +scm_hash_fn_set_x (SCM table,SCM obj,SCM val,unsigned int (*hash_fn)(), + SCM (*assoc_fn)(),void * closure) { SCM it; @@ -157,13 +142,8 @@ scm_hash_fn_set_x (table, obj, val, hash_fn, assoc_fn, closure) SCM -scm_hash_fn_remove_x (table, obj, hash_fn, assoc_fn, delete_fn, closure) - SCM table; - SCM obj; - unsigned int (*hash_fn)(); - SCM (*assoc_fn)(); - SCM (*delete_fn)(); - void * closure; +scm_hash_fn_remove_x (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_fn)(), + SCM (*delete_fn)(),void * closure) { unsigned int k; SCM h; @@ -184,192 +164,168 @@ scm_hash_fn_remove_x (table, obj, hash_fn, assoc_fn, delete_fn, closure) -SCM_PROC (s_hashq_get_handle, "hashq-get-handle", 2, 0, 0, scm_hashq_get_handle); - -SCM -scm_hashq_get_handle (table, obj) - SCM table; - SCM obj; +GUILE_PROC (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0, + (SCM table, SCM obj), +"") +#define FUNC_NAME s_scm_hashq_get_handle { return scm_hash_fn_get_handle (table, obj, scm_ihashq, scm_sloppy_assq, 0); } +#undef FUNC_NAME -SCM_PROC (s_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0, scm_hashq_create_handle_x); - -SCM -scm_hashq_create_handle_x (table, obj, init) - SCM table; - SCM obj; - SCM init; +GUILE_PROC (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0, + (SCM table, SCM obj, SCM init), +"") +#define FUNC_NAME s_scm_hashq_create_handle_x { return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashq, scm_sloppy_assq, 0); } +#undef FUNC_NAME -SCM_PROC (s_hashq_ref, "hashq-ref", 2, 1, 0, scm_hashq_ref); - -SCM -scm_hashq_ref (table, obj, dflt) - SCM table; - SCM obj; - SCM dflt; +GUILE_PROC (scm_hashq_ref, "hashq-ref", 2, 1, 0, + (SCM table, SCM obj, SCM dflt), +"") +#define FUNC_NAME s_scm_hashq_ref { if (dflt == SCM_UNDEFINED) dflt = SCM_BOOL_F; return scm_hash_fn_ref (table, obj, dflt, scm_ihashq, scm_sloppy_assq, 0); } +#undef FUNC_NAME -SCM_PROC (s_hashq_set_x, "hashq-set!", 3, 0, 0, scm_hashq_set_x); - -SCM -scm_hashq_set_x (table, obj, val) - SCM table; - SCM obj; - SCM val; +GUILE_PROC (scm_hashq_set_x, "hashq-set!", 3, 0, 0, + (SCM table, SCM obj, SCM val), +"") +#define FUNC_NAME s_scm_hashq_set_x { return scm_hash_fn_set_x (table, obj, val, scm_ihashq, scm_sloppy_assq, 0); } +#undef FUNC_NAME -SCM_PROC (s_hashq_remove_x, "hashq-remove!", 2, 0, 0, scm_hashq_remove_x); - -SCM -scm_hashq_remove_x (table, obj) - SCM table; - SCM obj; +GUILE_PROC (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0, + (SCM table, SCM obj), +"") +#define FUNC_NAME s_scm_hashq_remove_x { return scm_hash_fn_remove_x (table, obj, scm_ihashq, scm_sloppy_assq, scm_delq_x, 0); } +#undef FUNC_NAME -SCM_PROC (s_hashv_get_handle, "hashv-get-handle", 2, 0, 0, scm_hashv_get_handle); - -SCM -scm_hashv_get_handle (table, obj) - SCM table; - SCM obj; +GUILE_PROC (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0, + (SCM table, SCM obj), +"") +#define FUNC_NAME s_scm_hashv_get_handle { return scm_hash_fn_get_handle (table, obj, scm_ihashv, scm_sloppy_assv, 0); } +#undef FUNC_NAME -SCM_PROC (s_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0, scm_hashv_create_handle_x); - -SCM -scm_hashv_create_handle_x (table, obj, init) - SCM table; - SCM obj; - SCM init; +GUILE_PROC (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0, + (SCM table, SCM obj, SCM init), +"") +#define FUNC_NAME s_scm_hashv_create_handle_x { return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashv, scm_sloppy_assv, 0); } +#undef FUNC_NAME -SCM_PROC (s_hashv_ref, "hashv-ref", 2, 1, 0, scm_hashv_ref); - -SCM -scm_hashv_ref (table, obj, dflt) - SCM table; - SCM obj; - SCM dflt; +GUILE_PROC (scm_hashv_ref, "hashv-ref", 2, 1, 0, + (SCM table, SCM obj, SCM dflt), +"") +#define FUNC_NAME s_scm_hashv_ref { if (dflt == SCM_UNDEFINED) dflt = SCM_BOOL_F; return scm_hash_fn_ref (table, obj, dflt, scm_ihashv, scm_sloppy_assv, 0); } +#undef FUNC_NAME -SCM_PROC (s_hashv_set_x, "hashv-set!", 3, 0, 0, scm_hashv_set_x); - -SCM -scm_hashv_set_x (table, obj, val) - SCM table; - SCM obj; - SCM val; +GUILE_PROC (scm_hashv_set_x, "hashv-set!", 3, 0, 0, + (SCM table, SCM obj, SCM val), +"") +#define FUNC_NAME s_scm_hashv_set_x { return scm_hash_fn_set_x (table, obj, val, scm_ihashv, scm_sloppy_assv, 0); } +#undef FUNC_NAME -SCM_PROC (s_hashv_remove_x, "hashv-remove!", 2, 0, 0, scm_hashv_remove_x); - -SCM -scm_hashv_remove_x (table, obj) - SCM table; - SCM obj; +GUILE_PROC (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0, + (SCM table, SCM obj), +"") +#define FUNC_NAME s_scm_hashv_remove_x { return scm_hash_fn_remove_x (table, obj, scm_ihashv, scm_sloppy_assv, scm_delv_x, 0); } +#undef FUNC_NAME -SCM_PROC (s_hash_get_handle, "hash-get-handle", 2, 0, 0, scm_hash_get_handle); - -SCM -scm_hash_get_handle (table, obj) - SCM table; - SCM obj; +GUILE_PROC (scm_hash_get_handle, "hash-get-handle", 2, 0, 0, + (SCM table, SCM obj), +"") +#define FUNC_NAME s_scm_hash_get_handle { return scm_hash_fn_get_handle (table, obj, scm_ihash, scm_sloppy_assoc, 0); } +#undef FUNC_NAME -SCM_PROC (s_hash_create_handle_x, "hash-create-handle!", 3, 0, 0, scm_hash_create_handle_x); - -SCM -scm_hash_create_handle_x (table, obj, init) - SCM table; - SCM obj; - SCM init; +GUILE_PROC (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0, + (SCM table, SCM obj, SCM init), +"") +#define FUNC_NAME s_scm_hash_create_handle_x { return scm_hash_fn_create_handle_x (table, obj, init, scm_ihash, scm_sloppy_assoc, 0); } +#undef FUNC_NAME -SCM_PROC (s_hash_ref, "hash-ref", 2, 1, 0, scm_hash_ref); - -SCM -scm_hash_ref (table, obj, dflt) - SCM table; - SCM obj; - SCM dflt; +GUILE_PROC (scm_hash_ref, "hash-ref", 2, 1, 0, + (SCM table, SCM obj, SCM dflt), +"") +#define FUNC_NAME s_scm_hash_ref { if (dflt == SCM_UNDEFINED) dflt = SCM_BOOL_F; return scm_hash_fn_ref (table, obj, dflt, scm_ihash, scm_sloppy_assoc, 0); } +#undef FUNC_NAME -SCM_PROC (s_hash_set_x, "hash-set!", 3, 0, 0, scm_hash_set_x); - -SCM -scm_hash_set_x (table, obj, val) - SCM table; - SCM obj; - SCM val; +GUILE_PROC (scm_hash_set_x, "hash-set!", 3, 0, 0, + (SCM table, SCM obj, SCM val), +"") +#define FUNC_NAME s_scm_hash_set_x { return scm_hash_fn_set_x (table, obj, val, scm_ihash, scm_sloppy_assoc, 0); } +#undef FUNC_NAME -SCM_PROC (s_hash_remove_x, "hash-remove!", 2, 0, 0, scm_hash_remove_x); - -SCM -scm_hash_remove_x (table, obj) - SCM table; - SCM obj; +GUILE_PROC (scm_hash_remove_x, "hash-remove!", 2, 0, 0, + (SCM table, SCM obj), +"") +#define FUNC_NAME s_scm_hash_remove_x { return scm_hash_fn_remove_x (table, obj, scm_ihash, scm_sloppy_assoc, scm_delete_x, 0); } +#undef FUNC_NAME @@ -383,13 +339,8 @@ struct scm_ihashx_closure -static unsigned int scm_ihashx SCM_P ((SCM obj, unsigned int n, struct scm_ihashx_closure * closure)); - static unsigned int -scm_ihashx (obj, n, closure) - SCM obj; - unsigned int n; - struct scm_ihashx_closure * closure; +scm_ihashx (SCM obj,unsigned int n,struct scm_ihashx_closure * closure) { SCM answer; SCM_ALLOW_INTS; @@ -402,13 +353,8 @@ scm_ihashx (obj, n, closure) -static SCM scm_sloppy_assx SCM_P ((SCM obj, SCM alist, struct scm_ihashx_closure * closure)); - static SCM -scm_sloppy_assx (obj, alist, closure) - SCM obj; - SCM alist; - struct scm_ihashx_closure * closure; +scm_sloppy_assx (SCM obj,SCM alist,struct scm_ihashx_closure * closure) { SCM answer; SCM_ALLOW_INTS; @@ -422,13 +368,8 @@ scm_sloppy_assx (obj, alist, closure) -static SCM scm_delx_x SCM_P ((SCM obj, SCM alist, struct scm_ihashx_closure * closure)); - static SCM -scm_delx_x (obj, alist, closure) - SCM obj; - SCM alist; - struct scm_ihashx_closure * closure; +scm_delx_x (SCM obj,SCM alist,struct scm_ihashx_closure * closure) { SCM answer; SCM_ALLOW_INTS; @@ -441,49 +382,37 @@ scm_delx_x (obj, alist, closure) -SCM_PROC (s_hashx_get_handle, "hashx-get-handle", 4, 0, 0, scm_hashx_get_handle); - -SCM -scm_hashx_get_handle (hash, assoc, table, obj) - SCM hash; - SCM assoc; - SCM table; - SCM obj; +GUILE_PROC (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0, + (SCM hash, SCM assoc, SCM table, SCM obj), +"") +#define FUNC_NAME s_scm_hashx_get_handle { struct scm_ihashx_closure closure; closure.hash = hash; closure.assoc = assoc; return scm_hash_fn_get_handle (table, obj, scm_ihashx, scm_sloppy_assx, (void *)&closure); } +#undef FUNC_NAME -SCM_PROC (s_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, scm_hashx_create_handle_x); - -SCM -scm_hashx_create_handle_x (hash, assoc, table, obj, init) - SCM hash; - SCM assoc; - SCM table; - SCM obj; - SCM init; +GUILE_PROC (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, + (SCM hash,SCM assoc,SCM table,SCM obj,SCM init), +"") +#define FUNC_NAME s_scm_hashx_create_handle_x { struct scm_ihashx_closure closure; closure.hash = hash; closure.assoc = assoc; return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashx, scm_sloppy_assx, (void *)&closure); } +#undef FUNC_NAME -SCM_PROC (s_hashx_ref, "hashx-ref", 4, 1, 0, scm_hashx_ref); - -SCM -scm_hashx_ref (hash, assoc, table, obj, dflt) - SCM hash; - SCM assoc; - SCM table; - SCM obj; - SCM dflt; +GUILE_PROC (scm_hashx_ref, "hashx-ref", 4, 1, 0, + (SCM hash,SCM assoc,SCM table,SCM obj,SCM dflt), +"") +#define FUNC_NAME s_scm_hashx_ref { struct scm_ihashx_closure closure; if (dflt == SCM_UNDEFINED) @@ -492,35 +421,27 @@ scm_hashx_ref (hash, assoc, table, obj, dflt) closure.assoc = assoc; return scm_hash_fn_ref (table, obj, dflt, scm_ihashx, scm_sloppy_assx, (void *)&closure); } +#undef FUNC_NAME -SCM_PROC (s_hashx_set_x, "hashx-set!", 5, 0, 0, scm_hashx_set_x); - -SCM -scm_hashx_set_x (hash, assoc, table, obj, val) - SCM hash; - SCM assoc; - SCM table; - SCM obj; - SCM val; +GUILE_PROC (scm_hashx_set_x, "hashx-set!", 5, 0, 0, + (SCM hash, SCM assoc, SCM table, SCM obj, SCM val), +"") +#define FUNC_NAME s_scm_hashx_set_x { struct scm_ihashx_closure closure; closure.hash = hash; closure.assoc = assoc; return scm_hash_fn_set_x (table, obj, val, scm_ihashx, scm_sloppy_assx, (void *)&closure); } +#undef FUNC_NAME SCM -scm_hashx_remove_x (hash, assoc, delete, table, obj) - SCM hash; - SCM assoc; - SCM delete; - SCM table; - SCM obj; +scm_hashx_remove_x (SCM hash,SCM assoc,SCM delete,SCM table,SCM obj) { struct scm_ihashx_closure closure; closure.hash = hash; @@ -535,17 +456,16 @@ fold_proc (void *proc, SCM key, SCM data, SCM value) return scm_apply ((SCM) proc, SCM_LIST3 (key, data, value), SCM_EOL); } -SCM_PROC (s_hash_fold, "hash-fold", 3, 0, 0, scm_hash_fold); - -SCM -scm_hash_fold (SCM proc, SCM init, SCM table) +GUILE_PROC (scm_hash_fold, "hash-fold", 3, 0, 0, + (SCM proc, SCM init, SCM table), +"") +#define FUNC_NAME s_scm_hash_fold { - SCM_ASSERT (SCM_NIMP (table) && SCM_VECTORP (table), - table, SCM_ARG1, s_hash_fold); - SCM_ASSERT (SCM_NIMP (proc) && SCM_NFALSEP (scm_procedure_p (proc)), - proc, SCM_ARG2, s_hash_fold); + SCM_VALIDATE_PROC(1,proc); + SCM_VALIDATE_VECTOR(3,table); return scm_internal_hash_fold (fold_proc, (void *) proc, init, table); } +#undef FUNC_NAME SCM scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table) @@ -558,10 +478,10 @@ scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table) while (SCM_NNULLP (ls)) { SCM_ASSERT (SCM_NIMP (ls) && SCM_CONSP (ls), - table, SCM_ARG1, s_hash_fold); + table, SCM_ARG1, s_scm_hash_fold); handle = SCM_CAR (ls); SCM_ASSERT (SCM_NIMP (handle) && SCM_CONSP (handle), - table, SCM_ARG1, s_hash_fold); + table, SCM_ARG1, s_scm_hash_fold); result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result); ls = SCM_CDR (ls); } diff --git a/libguile/init.c b/libguile/init.c index 127ca8bef..1025124da 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + /* Include the headers for just about everything. We call all their initialization functions. */ @@ -136,12 +140,21 @@ /* Setting up the stack. */ -static void start_stack SCM_P ((void *base)); -static void restart_stack SCM_P ((void * base)); +static void +restart_stack (void *base) +{ + scm_dynwinds = SCM_EOL; + SCM_DYNENV (scm_rootcont) = SCM_EOL; + SCM_THROW_VALUE (scm_rootcont) = SCM_EOL; +#ifdef DEBUG_EXTENSIONS + SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0; +#endif + SCM_BASE (scm_rootcont) = base; + scm_continuation_stack_ptr = SCM_MAKINUM (0); +} static void -start_stack (base) - void * base; +start_stack (void *base) { SCM root; @@ -178,31 +191,12 @@ start_stack (base) } -static void -restart_stack (base) - void * base; -{ - scm_dynwinds = SCM_EOL; - SCM_DYNENV (scm_rootcont) = SCM_EOL; - SCM_THROW_VALUE (scm_rootcont) = SCM_EOL; -#ifdef DEBUG_EXTENSIONS - SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0; -#endif - SCM_BASE (scm_rootcont) = base; - scm_continuation_stack_ptr = SCM_MAKINUM (0); -} - #if 0 static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define "; -static void fixconfig SCM_P ((char *s1, char *s2, int s)); - static void -fixconfig (s1, s2, s) - char *s1; - char *s2; - int s; +fixconfig (char *s1,char *s2,int s) { fputs (s1, stderr); fputs (s2, stderr); @@ -213,10 +207,8 @@ fixconfig (s1, s2, s) } -static void check_config SCM_P ((void)); - static void -check_config () +check_config (void) { scm_sizet j; @@ -344,16 +336,15 @@ typedef long setjmp_type; struct main_func_closure { /* the function to call */ - void (*main_func) SCM_P ((void *closure, int argc, char **argv)); + void (*main_func)(void *closure, int argc, char **argv); void *closure; /* dummy data to pass it */ int argc; char **argv; /* the argument list it should receive */ }; -static void scm_boot_guile_1 SCM_P ((SCM_STACKITEM *base, - struct main_func_closure *closure)); -static SCM invoke_main_func SCM_P ((void *body_data)); +static void scm_boot_guile_1(SCM_STACKITEM *base, struct main_func_closure *closure); +static SCM invoke_main_func(void *body_data); /* Fire up the Guile Scheme interpreter. diff --git a/libguile/ioext.c b/libguile/ioext.c index 209f85d44..b8c070fe9 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + @@ -50,6 +54,7 @@ #include "chars.h" #include "feature.h" +#include "scm_validate.h" #include "ioext.h" #include @@ -62,59 +67,36 @@ #endif -SCM_PROC (s_read_delimited_x, "%read-delimited!", 3, 3, 0, scm_read_delimited_x); - -SCM -scm_read_delimited_x (delims, buf, gobble, port, start, end) - SCM delims; - SCM buf; - SCM gobble; - SCM port; - SCM start; - SCM end; +GUILE_PROC (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, + (SCM delims, SCM buf, SCM gobble, SCM port, SCM start, SCM end), +"") +#define FUNC_NAME s_scm_read_delimited_x { long j; char *cbuf; long cstart; - long cend; + long cend, tend; int c; char *cdelims; int num_delims; - SCM_ASSERT (SCM_NIMP (delims) && SCM_ROSTRINGP (delims), - delims, SCM_ARG1, s_read_delimited_x); - cdelims = SCM_ROCHARS (delims); + SCM_VALIDATE_ROSTRING_COPY(1,delims,cdelims); num_delims = SCM_ROLENGTH (delims); - SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), - buf, SCM_ARG2, s_read_delimited_x); - cbuf = SCM_CHARS (buf); + SCM_VALIDATE_STRING_COPY(2,buf,cbuf); cend = SCM_LENGTH (buf); if (SCM_UNBNDP (port)) port = scm_cur_inp; else - { - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), - port, SCM_ARG1, s_read_delimited_x); - } + SCM_VALIDATE_OPINPORT(4,port); - if (SCM_UNBNDP (start)) - cstart = 0; - else - { - cstart = scm_num2long (start, - (char *) SCM_ARG5, s_read_delimited_x); - if (cstart < 0 || cstart >= cend) - scm_out_of_range (s_read_delimited_x, start); + SCM_VALIDATE_INT_DEF_COPY(5,start,0,cstart); + if (cstart < 0 || cstart >= cend) + scm_out_of_range (FUNC_NAME, start); - if (!SCM_UNBNDP (end)) - { - long tend = scm_num2long (end, (char *) SCM_ARG6, - s_read_delimited_x); - if (tend <= cstart || tend > cend) - scm_out_of_range (s_read_delimited_x, end); - cend = tend; - } - } + SCM_VALIDATE_INT_DEF_COPY(6,end,cend,tend); + if (tend <= cstart || tend > cend) + scm_out_of_range (FUNC_NAME, end); + cend = tend; for (j = cstart; j < cend; j++) { @@ -140,6 +122,7 @@ scm_read_delimited_x (delims, buf, gobble, port, start, end) } return scm_cons (SCM_BOOL_F, scm_long2num (j - cstart)); } +#undef FUNC_NAME static unsigned char * scm_do_read_line (SCM port, int *len_p) @@ -233,11 +216,10 @@ scm_do_read_line (SCM port, int *len_p) * efficiently in Scheme. */ -SCM_PROC (s_read_line, "%read-line", 0, 1, 0, scm_read_line); - -SCM -scm_read_line (port) - SCM port; +GUILE_PROC (scm_read_line, "%read-line", 0, 1, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_read_line { scm_port *pt; char *s; @@ -246,8 +228,7 @@ scm_read_line (port) if (SCM_UNBNDP (port)) port = scm_cur_inp; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), - port, SCM_ARG1, s_read_line); + SCM_VALIDATE_OPINPORT(1,port); pt = SCM_PTAB_ENTRY (port); if (pt->rw_active == SCM_PORT_WRITE) @@ -281,55 +262,50 @@ scm_read_line (port) return scm_cons (line, term); } +#undef FUNC_NAME -SCM_PROC (s_write_line, "write-line", 1, 1, 0, scm_write_line); - -SCM -scm_write_line (obj, port) - SCM obj; - SCM port; +GUILE_PROC (scm_write_line, "write-line", 1, 1, 0, + (SCM obj, SCM port), +"") +#define FUNC_NAME s_scm_write_line { scm_display (obj, port); return scm_newline (port); } +#undef FUNC_NAME -SCM_PROC (s_ftell, "ftell", 1, 0, 0, scm_ftell); - -SCM -scm_ftell (object) - SCM object; +GUILE_PROC (scm_ftell, "ftell", 1, 0, 0, + (SCM object), +"") +#define FUNC_NAME s_scm_ftell { return scm_seek (object, SCM_INUM0, SCM_MAKINUM (SEEK_CUR)); } +#undef FUNC_NAME -SCM_PROC (s_fseek, "fseek", 3, 0, 0, scm_fseek); - -SCM -scm_fseek (object, offset, whence) - SCM object; - SCM offset; - SCM whence; +GUILE_PROC (scm_fseek, "fseek", 3, 0, 0, + (SCM object, SCM offset, SCM whence), +"") +#define FUNC_NAME s_scm_fseek { scm_seek (object, offset, whence); - return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_redirect_port, "redirect-port", 2, 0, 0, scm_redirect_port); - -SCM -scm_redirect_port (old, new) - SCM old; - SCM new; +GUILE_PROC (scm_redirect_port, "redirect-port", 2, 0, 0, + (SCM old, SCM new), +"") +#define FUNC_NAME s_scm_redirect_port { int ans, oldfd, newfd; struct scm_fport *fp; old = SCM_COERCE_OUTPORT (old); new = SCM_COERCE_OUTPORT (new); - - SCM_ASSERT (SCM_NIMP (old) && SCM_OPFPORTP (old), old, SCM_ARG1, s_redirect_port); - SCM_ASSERT (SCM_NIMP (new) && SCM_OPFPORTP (new), new, SCM_ARG2, s_redirect_port); + + SCM_VALIDATE_OPFPORT(1,old); + SCM_VALIDATE_OPFPORT(2,new); oldfd = SCM_FPORT_FDES (old); fp = SCM_FSTREAM (new); newfd = fp->fdes; @@ -346,16 +322,18 @@ scm_redirect_port (old, new) scm_end_input (new); ans = dup2 (oldfd, newfd); if (ans == -1) - scm_syserror (s_redirect_port); + SCM_SYSERROR; pt->rw_random = old_pt->rw_random; /* continue using existing buffers, even if inappropriate. */ } return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_dup_to_fdes, "dup->fdes", 1, 1, 0, scm_dup_to_fdes); -SCM -scm_dup_to_fdes (SCM fd_or_port, SCM fd) +GUILE_PROC (scm_dup_to_fdes, "dup->fdes", 1, 1, 0, + (SCM fd_or_port, SCM fd), +"") +#define FUNC_NAME s_scm_dup_to_fdes { int oldfd, newfd, rv; @@ -365,8 +343,7 @@ scm_dup_to_fdes (SCM fd_or_port, SCM fd) oldfd = SCM_INUM (fd_or_port); else { - SCM_ASSERT (SCM_NIMP (fd_or_port) && SCM_OPFPORTP (fd_or_port), - fd_or_port, SCM_ARG1, s_dup_to_fdes); + SCM_VALIDATE_OPFPORT(1,fd_or_port); oldfd = SCM_FPORT_FDES (fd_or_port); } @@ -374,41 +351,44 @@ scm_dup_to_fdes (SCM fd_or_port, SCM fd) { newfd = dup (oldfd); if (newfd == -1) - scm_syserror (s_dup_to_fdes); + SCM_SYSERROR; fd = SCM_MAKINUM (newfd); } else { - SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG2, s_dup_to_fdes); + SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG2, FUNC_NAME); newfd = SCM_INUM (fd); if (oldfd != newfd) { scm_evict_ports (newfd); /* see scsh manual. */ rv = dup2 (oldfd, newfd); if (rv == -1) - scm_syserror (s_dup_to_fdes); + SCM_SYSERROR; } } return fd; } +#undef FUNC_NAME -SCM_PROC (s_fileno, "fileno", 1, 0, 0, scm_fileno); - -SCM -scm_fileno (port) - SCM port; +GUILE_PROC (scm_fileno, "fileno", 1, 0, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_fileno { port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, - s_fileno); + SCM_VALIDATE_OPFPORT(1,port); return SCM_MAKINUM (SCM_FPORT_FDES (port)); } - -SCM_PROC (s_isatty, "isatty?", 1, 0, 0, scm_isatty_p); - -SCM -scm_isatty_p (port) - SCM port; +#undef FUNC_NAME + +/* GJB:FIXME:: why does this not throw + an error if the arg is not a port? + This proc as is would be better names isattyport? + if it is not going to assume that the arg is a port */ +GUILE_PROC (scm_isatty_p, "isatty?", 1, 0, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_isatty_p { int rv; @@ -418,27 +398,26 @@ scm_isatty_p (port) return SCM_BOOL_F; rv = isatty (SCM_FPORT_FDES (port)); - return rv ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(rv); } +#undef FUNC_NAME -SCM_PROC (s_fdopen, "fdopen", 2, 0, 0, scm_fdopen); - -SCM -scm_fdopen (fdes, modes) - SCM fdes; - SCM modes; +GUILE_PROC (scm_fdopen, "fdopen", 2, 0, 0, + (SCM fdes, SCM modes), +"") +#define FUNC_NAME s_scm_fdopen { SCM port; - SCM_ASSERT (SCM_INUMP (fdes), fdes, SCM_ARG1, s_fdopen); - SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, - s_fdopen); + SCM_VALIDATE_INT(1,fdes); + SCM_VALIDATE_ROSTRING(2,modes); SCM_COERCE_SUBSTR (modes); port = scm_fdes_to_port (SCM_INUM (fdes), SCM_ROCHARS (modes), SCM_BOOL_F); return port; } +#undef FUNC_NAME @@ -447,12 +426,10 @@ scm_fdopen (fdes, modes) * #t if fdes moved. * MOVE->FDES is implemented in Scheme and calls this primitive. */ -SCM_PROC (s_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0, scm_primitive_move_to_fdes); - -SCM -scm_primitive_move_to_fdes (port, fd) - SCM port; - SCM fd; +GUILE_PROC (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0, + (SCM port, SCM fd), +"") +#define FUNC_NAME s_scm_primitive_move_to_fdes { struct scm_fport *stream; int old_fd; @@ -461,8 +438,8 @@ scm_primitive_move_to_fdes (port, fd) port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_primitive_move_to_fdes); - SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG2, s_primitive_move_to_fdes); + SCM_VALIDATE_OPFPORT(1,port); + SCM_VALIDATE_INT(2,fd); stream = SCM_FSTREAM (port); old_fd = stream->fdes; new_fd = SCM_INUM (fd); @@ -473,25 +450,24 @@ scm_primitive_move_to_fdes (port, fd) scm_evict_ports (new_fd); rv = dup2 (old_fd, new_fd); if (rv == -1) - scm_syserror (s_primitive_move_to_fdes); + SCM_SYSERROR; stream->fdes = new_fd; SCM_SYSCALL (close (old_fd)); return SCM_BOOL_T; } +#undef FUNC_NAME /* Return a list of ports using a given file descriptor. */ -SCM_PROC(s_fdes_to_ports, "fdes->ports", 1, 0, 0, scm_fdes_to_ports); - -SCM -scm_fdes_to_ports (fd) - SCM fd; +GUILE_PROC(scm_fdes_to_ports, "fdes->ports", 1, 0, 0, + (SCM fd), +"") +#define FUNC_NAME s_scm_fdes_to_ports { SCM result = SCM_EOL; int int_fd; int i; - SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG1, s_fdes_to_ports); - int_fd = SCM_INUM (fd); + SCM_VALIDATE_INT_COPY(1,fd,int_fd); for (i = 0; i < scm_port_table_size; i++) { @@ -500,7 +476,8 @@ scm_fdes_to_ports (fd) result = scm_cons (scm_port_table[i]->port, result); } return result; -} +} +#undef FUNC_NAME void diff --git a/libguile/keywords.c b/libguile/keywords.c index 376a424ad..bf009d3a6 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -45,16 +49,12 @@ #include "genio.h" #include "smob.h" +#include "scm_validate.h" #include "keywords.h" -static int prin_keyword SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - static int -prin_keyword (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +prin_keyword (SCM exp,SCM port,scm_print_state *pstate) { scm_puts ("#:", port); scm_puts(1 + SCM_CHARS (SCM_CDR (exp)), port); @@ -68,18 +68,17 @@ int scm_tc16_keyword; int scm_tc16_kw; -SCM_PROC (s_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0, scm_make_keyword_from_dash_symbol); - -SCM -scm_make_keyword_from_dash_symbol (symbol) - SCM symbol; +GUILE_PROC (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0, + (SCM symbol), +"") +#define FUNC_NAME s_scm_make_keyword_from_dash_symbol { SCM vcell; SCM_ASSERT (SCM_NIMP (symbol) && SCM_SYMBOLP (symbol) && ('-' == SCM_CHARS(symbol)[0]), - symbol, SCM_ARG1, s_make_keyword_from_dash_symbol); + symbol, SCM_ARG1, FUNC_NAME); SCM_DEFER_INTS; vcell = scm_sym2ovcell_soft (symbol, scm_keyword_obarray); @@ -94,6 +93,7 @@ scm_make_keyword_from_dash_symbol (symbol) SCM_ALLOW_INTS; return SCM_CDR (vcell); } +#undef FUNC_NAME SCM scm_c_make_keyword (char *s) @@ -107,31 +107,25 @@ scm_c_make_keyword (char *s) return scm_make_keyword_from_dash_symbol (SCM_CAR (vcell)); } -SCM_PROC(s_keyword_p, "keyword?", 1, 0, 0, scm_keyword_p); - -SCM -scm_keyword_p (obj) - SCM obj; +GUILE_PROC(scm_keyword_p, "keyword?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_keyword_p { - return ( (SCM_NIMP(obj) && SCM_KEYWORDP (obj)) - ? SCM_BOOL_T - : SCM_BOOL_F); + return SCM_BOOL(SCM_NIMP(obj) && SCM_KEYWORDP (obj)); } +#undef FUNC_NAME - -SCM_PROC(s_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0, scm_keyword_dash_symbol); - -SCM -scm_keyword_dash_symbol (keyword) - SCM keyword; +GUILE_PROC(scm_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0, + (SCM keyword), +"") +#define FUNC_NAME s_scm_keyword_dash_symbol { - SCM_ASSERT (SCM_NIMP (keyword) && SCM_KEYWORDP (keyword), - keyword, SCM_ARG1, s_keyword_dash_symbol); + SCM_VALIDATE_KEYWORD(1,keyword); return SCM_CDR (keyword); } - - +#undef FUNC_NAME diff --git a/libguile/lang.c b/libguile/lang.c index ca8690ffd..c3ea7ebe4 100644 --- a/libguile/lang.c +++ b/libguile/lang.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include "_scm.h" @@ -45,6 +49,7 @@ #include "eval.h" #include "macros.h" +#include "scm_validate.h" #include "lang.h" @@ -58,10 +63,10 @@ * in all data structures. */ -SCM_PROC (s_nil_cons, "nil-cons", 2, 0, 0, scm_nil_cons); - -SCM -scm_nil_cons (SCM x, SCM y) +GUILE_PROC (scm_nil_cons, "nil-cons", 2, 0, 0, + (SCM x, SCM y), +"") +#define FUNC_NAME s_scm_nil_cons { register SCM z; SCM_NEWCELL (z); @@ -69,37 +74,43 @@ scm_nil_cons (SCM x, SCM y) SCM_SETCDR (z, SCM_NIL2EOL (y, y)); return z; } +#undef FUNC_NAME -SCM_PROC (s_nil_car, "nil-car", 1, 0, 0, scm_nil_car); - -SCM -scm_nil_car (SCM x) +GUILE_PROC (scm_nil_car, "nil-car", 1, 0, 0, + (SCM x), + "") +#define FUNC_NAME s_scm_nil_car { if (SCM_NILP (x)) return scm_nil; - SCM_ASSERT (SCM_NIMP (x) && SCM_CONSP (x), x, SCM_ARG1, s_nil_car); + SCM_VALIDATE_NIMCONS(1,x); return SCM_CAR (x); } +#undef FUNC_NAME -SCM_PROC (s_nil_cdr, "nil-cdr", 1, 0, 0, scm_nil_cdr); - -SCM -scm_nil_cdr (SCM x) +GUILE_PROC (scm_nil_cdr, "nil-cdr", 1, 0, 0, + (SCM x), + "") +#define FUNC_NAME s_scm_nil_cdr { if (SCM_NILP (x)) return scm_nil; - SCM_ASSERT (SCM_NIMP (x) && SCM_CONSP (x), x, SCM_ARG1, s_nil_cdr); + SCM_VALIDATE_NIMCONS(1,x); return SCM_EOL2NIL (SCM_CDR (x), x); } - -SCM_PROC (s_null, "null", 1, 0, 0, scm_null); - -SCM -scm_null (SCM x) +#undef FUNC_NAME + +/* GJB:FIXME:: why does this return scm_nil instead of SCM_BOOL_F? + Could use SCM_BOOL, below, otherwise */ +GUILE_PROC (scm_null, "null", 1, 0, 0, + (SCM x), + "") +#define FUNC_NAME s_scm_null { return (SCM_NILP (x) || SCM_NULLP (x) || SCM_FALSEP (x)) ? scm_t : scm_nil; } +#undef FUNC_NAME SCM scm_m_while (SCM exp, SCM env) @@ -118,10 +129,12 @@ scm_m_while (SCM exp, SCM env) return scm_nil; } -SCM_PROC1 (s_nil_eq, "nil-eq", scm_tc7_rpsubr, scm_nil_eq); - -SCM -scm_nil_eq (SCM x, SCM y) +/* GJB:FIXME:: why does this return scm_nil instead of SCM_BOOL_F? + Could use SCM_BOOL, below, otherwise */ +GUILE_PROC1 (scm_nil_eq, "nil-eq", scm_tc7_rpsubr, + (SCM x, SCM y), +"") +#define FUNC_NAME s_scm_nil_eq { return (((x==y) || (SCM_NILP (x) && (SCM_NULLP (y) || SCM_FALSEP (y))) @@ -129,6 +142,7 @@ scm_nil_eq (SCM x, SCM y) ? scm_t : scm_nil); } +#undef FUNC_NAME diff --git a/libguile/list.c b/libguile/list.c index 52069a07c..266affd39 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -38,11 +38,16 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include #include "_scm.h" #include "eq.h" +#include "scm_validate.h" #include "list.h" #ifdef __STDC__ @@ -84,19 +89,20 @@ scm_listify (elt, va_alist) } -SCM_PROC(s_list, "list", 0, 0, 1, scm_list); -SCM -scm_list(objs) - SCM objs; +GUILE_PROC(scm_list, "list", 0, 0, 1, + (SCM objs), +"") +#define FUNC_NAME s_scm_list { return objs; } +#undef FUNC_NAME -SCM_PROC (s_list_star, "list*", 1, 0, 1, scm_list_star); - -SCM -scm_list_star (SCM arg, SCM rest) +GUILE_PROC (scm_list_star, "list*", 1, 0, 1, + (SCM arg, SCM rest), +"") +#define FUNC_NAME s_scm_list_star { if (SCM_NIMP (rest)) { @@ -110,30 +116,29 @@ scm_list_star (SCM arg, SCM rest) } return arg; } - +#undef FUNC_NAME /* general questions about lists --- null?, list?, length, etc. */ -SCM_PROC(s_null_p, "null?", 1, 0, 0, scm_null_p); -SCM -scm_null_p(x) - SCM x; +GUILE_PROC(scm_null_p, "null?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_null_p { - return SCM_NULLP(x) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(SCM_NULLP(x)); } +#undef FUNC_NAME -SCM_PROC(s_list_p, "list?", 1, 0, 0, scm_list_p); -SCM -scm_list_p(x) - SCM x; +GUILE_PROC(scm_list_p, "list?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_list_p { - if (scm_ilength(x)<0) - return SCM_BOOL_F; - else - return SCM_BOOL_T; + return SCM_BOOL(scm_ilength(x)>=0); } +#undef FUNC_NAME /* Return the length of SX, or -1 if it's not a proper list. @@ -141,8 +146,7 @@ scm_list_p(x) long" lists (i.e. lists with cycles in their cdrs), and returns -1 if it does find one. */ long -scm_ilength(sx) - SCM sx; +scm_ilength(SCM sx) { register long i = 0; register SCM tortoise = sx; @@ -167,56 +171,57 @@ scm_ilength(sx) return -1; } -SCM_PROC(s_length, "length", 1, 0, 0, scm_length); -SCM -scm_length(x) - SCM x; +GUILE_PROC(scm_length, "length", 1, 0, 0, + (SCM lst), +"") +#define FUNC_NAME s_scm_length { int i; - i = scm_ilength(x); - SCM_ASSERT(i >= 0, x, SCM_ARG1, s_length); + SCM_VALIDATE_LIST_COPYLEN(1,lst,i); return SCM_MAKINUM (i); } +#undef FUNC_NAME /* appending lists */ -SCM_PROC (s_append, "append", 0, 0, 1, scm_append); -SCM -scm_append(args) - SCM args; +GUILE_PROC (scm_append, "append", 0, 0, 1, + (SCM args), +"") +#define FUNC_NAME s_scm_append { SCM res = SCM_EOL; SCM *lloc = &res, arg; if (SCM_IMP(args)) { - SCM_ASSERT(SCM_NULLP(args), args, SCM_ARGn, s_append); + SCM_VALIDATE_NULL(SCM_ARGn, args); return res; } - SCM_ASSERT(SCM_CONSP(args), args, SCM_ARGn, s_append); + SCM_VALIDATE_CONS(SCM_ARGn, args); while (1) { arg = SCM_CAR(args); args = SCM_CDR(args); if (SCM_IMP(args)) { *lloc = arg; - SCM_ASSERT(SCM_NULLP(args), args, SCM_ARGn, s_append); + SCM_VALIDATE_NULL(SCM_ARGn, args); return res; } - SCM_ASSERT(SCM_CONSP(args), args, SCM_ARGn, s_append); + SCM_VALIDATE_CONS(SCM_ARGn, args); for(;SCM_NIMP(arg);arg = SCM_CDR(arg)) { - SCM_ASSERT(SCM_CONSP(arg), arg, SCM_ARGn, s_append); + SCM_VALIDATE_CONS(SCM_ARGn, arg); *lloc = scm_cons(SCM_CAR(arg), SCM_EOL); lloc = SCM_CDRLOC(*lloc); } - SCM_ASSERT(SCM_NULLP(arg), arg, SCM_ARGn, s_append); + SCM_VALIDATE_NULL(SCM_ARGn, arg); } } +#undef FUNC_NAME -SCM_PROC (s_append_x, "append!", 0, 0, 1, scm_append_x); -SCM -scm_append_x(args) - SCM args; +GUILE_PROC (scm_append_x, "append!", 0, 0, 1, + (SCM args), +"") +#define FUNC_NAME s_scm_append_x { SCM arg; tail: @@ -225,16 +230,17 @@ scm_append_x(args) args = SCM_CDR(args); if (SCM_NULLP(args)) return arg; if (SCM_NULLP(arg)) goto tail; - SCM_ASSERT(SCM_NIMP(arg) && SCM_CONSP(arg), arg, SCM_ARG1, s_append_x); + SCM_VALIDATE_NIMCONS(SCM_ARG1,arg); SCM_SETCDR (scm_last_pair (arg), scm_append_x (args)); return arg; } +#undef FUNC_NAME -SCM_PROC(s_last_pair, "last-pair", 1, 0, 0, scm_last_pair); -SCM -scm_last_pair(sx) - SCM sx; +GUILE_PROC(scm_last_pair, "last-pair", 1, 0, 0, + (SCM sx), +"") +#define FUNC_NAME s_scm_last_pair { register SCM res = sx; register SCM x; @@ -242,7 +248,7 @@ scm_last_pair(sx) if (SCM_NULLP (sx)) return SCM_EOL; - SCM_ASSERT(SCM_NIMP(res) && SCM_CONSP(res), res, SCM_ARG1, s_last_pair); + SCM_VALIDATE_NIMCONS(SCM_ARG1,res); while (!0) { x = SCM_CDR(res); if (SCM_IMP(x) || SCM_NCONSP(x)) return res; @@ -251,50 +257,52 @@ scm_last_pair(sx) if (SCM_IMP(x) || SCM_NCONSP(x)) return res; res = x; sx = SCM_CDR(sx); - SCM_ASSERT(x != sx, sx, SCM_ARG1, s_last_pair); + SCM_ASSERT(x != sx, sx, SCM_ARG1, FUNC_NAME); } } +#undef FUNC_NAME /* reversing lists */ -SCM_PROC (s_reverse, "reverse", 1, 0, 0, scm_reverse); - -SCM -scm_reverse (SCM ls) +GUILE_PROC (scm_reverse, "reverse", 1, 0, 0, + (SCM ls), +"") +#define FUNC_NAME s_scm_reverse { SCM res = SCM_EOL; SCM p = ls, t = ls; while (SCM_NIMP (p)) { - SCM_ASSERT (SCM_CONSP (p), ls, SCM_ARG1, s_reverse); + SCM_VALIDATE_CONS(1,ls); res = scm_cons (SCM_CAR (p), res); p = SCM_CDR (p); if (SCM_IMP (p)) break; - SCM_ASSERT (SCM_CONSP (p), ls, SCM_ARG1, s_reverse); + SCM_VALIDATE_CONS(1,ls); res = scm_cons (SCM_CAR (p), res); p = SCM_CDR (p); t = SCM_CDR (t); if (t == p) - scm_misc_error (s_reverse, "Circular structure: %S", SCM_LIST1 (ls)); + scm_misc_error (FUNC_NAME, "Circular structure: %S", SCM_LIST1 (ls)); } - SCM_ASSERT (SCM_NULLP (p), ls, SCM_ARG1, s_reverse); + ls = p; + SCM_VALIDATE_NULL(1,ls); return res; } +#undef FUNC_NAME -SCM_PROC (s_reverse_x, "reverse!", 1, 1, 0, scm_reverse_x); -SCM -scm_reverse_x (ls, new_tail) - SCM ls; - SCM new_tail; +GUILE_PROC (scm_reverse_x, "reverse!", 1, 1, 0, + (SCM ls, SCM new_tail), +"") +#define FUNC_NAME s_scm_reverse_x { SCM old_tail; - SCM_ASSERT (scm_ilength (ls) >= 0, ls, SCM_ARG1, s_reverse_x); + SCM_ASSERT (scm_ilength (ls) >= 0, ls, SCM_ARG1, FUNC_NAME); if (SCM_UNBNDP (new_tail)) new_tail = SCM_EOL; else - SCM_ASSERT (scm_ilength (new_tail) >= 0, new_tail, SCM_ARG2, s_reverse_x); + SCM_ASSERT (scm_ilength (new_tail) >= 0, new_tail, SCM_ARG2, FUNC_NAME); while (SCM_NIMP (ls)) { @@ -305,124 +313,119 @@ scm_reverse_x (ls, new_tail) } return new_tail; } +#undef FUNC_NAME /* indexing lists by element number */ -SCM_PROC(s_list_ref, "list-ref", 2, 0, 0, scm_list_ref); -SCM -scm_list_ref(lst, k) - SCM lst; - SCM k; -{ - register long i; - SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_ref); - i = SCM_INUM(k); - SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_ref); - while (i-- > 0) { - SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout); - lst = SCM_CDR(lst); - } -erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), - SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_ref); - return SCM_CAR(lst); +GUILE_PROC(scm_list_ref, "list-ref", 2, 0, 0, + (SCM lst, SCM k), +"") +#define FUNC_NAME s_scm_list_ref +{ + register long i; + SCM_VALIDATE_INT_MIN_COPY(2,k,0,i); + while (i-- > 0) { + SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout); + lst = SCM_CDR(lst); + } + erout: + SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), + SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME); + return SCM_CAR(lst); } +#undef FUNC_NAME -SCM_PROC(s_list_set_x, "list-set!", 3, 0, 0, scm_list_set_x); -SCM -scm_list_set_x(lst, k, val) - SCM lst; - SCM k; - SCM val; -{ - register long i; - SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_set_x); - i = SCM_INUM(k); - SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_set_x); - while (i-- > 0) { - SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout); - lst = SCM_CDR(lst); - } -erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), - SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_set_x); - SCM_SETCAR (lst, val); - return val; +GUILE_PROC(scm_list_set_x, "list-set!", 3, 0, 0, + (SCM lst, SCM k, SCM val), +"") +#define FUNC_NAME s_scm_list_set_x +{ + register long i; + SCM_VALIDATE_INT_MIN_COPY(2,k,0,i); + while (i-- > 0) { + SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout); + lst = SCM_CDR(lst); + } + erout: + SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), + SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME); + SCM_SETCAR (lst, val); + return val; } +#undef FUNC_NAME -SCM_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail); -SCM_PROC(s_list_tail, "list-tail", 2, 0, 0, scm_list_tail); -SCM -scm_list_tail(lst, k) - SCM lst; - SCM k; +SCM_REGISTER_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail); + +GUILE_PROC(scm_list_tail, "list-tail", 2, 0, 0, + (SCM lst, SCM k), +"") +#define FUNC_NAME s_scm_list_tail { register long i; - SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_tail); - i = SCM_INUM(k); + SCM_VALIDATE_INT_MIN_COPY(2,k,0,i); while (i-- > 0) { - SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_tail); + SCM_VALIDATE_NIMCONS(1,lst); lst = SCM_CDR(lst); } return lst; } +#undef FUNC_NAME -SCM_PROC(s_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, scm_list_cdr_set_x); -SCM -scm_list_cdr_set_x(lst, k, val) - SCM lst; - SCM k; - SCM val; -{ - register long i; - SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_cdr_set_x); - i = SCM_INUM(k); - SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_cdr_set_x); - while (i-- > 0) { - SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout); - lst = SCM_CDR(lst); - } -erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), - SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_cdr_set_x); - SCM_SETCDR (lst, val); - return val; +GUILE_PROC(scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, + (SCM lst, SCM k, SCM val), +"") +#define FUNC_NAME s_scm_list_cdr_set_x +{ + register long i; + SCM_VALIDATE_INT_MIN_COPY(2,k,0,i); + while (i-- > 0) { + SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout); + lst = SCM_CDR(lst); + } +erout: + SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), + SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME); + SCM_SETCDR (lst, val); + return val; } +#undef FUNC_NAME /* copying lists, perhaps partially */ -SCM_PROC(s_list_head, "list-head", 2, 0, 0, scm_list_head); -SCM -scm_list_head(lst, k) - SCM lst; - SCM k; +GUILE_PROC(scm_list_head, "list-head", 2, 0, 0, + (SCM lst, SCM k), +"") +#define FUNC_NAME s_scm_list_head { SCM answer; SCM * pos; register long i; - SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_head); + SCM_VALIDATE_INT_MIN_COPY(2,k,0,i); answer = SCM_EOL; pos = &answer; - i = SCM_INUM(k); while (i-- > 0) { - SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_head); + SCM_VALIDATE_NIMCONS(1,lst); *pos = scm_cons (SCM_CAR (lst), SCM_EOL); pos = SCM_CDRLOC (*pos); lst = SCM_CDR(lst); } return answer; } +#undef FUNC_NAME -SCM_PROC (s_list_copy, "list-copy", 1, 0, 0, scm_list_copy); -SCM -scm_list_copy (lst) - SCM lst; +GUILE_PROC (scm_list_copy, "list-copy", 1, 0, 0, + (SCM lst), +"") +#define FUNC_NAME s_scm_list_copy { SCM newlst; SCM * fill_here; @@ -442,15 +445,15 @@ scm_list_copy (lst) } return newlst; } +#undef FUNC_NAME /* membership tests (memq, memv, etc.) */ -SCM_PROC (s_sloppy_memq, "sloppy-memq", 2, 0, 0, scm_sloppy_memq); -SCM -scm_sloppy_memq(x, lst) - SCM x; - SCM lst; +GUILE_PROC (scm_sloppy_memq, "sloppy-memq", 2, 0, 0, + (SCM x, SCM lst), +"") +#define FUNC_NAME s_scm_sloppy_memq { for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst)) { @@ -459,13 +462,13 @@ scm_sloppy_memq(x, lst) } return lst; } +#undef FUNC_NAME -SCM_PROC (s_sloppy_memv, "sloppy-memv", 2, 0, 0, scm_sloppy_memv); -SCM -scm_sloppy_memv(x, lst) - SCM x; - SCM lst; +GUILE_PROC (scm_sloppy_memv, "sloppy-memv", 2, 0, 0, + (SCM x, SCM lst), +"") +#define FUNC_NAME s_scm_sloppy_memv { for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst)) { @@ -474,13 +477,13 @@ scm_sloppy_memv(x, lst) } return lst; } +#undef FUNC_NAME -SCM_PROC (s_sloppy_member, "sloppy-member", 2, 0, 0, scm_sloppy_member); -SCM -scm_sloppy_member (x, lst) - SCM x; - SCM lst; +GUILE_PROC (scm_sloppy_member, "sloppy-member", 2, 0, 0, + (SCM x, SCM lst), +"") +#define FUNC_NAME s_scm_sloppy_member { for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst)) { @@ -489,57 +492,57 @@ scm_sloppy_member (x, lst) } return lst; } +#undef FUNC_NAME -SCM_PROC(s_memq, "memq", 2, 0, 0, scm_memq); -SCM -scm_memq(x, lst) - SCM x; - SCM lst; +GUILE_PROC(scm_memq, "memq", 2, 0, 0, + (SCM x, SCM lst), +"") +#define FUNC_NAME s_scm_memq { SCM answer; - SCM_ASSERT (scm_ilength (lst) >= 0, lst, SCM_ARG2, s_memq); + SCM_VALIDATE_LIST(2,lst); answer = scm_sloppy_memq (x, lst); return (answer == SCM_EOL) ? SCM_BOOL_F : answer; } +#undef FUNC_NAME -SCM_PROC(s_memv, "memv", 2, 0, 0, scm_memv); -SCM -scm_memv(x, lst) - SCM x; - SCM lst; +GUILE_PROC(scm_memv, "memv", 2, 0, 0, + (SCM x, SCM lst), +"") +#define FUNC_NAME s_scm_memv { SCM answer; - SCM_ASSERT (scm_ilength (lst) >= 0, lst, SCM_ARG2, s_memv); + SCM_VALIDATE_LIST(2,lst); answer = scm_sloppy_memv (x, lst); return (answer == SCM_EOL) ? SCM_BOOL_F : answer; } +#undef FUNC_NAME -SCM_PROC(s_member, "member", 2, 0, 0, scm_member); -SCM -scm_member(x, lst) - SCM x; - SCM lst; +GUILE_PROC(scm_member, "member", 2, 0, 0, + (SCM x, SCM lst), +"") +#define FUNC_NAME s_scm_member { SCM answer; - SCM_ASSERT (scm_ilength (lst) >= 0, lst, SCM_ARG2, s_member); + SCM_VALIDATE_LIST(2,lst); answer = scm_sloppy_member (x, lst); return (answer == SCM_EOL) ? SCM_BOOL_F : answer; } +#undef FUNC_NAME /* deleting elements from a list (delq, etc.) */ -SCM_PROC(s_delq_x, "delq!", 2, 0, 0, scm_delq_x); -SCM -scm_delq_x (item, lst) - SCM item; - SCM lst; +GUILE_PROC(scm_delq_x, "delq!", 2, 0, 0, + (SCM item, SCM lst), +"") +#define FUNC_NAME s_scm_delq_x { SCM walk; SCM *prev; @@ -556,13 +559,13 @@ scm_delq_x (item, lst) return lst; } +#undef FUNC_NAME -SCM_PROC(s_delv_x, "delv!", 2, 0, 0, scm_delv_x); -SCM -scm_delv_x (item, lst) - SCM item; - SCM lst; +GUILE_PROC(scm_delv_x, "delv!", 2, 0, 0, + (SCM item, SCM lst), +"") +#define FUNC_NAME s_scm_delv_x { SCM walk; SCM *prev; @@ -579,14 +582,14 @@ scm_delv_x (item, lst) return lst; } +#undef FUNC_NAME -SCM_PROC(s_delete_x, "delete!", 2, 0, 0, scm_delete_x); -SCM -scm_delete_x (item, lst) - SCM item; - SCM lst; +GUILE_PROC(scm_delete_x, "delete!", 2, 0, 0, + (SCM item, SCM lst), +"") +#define FUNC_NAME s_scm_delete_x { SCM walk; SCM *prev; @@ -603,53 +606,47 @@ scm_delete_x (item, lst) return lst; } +#undef FUNC_NAME -SCM_PROC (s_delq, "delq", 2, 0, 0, scm_delq); -SCM -scm_delq (item, lst) - SCM item; - SCM lst; +GUILE_PROC (scm_delq, "delq", 2, 0, 0, + (SCM item, SCM lst), +"") +#define FUNC_NAME s_scm_delq { - SCM copy; - - copy = scm_list_copy (lst); + SCM copy = scm_list_copy (lst); return scm_delq_x (item, copy); } +#undef FUNC_NAME -SCM_PROC (s_delv, "delv", 2, 0, 0, scm_delv); -SCM -scm_delv (item, lst) - SCM item; - SCM lst; +GUILE_PROC (scm_delv, "delv", 2, 0, 0, + (SCM item, SCM lst), +"") +#define FUNC_NAME s_scm_delv { - SCM copy; - - copy = scm_list_copy (lst); + SCM copy = scm_list_copy (lst); return scm_delv_x (item, copy); } +#undef FUNC_NAME -SCM_PROC (s_delete, "delete", 2, 0, 0, scm_delete); -SCM -scm_delete (item, lst) - SCM item; - SCM lst; +GUILE_PROC (scm_delete, "delete", 2, 0, 0, + (SCM item, SCM lst), +"") +#define FUNC_NAME s_scm_delete { - SCM copy; - - copy = scm_list_copy (lst); + SCM copy = scm_list_copy (lst); return scm_delete_x (item, copy); } +#undef FUNC_NAME -SCM_PROC(s_delq1_x, "delq1!", 2, 0, 0, scm_delq1_x); -SCM -scm_delq1_x (item, lst) - SCM item; - SCM lst; +GUILE_PROC(scm_delq1_x, "delq1!", 2, 0, 0, + (SCM item, SCM lst), +"") +#define FUNC_NAME s_scm_delq1_x { SCM walk; SCM *prev; @@ -669,13 +666,13 @@ scm_delq1_x (item, lst) return lst; } +#undef FUNC_NAME -SCM_PROC(s_delv1_x, "delv1!", 2, 0, 0, scm_delv1_x); -SCM -scm_delv1_x (item, lst) - SCM item; - SCM lst; +GUILE_PROC(scm_delv1_x, "delv1!", 2, 0, 0, + (SCM item, SCM lst), +"") +#define FUNC_NAME s_scm_delv1_x { SCM walk; SCM *prev; @@ -695,13 +692,13 @@ scm_delv1_x (item, lst) return lst; } +#undef FUNC_NAME -SCM_PROC(s_delete1_x, "delete1!", 2, 0, 0, scm_delete1_x); -SCM -scm_delete1_x (item, lst) - SCM item; - SCM lst; +GUILE_PROC(scm_delete1_x, "delete1!", 2, 0, 0, + (SCM item, SCM lst), +"") +#define FUNC_NAME s_scm_delete1_x { SCM walk; SCM *prev; @@ -721,6 +718,7 @@ scm_delete1_x (item, lst) return lst; } +#undef FUNC_NAME diff --git a/libguile/load.c b/libguile/load.c index 5ff4c472b..59a099afb 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -50,6 +54,7 @@ #include "alist.h" #include "dynwind.h" +#include "scm_validate.h" #include "load.h" #include @@ -92,23 +97,22 @@ load (void *data) return SCM_UNSPECIFIED; } -SCM_PROC(s_primitive_load, "primitive-load", 1, 0, 0, scm_primitive_load); -SCM -scm_primitive_load (filename) - SCM filename; +GUILE_PROC(scm_primitive_load, "primitive-load", 1, 0, 0, + (SCM filename), +"") +#define FUNC_NAME s_scm_primitive_load { SCM hook = *scm_loc_load_hook; - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, - SCM_ARG1, s_primitive_load); + SCM_VALIDATE_ROSTRING(1,filename); SCM_ASSERT (hook == SCM_BOOL_F || (scm_procedure_p (hook) == SCM_BOOL_T), hook, "value of %load-hook is neither a procedure nor #f", - s_primitive_load); + FUNC_NAME); if (hook != SCM_BOOL_F) scm_apply (hook, scm_listify (filename, SCM_UNDEFINED), SCM_EOL); - { + { /* scope */ SCM port, save_port; port = scm_open_file (filename, scm_makfromstr ("r", (scm_sizet) sizeof (char), 0)); @@ -122,16 +126,19 @@ scm_primitive_load (filename) } return SCM_UNSPECIFIED; } +#undef FUNC_NAME /* Builtin path to scheme library files. */ #ifdef SCM_PKGDATA_DIR -SCM_PROC (s_sys_package_data_dir, "%package-data-dir", 0, 0, 0, scm_sys_package_data_dir); -SCM -scm_sys_package_data_dir () +GUILE_PROC (scm_sys_package_data_dir, "%package-data-dir", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_sys_package_data_dir { return scm_makfrom0str (SCM_PKGDATA_DIR); } +#undef FUNC_NAME #endif /* SCM_PKGDATA_DIR */ @@ -171,21 +178,21 @@ scm_internal_parse_path (char *path, SCM tail) } -SCM_PROC (s_parse_path, "parse-path", 1, 1, 0, scm_parse_path); - -SCM -scm_parse_path (SCM path, SCM tail) +GUILE_PROC (scm_parse_path, "parse-path", 1, 1, 0, + (SCM path, SCM tail), +"") +#define FUNC_NAME s_scm_parse_path { SCM_ASSERT (SCM_FALSEP (path) || (SCM_NIMP (path) && SCM_ROSTRINGP (path)), path, - SCM_ARG1, - s_parse_path); + SCM_ARG1, FUNC_NAME); if (SCM_UNBNDP (tail)) tail = SCM_EOL; return (SCM_FALSEP (path) ? tail : scm_internal_parse_path (SCM_ROCHARS (path), tail)); } +#undef FUNC_NAME /* Initialize the global variable %load-path, given the value of the @@ -216,26 +223,22 @@ SCM scm_listofnullstr; If FILENAME is absolute, return it unchanged. If given, EXTENSIONS is a list of strings; for each directory in PATH, we search for FILENAME concatenated with each EXTENSION. */ -SCM_PROC(s_search_path, "search-path", 2, 1, 0, scm_search_path); -SCM -scm_search_path (path, filename, extensions) - SCM path; - SCM filename; - SCM extensions; +GUILE_PROC(scm_search_path, "search-path", 2, 1, 0, + (SCM path, SCM filename, SCM extensions), +"") +#define FUNC_NAME s_scm_search_path { char *filename_chars; int filename_len; size_t max_path_len; /* maximum length of any PATH element */ size_t max_ext_len; /* maximum length of any EXTENSIONS element */ - SCM_ASSERT (scm_ilength (path) >= 0, path, SCM_ARG1, s_search_path); - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, - SCM_ARG2, s_search_path); + SCM_VALIDATE_LIST(1,path); + SCM_VALIDATE_ROSTRING(2,filename); if (SCM_UNBNDP (extensions)) extensions = SCM_EOL; else - SCM_ASSERT (scm_ilength (extensions) >= 0, extensions, - SCM_ARG3, s_search_path); + SCM_VALIDATE_LIST(3,extensions); filename_chars = SCM_ROCHARS (filename); filename_len = SCM_ROLENGTH (filename); @@ -254,7 +257,7 @@ scm_search_path (path, filename, extensions) SCM elt = SCM_CAR (walk); SCM_ASSERT (SCM_NIMP (elt) && SCM_ROSTRINGP (elt), elt, "path is not a list of strings", - s_search_path); + FUNC_NAME); if (SCM_ROLENGTH (elt) > max_path_len) max_path_len = SCM_ROLENGTH (elt); } @@ -284,7 +287,7 @@ scm_search_path (path, filename, extensions) /* Find the length of the longest element of the load extensions list. */ - { + { /* scope */ SCM walk; max_ext_len = 0; @@ -293,7 +296,7 @@ scm_search_path (path, filename, extensions) SCM elt = SCM_CAR (walk); SCM_ASSERT (SCM_NIMP (elt) && SCM_ROSTRINGP (elt), elt, "extension list is not a list of strings", - s_search_path); + FUNC_NAME); if (SCM_ROLENGTH (elt) > max_ext_len) max_ext_len = SCM_ROLENGTH (elt); } @@ -301,10 +304,10 @@ scm_search_path (path, filename, extensions) SCM_DEFER_INTS; - { + { /* scope */ SCM result = SCM_BOOL_F; int buf_size = max_path_len + 1 + filename_len + max_ext_len + 1; - char *buf = scm_must_malloc (buf_size, s_search_path); + char *buf = SCM_MUST_MALLOC (buf_size); /* This simplifies the loop below a bit. */ if (SCM_NULLP (extensions)) @@ -356,41 +359,40 @@ scm_search_path (path, filename, extensions) return result; } } +#undef FUNC_NAME /* Search %load-path for a directory containing a file named FILENAME. The file must be readable, and not a directory. If we find one, return its full filename; otherwise, return #f. If FILENAME is absolute, return it unchanged. */ -SCM_PROC(s_sys_search_load_path, "%search-load-path", 1, 0, 0, scm_sys_search_load_path); -SCM -scm_sys_search_load_path (filename) - SCM filename; +GUILE_PROC(scm_sys_search_load_path, "%search-load-path", 1, 0, 0, + (SCM filename), +"") +#define FUNC_NAME s_scm_sys_search_load_path { SCM path = *scm_loc_load_path; SCM exts = *scm_loc_load_extensions; - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, - SCM_ARG1, s_sys_search_load_path); + SCM_VALIDATE_ROSTRING(1,filename); + SCM_ASSERT (scm_ilength (path) >= 0, path, "load path is not a proper list", - s_sys_search_load_path); + FUNC_NAME); SCM_ASSERT (scm_ilength (exts) >= 0, exts, "load extension list is not a proper list", - s_sys_search_load_path); - return scm_search_path (path, - filename, - exts); + FUNC_NAME); + return scm_search_path (path, filename, exts); } +#undef FUNC_NAME -SCM_PROC(s_primitive_load_path, "primitive-load-path", 1, 0, 0, scm_primitive_load_path); -SCM -scm_primitive_load_path (filename) - SCM filename; +GUILE_PROC(scm_primitive_load_path, "primitive-load-path", 1, 0, 0, + (SCM filename), +"") +#define FUNC_NAME s_scm_primitive_load_path { SCM full_filename; - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, - SCM_ARG1, s_primitive_load_path); + SCM_VALIDATE_ROSTRING(1,filename); full_filename = scm_sys_search_load_path (filename); @@ -398,7 +400,7 @@ scm_primitive_load_path (filename) { int absolute = (SCM_ROLENGTH (filename) >= 1 && SCM_ROCHARS (filename)[0] == '/'); - scm_misc_error (s_primitive_load_path, + scm_misc_error (FUNC_NAME, (absolute ? "Unable to load file %S" : "Unable to find file %S in load path"), @@ -407,6 +409,7 @@ scm_primitive_load_path (filename) return scm_primitive_load (full_filename); } +#undef FUNC_NAME /* The following function seems trivial - and indeed it is. Its * existence is motivated by its ability to evaluate expressions @@ -415,17 +418,17 @@ scm_primitive_load_path (filename) SCM_SYMBOL (scm_end_of_file_key, "end-of-file"); -SCM_PROC (s_read_and_eval_x, "read-and-eval!", 0, 1, 0, scm_read_and_eval_x); - -SCM -scm_read_and_eval_x (port) - SCM port; +GUILE_PROC (scm_read_and_eval_x, "read-and-eval!", 0, 1, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_read_and_eval_x { SCM form = scm_read (port); if (SCM_EOF_OBJECT_P (form)) scm_ithrow (scm_end_of_file_key, SCM_EOL, 1); return scm_eval_x (form); } +#undef FUNC_NAME /* Information about the build environment. */ diff --git a/libguile/macros.c b/libguile/macros.c index c7b9af06b..ac9485ab5 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -38,72 +38,71 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include "_scm.h" #include "smob.h" +#include "scm_validate.h" #include "macros.h" long scm_tc16_macro; -SCM_PROC(s_makacro, "procedure->syntax", 1, 0, 0, scm_makacro); - -SCM -scm_makacro (code) - SCM code; +GUILE_PROC (scm_makacro, "procedure->syntax", 1, 0, 0, + (SCM code), +"") +#define FUNC_NAME s_scm_makacro { - SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (code)), - code, SCM_ARG1, s_makacro); + SCM_VALIDATE_PROC(1,code); SCM_RETURN_NEWSMOB (scm_tc16_macro, code); } +#undef FUNC_NAME -SCM_PROC(s_makmacro, "procedure->macro", 1, 0, 0, scm_makmacro); - -SCM -scm_makmacro (code) - SCM code; +GUILE_PROC(scm_makmacro, "procedure->macro", 1, 0, 0, + (SCM code), +"") +#define FUNC_NAME s_scm_makmacro { - SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (code)), - code, SCM_ARG1, s_makmacro); + SCM_VALIDATE_PROC(1,code); SCM_RETURN_NEWSMOB (scm_tc16_macro | (1L << 16), code); } +#undef FUNC_NAME -SCM_PROC(s_makmmacro, "procedure->memoizing-macro", 1, 0, 0, scm_makmmacro); - -SCM -scm_makmmacro (code) - SCM code; +GUILE_PROC(scm_makmmacro, "procedure->memoizing-macro", 1, 0, 0, + (SCM code), +"") +#define FUNC_NAME s_scm_makmmacro { - SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (code)), - code, SCM_ARG1, s_makmmacro); + SCM_VALIDATE_PROC(1,code); SCM_RETURN_NEWSMOB (scm_tc16_macro | (2L << 16), code); } +#undef FUNC_NAME -SCM_PROC (s_macro_p, "macro?", 1, 0, 0, scm_macro_p); - -SCM -scm_macro_p (obj) - SCM obj; +GUILE_PROC (scm_macro_p, "macro?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_macro_p { - return (SCM_NIMP (obj) && SCM_TYP16 (obj) == scm_tc16_macro - ? SCM_BOOL_T - : SCM_BOOL_F); + return SCM_BOOL(SCM_NIMP (obj) && SCM_TYP16 (obj) == scm_tc16_macro); } +#undef FUNC_NAME SCM_SYMBOL (scm_sym_syntax, "syntax"); SCM_SYMBOL (scm_sym_macro, "macro"); SCM_SYMBOL (scm_sym_mmacro, "macro!"); -SCM_PROC (s_macro_type, "macro-type", 1, 0, 0, scm_macro_type); - -SCM -scm_macro_type (m) - SCM m; +GUILE_PROC (scm_macro_type, "macro-type", 1, 0, 0, + (SCM m), +"") +#define FUNC_NAME s_scm_macro_type { if (!(SCM_NIMP (m) && SCM_TYP16 (m) == scm_tc16_macro)) return SCM_BOOL_F; @@ -112,43 +111,35 @@ scm_macro_type (m) case 0: return scm_sym_syntax; case 1: return scm_sym_macro; case 2: return scm_sym_mmacro; - default: scm_wrong_type_arg (s_macro_type, 1, m); + default: scm_wrong_type_arg (FUNC_NAME, 1, m); } } +#undef FUNC_NAME -SCM_PROC (s_macro_name, "macro-name", 1, 0, 0, scm_macro_name); - -SCM -scm_macro_name (m) - SCM m; +GUILE_PROC (scm_macro_name, "macro-name", 1, 0, 0, + (SCM m), +"") +#define FUNC_NAME s_scm_macro_name { - SCM_ASSERT (SCM_NIMP (m) && SCM_TYP16 (m) == scm_tc16_macro, - m, - SCM_ARG1, - s_macro_name); + SCM_VALIDATE_SMOB(1,m,macro); return scm_procedure_name (SCM_CDR (m)); } +#undef FUNC_NAME -SCM_PROC (s_macro_transformer, "macro-transformer", 1, 0, 0, scm_macro_transformer); - -SCM -scm_macro_transformer (m) - SCM m; +GUILE_PROC (scm_macro_transformer, "macro-transformer", 1, 0, 0, + (SCM m), +"") +#define FUNC_NAME s_scm_macro_transformer { - SCM_ASSERT (SCM_NIMP (m) && SCM_TYP16 (m) == scm_tc16_macro, - m, - SCM_ARG1, - s_macro_transformer); + SCM_VALIDATE_SMOB(1,m,macro); return SCM_CLOSUREP (SCM_CDR (m)) ? SCM_CDR (m) : SCM_BOOL_F; } +#undef FUNC_NAME SCM -scm_make_synt (name, macroizer, fcn) - const char *name; - SCM (*macroizer) (); - SCM (*fcn) (); +scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() ) { SCM symcell = scm_sysintern (name, SCM_UNDEFINED); long tmp = ((((SCM_CELLPTR) (SCM_CAR (symcell))) - scm_heap_org) << 8); diff --git a/libguile/mallocs.c b/libguile/mallocs.c index a832bdb1c..ebc294d36 100644 --- a/libguile/mallocs.c +++ b/libguile/mallocs.c @@ -1,6 +1,5 @@ -/* classes: src_files */ - -/* Copyright (C) 1995, 1997, 1998 Free Software Foundation, Inc. +/* classes: src_files + * Copyright (C) 1995, 1997, 1998 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -17,6 +16,10 @@ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, * Boston, MA 02111-1307 USA */ +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + + #include @@ -38,11 +41,8 @@ -static scm_sizet fmalloc SCM_P ((SCM ptr)); - static scm_sizet -fmalloc(ptr) - SCM ptr; +fmalloc(SCM ptr) { if (SCM_MALLOCDATA (ptr)) free (SCM_MALLOCDATA (ptr)); @@ -50,13 +50,8 @@ fmalloc(ptr) } -static int prinmalloc SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - static int -prinmalloc (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +prinmalloc (SCM exp,SCM port,scm_print_state *pstate) { scm_puts("#h_name, (scm_sizet) strlen (entry->h_name), 0); @@ -268,6 +271,7 @@ scm_gethost (name) ve[4] = lst; return ans; } +#undef FUNC_NAME /* In all subsequent getMUMBLE functions, when we're called with no @@ -280,11 +284,10 @@ scm_gethost (name) operation?), but it seems to work okay. We'll see. */ #if defined(HAVE_GETNETENT) && defined(HAVE_GETNETBYNAME) && defined(HAVE_GETNETBYADDR) -SCM_PROC (s_getnet, "getnet", 0, 1, 0, scm_getnet); - -SCM -scm_getnet (name) - SCM name; +GUILE_PROC (scm_getnet, "getnet", 0, 1, 0, + (SCM name), +"") +#define FUNC_NAME s_scm_getnet { SCM ans; SCM *ve; @@ -299,7 +302,7 @@ scm_getnet (name) if (! entry) { if (errno) - scm_syserror (s_getnet); + SCM_SYSERROR; else return SCM_BOOL_F; } @@ -312,11 +315,11 @@ scm_getnet (name) else { unsigned long netnum; - netnum = scm_num2ulong (name, (char *) SCM_ARG1, s_getnet); + netnum = scm_num2ulong (name, (char *) SCM_ARG1, FUNC_NAME); entry = getnetbyaddr (netnum, AF_INET); } if (!entry) - scm_syserror_msg (s_getnet, "no such network %s", + scm_syserror_msg (FUNC_NAME, "no such network %s", scm_listify (name, SCM_UNDEFINED), errno); ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0); ve[1] = scm_makfromstrs (-1, entry->n_aliases); @@ -324,14 +327,14 @@ scm_getnet (name) ve[3] = scm_ulong2num (entry->n_net + 0L); return ans; } +#undef FUNC_NAME #endif #ifdef HAVE_GETPROTOENT -SCM_PROC (s_getproto, "getproto", 0, 1, 0, scm_getproto); - -SCM -scm_getproto (name) - SCM name; +GUILE_PROC (scm_getproto, "getproto", 0, 1, 0, + (SCM name), +"") +#define FUNC_NAME s_scm_getproto { SCM ans; SCM *ve; @@ -346,7 +349,7 @@ scm_getproto (name) if (! entry) { if (errno) - scm_syserror (s_getproto); + SCM_SYSERROR; else return SCM_BOOL_F; } @@ -359,24 +362,22 @@ scm_getproto (name) else { unsigned long protonum; - protonum = scm_num2ulong (name, (char *) SCM_ARG1, s_getproto); + protonum = SCM_NUM2ULONG (1,name); entry = getprotobynumber (protonum); } if (!entry) - scm_syserror_msg (s_getproto, "no such protocol %s", + SCM_SYSERROR_MSG ("no such protocol %s", scm_listify (name, SCM_UNDEFINED), errno); ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0); ve[1] = scm_makfromstrs (-1, entry->p_aliases); ve[2] = SCM_MAKINUM (entry->p_proto + 0L); return ans; } +#undef FUNC_NAME #endif -static SCM scm_return_entry SCM_P ((struct servent *entry)); - static SCM -scm_return_entry (entry) - struct servent *entry; +scm_return_entry (struct servent *entry) { SCM ans; SCM *ve; @@ -391,12 +392,10 @@ scm_return_entry (entry) } #ifdef HAVE_GETSERVENT -SCM_PROC (s_getserv, "getserv", 0, 2, 0, scm_getserv); - -SCM -scm_getserv (name, proto) - SCM name; - SCM proto; +GUILE_PROC (scm_getserv, "getserv", 0, 2, 0, + (SCM name, SCM proto), +"") +#define FUNC_NAME s_scm_getserv { struct servent *entry; if (SCM_UNBNDP (name)) @@ -406,13 +405,13 @@ scm_getserv (name, proto) if (!entry) { if (errno) - scm_syserror (s_getserv); + SCM_SYSERROR; else return SCM_BOOL_F; } return scm_return_entry (entry); } - SCM_ASSERT (SCM_NIMP (proto) && SCM_ROSTRINGP (proto), proto, SCM_ARG2, s_getserv); + SCM_VALIDATE_ROSTRING(2,proto); SCM_COERCE_SUBSTR (proto); if (SCM_NIMP (name) && SCM_ROSTRINGP (name)) { @@ -421,22 +420,22 @@ scm_getserv (name, proto) } else { - SCM_ASSERT (SCM_INUMP (name), name, SCM_ARG1, s_getserv); + SCM_VALIDATE_INT(1,name); entry = getservbyport (htons (SCM_INUM (name)), SCM_ROCHARS (proto)); } if (!entry) - scm_syserror_msg (s_getserv, "no such service %s", - scm_listify (name, SCM_UNDEFINED), errno); + SCM_SYSERROR_MSG("no such service %s", + scm_listify (name, SCM_UNDEFINED), errno); return scm_return_entry (entry); } +#undef FUNC_NAME #endif #if defined(HAVE_SETHOSTENT) && defined(HAVE_ENDHOSTENT) -SCM_PROC (s_sethost, "sethost", 0, 1, 0, scm_sethost); - -SCM -scm_sethost (arg) - SCM arg; +GUILE_PROC (scm_sethost, "sethost", 0, 1, 0, + (SCM arg), +"") +#define FUNC_NAME s_scm_sethost { if (SCM_UNBNDP (arg)) endhostent (); @@ -444,14 +443,14 @@ scm_sethost (arg) sethostent (SCM_NFALSEP (arg)); return SCM_UNSPECIFIED; } +#undef FUNC_NAME #endif #if defined(HAVE_SETNETENT) && defined(HAVE_ENDNETENT) -SCM_PROC (s_setnet, "setnet", 0, 1, 0, scm_setnet); - -SCM -scm_setnet (arg) - SCM arg; +GUILE_PROC (scm_setnet, "setnet", 0, 1, 0, + (SCM arg), +"") +#define FUNC_NAME s_scm_setnet { if (SCM_UNBNDP (arg)) endnetent (); @@ -459,14 +458,14 @@ scm_setnet (arg) setnetent (SCM_NFALSEP (arg)); return SCM_UNSPECIFIED; } +#undef FUNC_NAME #endif #if defined(HAVE_SETPROTOENT) && defined(HAVE_ENDPROTOENT) -SCM_PROC (s_setproto, "setproto", 0, 1, 0, scm_setproto); - -SCM -scm_setproto (arg) - SCM arg; +GUILE_PROC (scm_setproto, "setproto", 0, 1, 0, + (SCM arg), +"") +#define FUNC_NAME s_scm_setproto { if (SCM_UNBNDP (arg)) endprotoent (); @@ -474,14 +473,14 @@ scm_setproto (arg) setprotoent (SCM_NFALSEP (arg)); return SCM_UNSPECIFIED; } +#undef FUNC_NAME #endif #if defined(HAVE_SETSERVENT) && defined(HAVE_ENDSERVENT) -SCM_PROC (s_setserv, "setserv", 0, 1, 0, scm_setserv); - -SCM -scm_setserv (arg) - SCM arg; +GUILE_PROC (scm_setserv, "setserv", 0, 1, 0, + (SCM arg), +"") +#define FUNC_NAME s_scm_setserv { if (SCM_UNBNDP (arg)) endservent (); @@ -489,6 +488,7 @@ scm_setserv (arg) setservent (SCM_NFALSEP (arg)); return SCM_UNSPECIFIED; } +#undef FUNC_NAME #endif diff --git a/libguile/numbers.c b/libguile/numbers.c index 992b3ddb7..8330b37fe 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -48,6 +52,7 @@ #include "feature.h" #include "smob.h" +#include "scm_validate.h" #include "numbers.h" #define DIGITS '0':case '1':case '2':case '3':case '4':\ @@ -90,11 +95,10 @@ -SCM_PROC (s_exact_p, "exact?", 1, 0, 0, scm_exact_p); - -SCM -scm_exact_p (x) - SCM x; +GUILE_PROC (scm_exact_p, "exact?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_exact_p { if (SCM_INUMP (x)) return SCM_BOOL_T; @@ -104,42 +108,43 @@ scm_exact_p (x) #endif return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_odd_p, "odd?", 1, 0, 0, scm_odd_p); - -SCM -scm_odd_p (n) - SCM n; +GUILE_PROC (scm_odd_p, "odd?", 1, 0, 0, + (SCM n), +"") +#define FUNC_NAME s_scm_odd_p { #ifdef SCM_BIGDIG if (SCM_NINUMP (n)) { - SCM_ASSERT (SCM_NIMP (n) && SCM_BIGP (n), n, SCM_ARG1, s_odd_p); - return (1 & SCM_BDIGITS (n)[0]) ? SCM_BOOL_T : SCM_BOOL_F; + SCM_VALIDATE_BIGINT(1,n); + return SCM_BOOL(1 & SCM_BDIGITS (n)[0]); } #else - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_odd_p); + SCM_VALIDATE_INT(1,n); #endif - return (4 & (int) n) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(4 & (int) n); } +#undef FUNC_NAME -SCM_PROC (s_even_p, "even?", 1, 0, 0, scm_even_p); - -SCM -scm_even_p (n) - SCM n; +GUILE_PROC (scm_even_p, "even?", 1, 0, 0, + (SCM n), +"") +#define FUNC_NAME s_scm_even_p { #ifdef SCM_BIGDIG if (SCM_NINUMP (n)) { - SCM_ASSERT (SCM_NIMP (n) && SCM_BIGP (n), n, SCM_ARG1, s_even_p); - return (1 & SCM_BDIGITS (n)[0]) ? SCM_BOOL_F : SCM_BOOL_T; + SCM_VALIDATE_BIGINT(1,n); + return SCM_NEGATE_BOOL(1 & SCM_BDIGITS (n)[0]); } #else - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_even_p); + SCM_VALIDATE_INT(1,n); #endif - return (4 & (int) n) ? SCM_BOOL_F : SCM_BOOL_T; + return SCM_NEGATE_BOOL(4 & (int) n); } +#undef FUNC_NAME SCM_GPROC (s_abs, "abs", 1, 0, 0, scm_abs, g_abs); @@ -516,210 +521,217 @@ scm_lcm (n1, n2) #endif #ifndef scm_long2num -SCM_PROC1 (s_logand, "logand", scm_tc7_asubr, scm_logand); - -SCM -scm_logand (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC1 (scm_logand, "logand", scm_tc7_asubr, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logand { + int i1, i2; if (SCM_UNBNDP (n2)) { if (SCM_UNBNDP (n1)) return SCM_MAKINUM (-1); return n1; } - return scm_ulong2num (scm_num2ulong (n1, (char *) SCM_ARG1, s_logand) - & scm_num2ulong (n2, (char *) SCM_ARG2, s_logand)); + SCM_VALIDATE_INT_COPY(1,n1,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return scm_ulong2num (i1 & i2); } +#undef FUNC_NAME -SCM_PROC1 (s_logior, "logior", scm_tc7_asubr, scm_logior); - -SCM -scm_logior (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC1 (scm_logior, "logior", scm_tc7_asubr, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logior { + int i1, i2; if (SCM_UNBNDP (n2)) { if (SCM_UNBNDP (n1)) return SCM_INUM0; return n1; } - return scm_ulong2num (scm_num2ulong (n1, (char *) SCM_ARG1, s_logior) - | scm_num2ulong (n2, (char *) SCM_ARG2, s_logior)); + SCM_VALIDATE_INT_COPY(1,n1,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return scm_ulong2num (i1 | i2); } +#undef FUNC_NAME -SCM_PROC1 (s_logxor, "logxor", scm_tc7_asubr, scm_logxor); - -SCM -scm_logxor (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC1 (scm_logxor, "logxor", scm_tc7_asubr, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logxor { + int i1, i2; if (SCM_UNBNDP (n2)) { if (SCM_UNBNDP (n1)) return SCM_INUM0; return n1; } - return scm_ulong2num (scm_num2ulong (n1, (char *) SCM_ARG1, s_logxor) - ^ scm_num2ulong (n2, (char *) SCM_ARG2, s_logxor)); + SCM_VALIDATE_INT_COPY(1,n1,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return scm_ulong2num (i1 ^ i2); } +#undef FUNC_NAME -SCM_PROC (s_logtest, "logtest", 2, 0, 0, scm_logtest); - -SCM -scm_logtest (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC (scm_logtest, "logtest", 2, 0, 0, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logtest { - return ((scm_num2ulong (n1, (char *) SCM_ARG1, s_logtest) - & scm_num2ulong (n2, (char *) SCM_ARG2, s_logtest)) - ? SCM_BOOL_T : SCM_BOOL_F); + int i1, i2; + SCM_VALIDATE_INT_COPY(1,n1,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return SCM_BOOL(i1 & i2); } +#undef FUNC_NAME -SCM_PROC (s_logbit_p, "logbit?", 2, 0, 0, scm_logbit_p); - -SCM -scm_logbit_p (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC (scm_logbit_p, "logbit?", 2, 0, 0, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logbit_p { - return (((1 << scm_num2long (n1, (char *) SCM_ARG1, s_logtest)) - & scm_num2ulong (n2, (char *) SCM_ARG2, s_logtest)) - ? SCM_BOOL_T : SCM_BOOL_F); + int i1, i2; + SCM_VALIDATE_INT_COPY(1,n1,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return SCM_BOOL((1 << i1) & i2); } +#undef FUNC_NAME #else -SCM_PROC1 (s_logand, "logand", scm_tc7_asubr, scm_logand); - -SCM -scm_logand (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC1 (scm_logand, "logand", scm_tc7_asubr, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logand { + int i1, i2; if (SCM_UNBNDP (n2)) { if (SCM_UNBNDP (n1)) return SCM_MAKINUM (-1); return n1; } - return SCM_MAKINUM (SCM_INUM (n1) & SCM_INUM (n2)); + SCM_VALIDATE_INT_COPY(1,n1,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return SCM_MAKINUM (i1 & i2); } +#undef FUNC_NAME -SCM_PROC1 (s_logior, "logior", scm_tc7_asubr, scm_logior); - -SCM -scm_logior (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC1 (scm_logior, "logior", scm_tc7_asubr, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logior { + int i1, i2; if (SCM_UNBNDP (n2)) { if (SCM_UNBNDP (n1)) return SCM_INUM0; return n1; } - return SCM_MAKINUM (SCM_INUM (n1) | SCM_INUM (n2)); + SCM_VALIDATE_INT_COPY(1,n1,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return SCM_MAKINUM (i1 | i2); } +#undef FUNC_NAME -SCM_PROC1 (s_logxor, "logxor", scm_tc7_asubr, scm_logxor); - -SCM -scm_logxor (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC1 (scm_logxor, "logxor", scm_tc7_asubr, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logxor { + int i1, i2; if (SCM_UNBNDP (n2)) { if (SCM_UNBNDP (n1)) return SCM_INUM0; return n1; } - return SCM_MAKINUM (SCM_INUM (n1) ^ SCM_INUM (n2)); + SCM_VALIDATE_INT_COPY(1,n1,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return SCM_MAKINUM (i1 ^ i2); } +#undef FUNC_NAME -SCM_PROC (s_logtest, "logtest", 2, 0, 0, scm_logtest); - -SCM -scm_logtest (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC (scm_logtest, "logtest", 2, 0, 0, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logtest { - SCM_ASSERT (SCM_INUMP (n1), n1, SCM_ARG1, s_logtest); - SCM_ASSERT (SCM_INUMP (n2), n2, SCM_ARG2, s_logtest); - return (SCM_INUM (n1) & SCM_INUM (n2)) ? SCM_BOOL_T : SCM_BOOL_F; + int i1, i2; + SCM_VALIDATE_INT_COPY(1,n1,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return SCM_BOOL(i1 & i2); } +#undef FUNC_NAME -SCM_PROC (s_logbit_p, "logbit?", 2, 0, 0, scm_logbit_p); - -SCM -scm_logbit_p (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC (scm_logbit_p, "logbit?", 2, 0, 0, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logbit_p { - SCM_ASSERT (SCM_INUMP (n1) && SCM_INUM (n1) >= 0, n1, SCM_ARG1, s_logbit_p); - SCM_ASSERT (SCM_INUMP (n2), n2, SCM_ARG2, s_logbit_p); - return ((1 << SCM_INUM (n1)) & SCM_INUM (n2)) ? SCM_BOOL_T : SCM_BOOL_F; + int i1, i2; + SCM_VALIDATE_INT_MIN_COPY(1,n1,0,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return SCM_BOOL((1 << i1) & i2); } +#undef FUNC_NAME #endif -SCM_PROC (s_lognot, "lognot", 1, 0, 0, scm_lognot); - -SCM -scm_lognot (n) - SCM n; +GUILE_PROC (scm_lognot, "lognot", 1, 0, 0, + (SCM n), +"") +#define FUNC_NAME s_scm_lognot { - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_lognot); + SCM_VALIDATE_INT(1,n); return scm_difference (SCM_MAKINUM (-1L), n); } +#undef FUNC_NAME -SCM_PROC (s_integer_expt, "integer-expt", 2, 0, 0, scm_integer_expt); - -SCM -scm_integer_expt (z1, z2) - SCM z1; - SCM z2; +GUILE_PROC (scm_integer_expt, "integer-expt", 2, 0, 0, + (SCM z1, SCM z2), +"") +#define FUNC_NAME s_scm_integer_expt { SCM acc = SCM_MAKINUM (1L); + int i2; #ifdef SCM_BIGDIG if (SCM_INUM0 == z1 || acc == z1) return z1; else if (SCM_MAKINUM (-1L) == z1) return SCM_BOOL_F == scm_even_p (z2) ? z1 : acc; #endif - SCM_ASSERT (SCM_INUMP (z2), z2, SCM_ARG2, s_integer_expt); - z2 = SCM_INUM (z2); - if (z2 < 0) + SCM_VALIDATE_INT_COPY(2,z2,i2); + if (i2 < 0) { - z2 = -z2; + i2 = -i2; z1 = scm_divide (z1, SCM_UNDEFINED); } while (1) { - if (0 == z2) + if (0 == i2) return acc; - if (1 == z2) + if (1 == i2) return scm_product (acc, z1); - if (z2 & 1) + if (i2 & 1) acc = scm_product (acc, z1); z1 = scm_product (z1, z1); - z2 >>= 1; + i2 >>= 1; } } +#undef FUNC_NAME -SCM_PROC (s_ash, "ash", 2, 0, 0, scm_ash); - -SCM -scm_ash (n, cnt) - SCM n; - SCM cnt; +GUILE_PROC (scm_ash, "ash", 2, 0, 0, + (SCM n, SCM cnt), +"") +#define FUNC_NAME s_scm_ash { + /* GJB:FIXME:: what is going on here? */ SCM res = SCM_INUM (n); - SCM_ASSERT (SCM_INUMP (cnt), cnt, SCM_ARG2, s_ash); + SCM_VALIDATE_INT(2,cnt); #ifdef SCM_BIGDIG if (cnt < 0) { @@ -733,30 +745,30 @@ scm_ash (n, cnt) else return scm_product (n, scm_integer_expt (SCM_MAKINUM (2), cnt)); #else - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_ash); + SCM_VALIDATE_INT(1,n) cnt = SCM_INUM (cnt); if (cnt < 0) return SCM_MAKINUM (SCM_SRS (res, -cnt)); res = SCM_MAKINUM (res << cnt); if (SCM_INUM (res) >> cnt != SCM_INUM (n)) - scm_num_overflow (s_ash); + scm_num_overflow (FUNC_NAME); return res; #endif } +#undef FUNC_NAME -SCM_PROC (s_bit_extract, "bit-extract", 3, 0, 0, scm_bit_extract); - -SCM -scm_bit_extract (n, start, end) - SCM n; - SCM start; - SCM end; +/* GJB:FIXME: do not use SCMs as integers! */ +GUILE_PROC (scm_bit_extract, "bit-extract", 3, 0, 0, + (SCM n, SCM start, SCM end), +"") +#define FUNC_NAME s_scm_bit_extract { - SCM_ASSERT (SCM_INUMP (start), start, SCM_ARG2, s_bit_extract); - SCM_ASSERT (SCM_INUMP (end), end, SCM_ARG3, s_bit_extract); + SCM_VALIDATE_INT(1,n); + SCM_VALIDATE_INT_MIN(2,start,0); + SCM_VALIDATE_INT_MIN(3,end,0); start = SCM_INUM (start); end = SCM_INUM (end); - SCM_ASSERT (end >= start, SCM_MAKINUM (end), SCM_OUTOFRANGE, s_bit_extract); + SCM_ASSERT (end >= start, SCM_MAKINUM (end), SCM_OUTOFRANGE, FUNC_NAME); #ifdef SCM_BIGDIG if (SCM_NINUMP (n)) return @@ -765,19 +777,20 @@ scm_bit_extract (n, start, end) SCM_MAKINUM (1L)), scm_ash (n, SCM_MAKINUM (-start))); #else - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_bit_extract); + SCM_VALIDATE_INT(1,n); #endif return SCM_MAKINUM ((SCM_INUM (n) >> start) & ((1L << (end - start)) - 1)); } +#undef FUNC_NAME static const char scm_logtab[] = { 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4 }; -SCM_PROC (s_logcount, "logcount", 1, 0, 0, scm_logcount); -SCM -scm_logcount (n) - SCM n; +GUILE_PROC (scm_logcount, "logcount", 1, 0, 0, + (SCM n), +"") +#define FUNC_NAME s_scm_logcount { register unsigned long c = 0; register long nn; @@ -786,7 +799,7 @@ scm_logcount (n) { scm_sizet i; SCM_BIGDIG *ds, d; - SCM_ASSERT (SCM_NIMP (n) && SCM_BIGP (n), n, SCM_ARG1, s_logcount); + SCM_VALIDATE_BIGINT(1,n); if (SCM_BIGSIGN (n)) return scm_logcount (scm_difference (SCM_MAKINUM (-1L), n)); ds = SCM_BDIGITS (n); @@ -796,7 +809,7 @@ scm_logcount (n) return SCM_MAKINUM (c); } #else - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_logcount); + SCM_VALIDATE_INT(1,n); #endif if ((nn = SCM_INUM (n)) < 0) nn = -1 - nn; @@ -804,15 +817,17 @@ scm_logcount (n) c += scm_logtab[15 & nn]; return SCM_MAKINUM (c); } +#undef FUNC_NAME + static const char scm_ilentab[] = { 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4 }; -SCM_PROC (s_integer_length, "integer-length", 1, 0, 0, scm_integer_length); -SCM -scm_integer_length (n) - SCM n; +GUILE_PROC (scm_integer_length, "integer-length", 1, 0, 0, + (SCM n), +"") +#define FUNC_NAME s_scm_integer_length { register unsigned long c = 0; register long nn; @@ -821,7 +836,7 @@ scm_integer_length (n) if (SCM_NINUMP (n)) { SCM_BIGDIG *ds, d; - SCM_ASSERT (SCM_NIMP (n) && SCM_BIGP (n), n, SCM_ARG1, s_integer_length); + SCM_VALIDATE_BIGINT(1,n); if (SCM_BIGSIGN (n)) return scm_integer_length (scm_difference (SCM_MAKINUM (-1L), n)); ds = SCM_BDIGITS (n); @@ -834,7 +849,7 @@ scm_integer_length (n) return SCM_MAKINUM (c - 4 + l); } #else - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_integer_length); + SCM_VALIDATE_INT(1,n); #endif if ((nn = SCM_INUM (n)) < 0) nn = -1 - nn; @@ -845,15 +860,14 @@ scm_integer_length (n) } return SCM_MAKINUM (c - 4 + l); } +#undef FUNC_NAME #ifdef SCM_BIGDIG static const char s_bignum[] = "bignum"; SCM -scm_mkbig (nlen, sign) - scm_sizet nlen; - int sign; +scm_mkbig (scm_sizet nlen, int sign) { SCM v = nlen; /* Cast to SCM to avoid signed/unsigned comparison warnings. */ @@ -870,9 +884,7 @@ scm_mkbig (nlen, sign) SCM -scm_big2inum (b, l) - SCM b; - scm_sizet l; +scm_big2inum (SCM b, scm_sizet l) { unsigned long num = 0; SCM_BIGDIG *tmp = SCM_BDIGITS (b); @@ -892,9 +904,7 @@ scm_big2inum (b, l) static const char s_adjbig[] = "scm_adjbig"; SCM -scm_adjbig (b, nlen) - SCM b; - scm_sizet nlen; +scm_adjbig (SCM b, scm_sizet nlen) { scm_sizet nsiz = nlen; if (((nsiz << 16) >> 16) != nlen) @@ -918,8 +928,7 @@ scm_adjbig (b, nlen) SCM -scm_normbig (b) - SCM b; +scm_normbig (SCM b) { #ifndef _UNICOS scm_sizet nlen = SCM_NUMDIGS (b); @@ -940,9 +949,7 @@ scm_normbig (b) SCM -scm_copybig (b, sign) - SCM b; - int sign; +scm_copybig (SCM b, int sign) { scm_sizet i = SCM_NUMDIGS (b); SCM ans = scm_mkbig (i, sign); @@ -955,8 +962,7 @@ scm_copybig (b, sign) SCM -scm_long2big (n) - long n; +scm_long2big (long n) { scm_sizet i = 0; SCM_BIGDIG *digits; @@ -975,8 +981,7 @@ scm_long2big (n) #ifdef HAVE_LONG_LONGS SCM -scm_long_long2big (n) - long_long n; +scm_long_long2big (long_long n) { scm_sizet i; SCM_BIGDIG *digits; @@ -1015,8 +1020,7 @@ scm_long_long2big (n) SCM -scm_2ulong2big (np) - unsigned long *np; +scm_2ulong2big (unsigned long *np) { unsigned long n; scm_sizet i; @@ -1044,8 +1048,7 @@ scm_2ulong2big (np) SCM -scm_ulong2big (n) - unsigned long n; +scm_ulong2big (unsigned long n) { scm_sizet i = 0; SCM_BIGDIG *digits; @@ -1062,9 +1065,7 @@ scm_ulong2big (n) int -scm_bigcomp (x, y) - SCM x; - SCM y; +scm_bigcomp (SCM x, SCM y) { int xsign = SCM_BIGSIGN (x); int ysign = SCM_BIGSIGN (y); @@ -1105,8 +1106,7 @@ scm_bigcomp (x, y) long -scm_pseudolong (x) - long x; +scm_pseudolong (long x) { union { @@ -1130,9 +1130,7 @@ scm_pseudolong (x) void -scm_longdigs (x, digs) - long x; - SCM_BIGDIG digs[]; +scm_longdigs (long x, SCM_BIGDIG digs[]) { scm_sizet i = 0; if (x < 0) @@ -1148,12 +1146,7 @@ scm_longdigs (x, digs) SCM -scm_addbig (x, nx, xsgn, bigy, sgny) - SCM_BIGDIG *x; - scm_sizet nx; - int xsgn; - SCM bigy; - int sgny; +scm_addbig (SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int sgny) { /* Assumes nx <= SCM_NUMDIGS(bigy) */ /* Assumes xsgn and sgny scm_equal either 0 or 0x0100 */ @@ -1238,12 +1231,7 @@ scm_addbig (x, nx, xsgn, bigy, sgny) SCM -scm_mulbig (x, nx, y, ny, sgn) - SCM_BIGDIG *x; - scm_sizet nx; - SCM_BIGDIG *y; - scm_sizet ny; - int sgn; +scm_mulbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn) { scm_sizet i = 0, j = nx + ny; unsigned long n = 0; @@ -1299,11 +1287,7 @@ scm_divbigdig (SCM_BIGDIG * ds, SCM -scm_divbigint (x, z, sgn, mode) - SCM x; - long z; - int sgn; - int mode; +scm_divbigint (SCM x, long z, int sgn, int mode) { if (z < 0) z = -z; @@ -1336,13 +1320,7 @@ scm_divbigint (x, z, sgn, mode) SCM -scm_divbigbig (x, nx, y, ny, sgn, modes) - SCM_BIGDIG *x; - scm_sizet nx; - SCM_BIGDIG *y; - scm_sizet ny; - int sgn; - int modes; +scm_divbigbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn, int modes) { /* modes description 0 remainder @@ -1551,12 +1529,8 @@ static const double fx[] = -static scm_sizet idbl2str SCM_P ((double f, char *a)); - static scm_sizet -idbl2str (f, a) - double f; - char *a; +idbl2str (double f, char *a) { int efmt, dpt, d, i, wp = scm_dblprec; scm_sizet ch = 0; @@ -1695,12 +1669,8 @@ idbl2str (f, a) } -static scm_sizet iflo2str SCM_P ((SCM flt, char *str)); - static scm_sizet -iflo2str (flt, str) - SCM flt; - char *str; +iflo2str (SCM flt, char *str) { scm_sizet i; #ifdef SCM_SINGLES @@ -1721,12 +1691,11 @@ iflo2str (flt, str) #endif /* SCM_FLOATS */ /* convert a long to a string (unterminated). returns the number of - characters in the result. */ + characters in the result. + rad is output base + p is destination: worst case (base 2) is SCM_INTBUFLEN */ scm_sizet -scm_iint2str (num, rad, p) - long num; - int rad; /* output base. */ - char *p; /* destination: worst case (base 2) is SCM_INTBUFLEN. */ +scm_iint2str (long num, int rad, char *p) { scm_sizet j = 1; scm_sizet i; @@ -1757,12 +1726,8 @@ scm_iint2str (num, rad, p) #ifdef SCM_BIGDIG -static SCM big2str SCM_P ((SCM b, register unsigned int radix)); - static SCM -big2str (b, radix) - SCM b; - register unsigned int radix; +big2str (SCM b, unsigned int radix) { SCM t = scm_copybig (b, 0); /* sign of temp doesn't matter */ register SCM_BIGDIG *ds = SCM_BDIGITS (t); @@ -1810,21 +1775,13 @@ big2str (b, radix) #endif -SCM_PROC (s_number_to_string, "number->string", 1, 1, 0, scm_number_to_string); - -SCM -scm_number_to_string (x, radix) - SCM x; - SCM radix; +GUILE_PROC (scm_number_to_string, "number->string", 1, 1, 0, + (SCM x, SCM radix), +"") +#define FUNC_NAME s_scm_number_to_string { - if (SCM_UNBNDP (radix)) - radix = SCM_MAKINUM (10L); - else - { - SCM_ASSERT (SCM_INUMP (radix), radix, SCM_ARG2, s_number_to_string); - SCM_ASSERT (SCM_INUM (radix) >= 2, radix, SCM_OUTOFRANGE, - s_number_to_string); - } + int base; + SCM_VALIDATE_INT_MIN_DEF_COPY(2,radix,2,10,base); #ifdef SCM_FLOATS if (SCM_NINUMP (x)) { @@ -1832,12 +1789,12 @@ scm_number_to_string (x, radix) #ifdef SCM_BIGDIG SCM_ASRTGO (SCM_NIMP (x), badx); if (SCM_BIGP (x)) - return big2str (x, (unsigned int) SCM_INUM (radix)); + return big2str (x, (unsigned int) base); #ifndef SCM_RECKLESS if (!(SCM_INEXP (x))) { badx: - scm_wta (x, (char *) SCM_ARG1, s_number_to_string); + scm_wta (x, (char *) SCM_ARG1, FUNC_NAME); } #endif #else @@ -1852,7 +1809,7 @@ scm_number_to_string (x, radix) { SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_number_to_string); - return big2str (x, (unsigned int) SCM_INUM (radix)); + return big2str (x, (unsigned int) base); } #else SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_number_to_string); @@ -1862,21 +1819,19 @@ scm_number_to_string (x, radix) char num_buf[SCM_INTBUFLEN]; return scm_makfromstr (num_buf, scm_iint2str (SCM_INUM (x), - (int) SCM_INUM (radix), + base, num_buf), 0); } } +#undef FUNC_NAME /* These print routines are stubbed here so that scm_repl.c doesn't need SCM_FLOATS or SCM_BIGDIGs conditionals */ int -scm_floprint (sexp, port, pstate) - SCM sexp; - SCM port; - scm_print_state *pstate; +scm_floprint (SCM sexp, SCM port, scm_print_state *pstate) { #ifdef SCM_FLOATS char num_buf[SCM_FLOBUFLEN]; @@ -1890,10 +1845,7 @@ scm_floprint (sexp, port, pstate) int -scm_bigprint (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +scm_bigprint (SCM exp, SCM port, scm_print_state *pstate) { #ifdef SCM_BIGDIG exp = big2str (exp, (unsigned int) 10); @@ -1907,13 +1859,8 @@ scm_bigprint (exp, port, pstate) /*** STRINGS -> NUMBERS ***/ -static SCM scm_small_istr2int SCM_P ((char *str, long len, long radix)); - static SCM -scm_small_istr2int (str, len, radix) - char *str; - long len; - long radix; +scm_small_istr2int (char *str, long len, long radix) { register long n = 0, ln; register int c; @@ -1977,10 +1924,7 @@ scm_small_istr2int (str, len, radix) SCM -scm_istr2int (str, len, radix) - char *str; - long len; - long radix; +scm_istr2int (char *str, long len, long radix) { scm_sizet j; register scm_sizet k, blen = 1; @@ -2074,10 +2018,7 @@ scm_istr2int (str, len, radix) #ifdef SCM_FLOATS SCM -scm_istr2flo (str, len, radix) - char *str; - long len; - long radix; +scm_istr2flo (char *str, long len, long radix) { register int c, i = 0; double lead_sgn; @@ -2366,10 +2307,7 @@ scm_istr2flo (str, len, radix) SCM -scm_istring2number (str, len, radix) - char *str; - long len; - long radix; +scm_istring2number (char *str, long len, long radix) { int i = 0; char ex = 0; @@ -2439,37 +2377,27 @@ scm_istring2number (str, len, radix) } -SCM_PROC (s_string_to_number, "string->number", 1, 1, 0, scm_string_to_number); - -SCM -scm_string_to_number (str, radix) - SCM str; - SCM radix; +GUILE_PROC (scm_string_to_number, "string->number", 1, 1, 0, + (SCM str, SCM radix), +"") +#define FUNC_NAME s_scm_string_to_number { SCM answer; - if (SCM_UNBNDP (radix)) - radix = SCM_MAKINUM (10L); - else - { - SCM_ASSERT (SCM_INUMP (radix), radix, SCM_ARG2, s_string_to_number); - SCM_ASSERT (SCM_INUM (radix) >= 2, radix, SCM_OUTOFRANGE, - s_number_to_string); - } - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), - str, SCM_ARG1, s_string_to_number); + int base; + SCM_VALIDATE_ROSTRING(1,str); + SCM_VALIDATE_INT_MIN_DEF_COPY(2,radix,2,10,base); answer = scm_istring2number (SCM_ROCHARS (str), SCM_ROLENGTH (str), - SCM_INUM (radix)); + base); return scm_return_first (answer, str); } +#undef FUNC_NAME /*** END strs->nums ***/ #ifdef SCM_FLOATS SCM -scm_makdbl (x, y) - double x; - double y; +scm_makdbl (double x, double y) { SCM z; if ((y == 0.0) && (x == 0.0)) @@ -2505,9 +2433,7 @@ scm_makdbl (x, y) SCM -scm_bigequal (x, y) - SCM x; - SCM y; +scm_bigequal (SCM x, SCM y) { #ifdef SCM_BIGDIG if (0 == scm_bigcomp (x, y)) @@ -2519,9 +2445,7 @@ scm_bigequal (x, y) SCM -scm_floequal (x, y) - SCM x; - SCM y; +scm_floequal (SCM x, SCM y) { #ifdef SCM_FLOATS if (SCM_REALPART (x) != SCM_REALPART (y)) @@ -2535,12 +2459,12 @@ scm_floequal (x, y) -SCM_PROC (s_number_p, "number?", 1, 0, 0, scm_number_p); -SCM_PROC (s_complex_p, "complex?", 1, 0, 0, scm_number_p); +SCM_REGISTER_PROC (s_number_p, "number?", 1, 0, 0, scm_number_p); -SCM -scm_number_p (x) - SCM x; +GUILE_PROC (scm_number_p, "complex?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_number_p { if (SCM_INUMP (x)) return SCM_BOOL_T; @@ -2555,16 +2479,18 @@ scm_number_p (x) #endif return SCM_BOOL_F; } +#undef FUNC_NAME #ifdef SCM_FLOATS -SCM_PROC (s_real_p, "real?", 1, 0, 0, scm_real_p); -SCM_PROC (s_rational_p, "rational?", 1, 0, 0, scm_real_p); +SCM_REGISTER_PROC (s_real_p, "real?", 1, 0, 0, scm_real_p); -SCM -scm_real_p (x) - SCM x; + +GUILE_PROC (scm_real_p, "rational?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_real_p { if (SCM_INUMP (x)) return SCM_BOOL_T; @@ -2578,14 +2504,14 @@ scm_real_p (x) #endif return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_int_p, "integer?", 1, 0, 0, scm_integer_p); - -SCM -scm_integer_p (x) - SCM x; +GUILE_PROC (scm_integer_p, "integer?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_integer_p { double r; if (SCM_INUMP (x)) @@ -2605,16 +2531,16 @@ scm_integer_p (x) return SCM_BOOL_T; return SCM_BOOL_F; } +#undef FUNC_NAME #endif /* SCM_FLOATS */ -SCM_PROC (s_inexact_p, "inexact?", 1, 0, 0, scm_inexact_p); - -SCM -scm_inexact_p (x) - SCM x; +GUILE_PROC (scm_inexact_p, "inexact?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_inexact_p { #ifdef SCM_FLOATS if (SCM_NIMP (x) && SCM_INEXP (x)) @@ -2622,6 +2548,7 @@ scm_inexact_p (x) #endif return SCM_BOOL_F; } +#undef FUNC_NAME @@ -2840,39 +2767,36 @@ scm_less_p (x, y) } -SCM_PROC1 (s_gr_p, ">", scm_tc7_rpsubr, scm_gr_p); - -SCM -scm_gr_p (x, y) - SCM x; - SCM y; +GUILE_PROC1 (scm_gr_p, ">", scm_tc7_rpsubr, + (SCM x, SCM y), +"") +#define FUNC_NAME s_scm_gr_p { return scm_less_p (y, x); } +#undef FUNC_NAME -SCM_PROC1 (s_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p); - -SCM -scm_leq_p (x, y) - SCM x; - SCM y; +GUILE_PROC1 (scm_leq_p, "<=", scm_tc7_rpsubr, + (SCM x, SCM y), +"") +#define FUNC_NAME s_scm_leq_p { return SCM_BOOL_NOT (scm_less_p (y, x)); } +#undef FUNC_NAME -SCM_PROC1 (s_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p); - -SCM -scm_geq_p (x, y) - SCM x; - SCM y; +GUILE_PROC1 (scm_geq_p, ">=", scm_tc7_rpsubr, + (SCM x, SCM y), +"") +#define FUNC_NAME s_scm_geq_p { return SCM_BOOL_NOT (scm_less_p (x, y)); } +#undef FUNC_NAME @@ -4269,59 +4193,55 @@ scm_two_doubles (z1, z2, sstring, xy) -SCM_PROC (s_sys_expt, "$expt", 2, 0, 0, scm_sys_expt); - -SCM -scm_sys_expt (z1, z2) - SCM z1; - SCM z2; +GUILE_PROC (scm_sys_expt, "$expt", 2, 0, 0, + (SCM z1, SCM z2), +"") +#define FUNC_NAME s_scm_sys_expt { struct dpair xy; - scm_two_doubles (z1, z2, s_sys_expt, &xy); + scm_two_doubles (z1, z2, FUNC_NAME, &xy); return scm_makdbl (pow (xy.x, xy.y), 0.0); } +#undef FUNC_NAME -SCM_PROC (s_sys_atan2, "$atan2", 2, 0, 0, scm_sys_atan2); - -SCM -scm_sys_atan2 (z1, z2) - SCM z1; - SCM z2; +GUILE_PROC (scm_sys_atan2, "$atan2", 2, 0, 0, + (SCM z1, SCM z2), +"") +#define FUNC_NAME s_scm_sys_atan2 { struct dpair xy; - scm_two_doubles (z1, z2, s_sys_atan2, &xy); + scm_two_doubles (z1, z2, FUNC_NAME, &xy); return scm_makdbl (atan2 (xy.x, xy.y), 0.0); } +#undef FUNC_NAME -SCM_PROC (s_make_rectangular, "make-rectangular", 2, 0, 0, scm_make_rectangular); - -SCM -scm_make_rectangular (z1, z2) - SCM z1; - SCM z2; +GUILE_PROC (scm_make_rectangular, "make-rectangular", 2, 0, 0, + (SCM z1, SCM z2), +"") +#define FUNC_NAME s_scm_make_rectangular { struct dpair xy; - scm_two_doubles (z1, z2, s_make_rectangular, &xy); + scm_two_doubles (z1, z2, FUNC_NAME, &xy); return scm_makdbl (xy.x, xy.y); } +#undef FUNC_NAME -SCM_PROC (s_make_polar, "make-polar", 2, 0, 0, scm_make_polar); - -SCM -scm_make_polar (z1, z2) - SCM z1; - SCM z2; +GUILE_PROC (scm_make_polar, "make-polar", 2, 0, 0, + (SCM z1, SCM z2), +"") +#define FUNC_NAME s_scm_make_polar { struct dpair xy; - scm_two_doubles (z1, z2, s_make_polar, &xy); + scm_two_doubles (z1, z2, FUNC_NAME, &xy); return scm_makdbl (xy.x * cos (xy.y), xy.x * sin (xy.y)); } +#undef FUNC_NAME @@ -4454,11 +4374,10 @@ scm_angle (z) } -SCM_PROC (s_inexact_to_exact, "inexact->exact", 1, 0, 0, scm_inexact_to_exact); - -SCM -scm_inexact_to_exact (z) - SCM z; +GUILE_PROC (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, + (SCM z), +"") +#define FUNC_NAME s_scm_inexact_to_exact { if (SCM_INUMP (z)) return z; @@ -4470,11 +4389,11 @@ scm_inexact_to_exact (z) if (!(SCM_REALP (z))) { badz: - scm_wta (z, (char *) SCM_ARG1, s_inexact_to_exact); + scm_wta (z, (char *) SCM_ARG1, FUNC_NAME); } #endif #else - SCM_ASSERT (SCM_NIMP (z) && SCM_REALP (z), z, SCM_ARG1, s_inexact_to_exact); + SCM_VALIDATE_REAL(1,z); #endif #ifdef SCM_BIGDIG { @@ -4493,6 +4412,7 @@ scm_inexact_to_exact (z) return SCM_MAKINUM ((long) floor (SCM_REALPART (z) + 0.5)); #endif } +#undef FUNC_NAME @@ -4813,7 +4733,6 @@ scm_num2ulong (num, pos, s_caller) #ifdef SCM_FLOATS #ifndef DBL_DIG -static void add1 SCM_P ((double f, double *fsum)); static void add1 (f, fsum) double f, *fsum; diff --git a/libguile/objects.c b/libguile/objects.c index cd5c2b65c..538aa2230 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + /* This file and objects.h contains those minimal pieces of the Guile @@ -55,6 +59,7 @@ #include "eval.h" #include "alist.h" +#include "scm_validate.h" #include "objects.h" @@ -354,33 +359,31 @@ scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3) return scm_apply_generic (gf, SCM_LIST3 (a1, a2, a3)); } -SCM_PROC (s_entity_p, "entity?", 1, 0, 0, scm_entity_p); - -SCM -scm_entity_p (SCM obj) +GUILE_PROC (scm_entity_p, "entity?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_entity_p { - return (SCM_NIMP (obj) && SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj) - ? SCM_BOOL_T - : SCM_BOOL_F); + return SCM_BOOL(SCM_NIMP (obj) && SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj)); } +#undef FUNC_NAME -SCM_PROC (s_operator_p, "operator?", 1, 0, 0, scm_operator_p); - -SCM -scm_operator_p (SCM obj) +GUILE_PROC (scm_operator_p, "operator?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_operator_p { - return (SCM_NIMP (obj) - && SCM_STRUCTP (obj) - && SCM_I_OPERATORP (obj) - && !SCM_I_ENTITYP (obj) - ? SCM_BOOL_T - : SCM_BOOL_F); + return SCM_BOOL(SCM_NIMP (obj) + && SCM_STRUCTP (obj) + && SCM_I_OPERATORP (obj) + && !SCM_I_ENTITYP (obj)); } +#undef FUNC_NAME -SCM_PROC (s_set_object_procedure_x, "set-object-procedure!", 2, 0, 0, scm_set_object_procedure_x); - -SCM -scm_set_object_procedure_x (SCM obj, SCM proc) +GUILE_PROC (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0, + (SCM obj, SCM proc), + "") +#define FUNC_NAME s_scm_set_object_procedure_x { SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj) && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) @@ -389,30 +392,31 @@ scm_set_object_procedure_x (SCM obj, SCM proc) & SCM_CLASSF_PURE_GENERIC))), obj, SCM_ARG1, - s_set_object_procedure_x); - SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (proc)), - proc, SCM_ARG2, s_set_object_procedure_x); + FUNC_NAME); + SCM_VALIDATE_PROC(2,proc); if (SCM_I_ENTITYP (obj)) SCM_ENTITY_PROCEDURE (obj) = proc; else SCM_OPERATOR_CLASS (obj)->procedure = proc; return SCM_UNSPECIFIED; } +#undef FUNC_NAME #ifdef GUILE_DEBUG -SCM_PROC (s_object_procedure, "object-procedure", 1, 0, 0, scm_object_procedure); - -SCM -scm_object_procedure (SCM obj) +GUILE_PROC (scm_object_procedure, "object-procedure", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_object_procedure { SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj) && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) || SCM_I_ENTITYP (obj)), - obj, SCM_ARG1, s_object_procedure); + obj, SCM_ARG1, FUNC_NAME); return (SCM_I_ENTITYP (obj) ? SCM_ENTITY_PROCEDURE (obj) : SCM_OPERATOR_CLASS (obj)->procedure); } +#undef FUNC_NAME #endif /* GUILE_DEBUG */ /* The following procedures are not a part of Goops but a minimal @@ -434,35 +438,28 @@ scm_i_make_class_object (SCM meta, return c; } -SCM_PROC (s_make_class_object, "make-class-object", 2, 0, 0, scm_make_class_object); - -SCM -scm_make_class_object (SCM metaclass, SCM layout) +GUILE_PROC (scm_make_class_object, "make-class-object", 2, 0, 0, + (SCM metaclass, SCM layout), + "") +#define FUNC_NAME s_scm_make_class_object { unsigned long flags = 0; - SCM_ASSERT (SCM_NIMP (metaclass) && SCM_STRUCTP (metaclass), - metaclass, SCM_ARG1, s_make_class_object); - SCM_ASSERT (SCM_NIMP (layout) && SCM_STRINGP (layout), - layout, SCM_ARG2, s_make_class_object); + SCM_VALIDATE_STRUCT(1,metaclass); + SCM_VALIDATE_STRING(2,layout); if (metaclass == scm_metaclass_operator) flags = SCM_CLASSF_OPERATOR; return scm_i_make_class_object (metaclass, layout, flags); } +#undef FUNC_NAME -SCM_PROC (s_make_subclass_object, "make-subclass-object", 2, 0, 0, scm_make_subclass_object); - -SCM -scm_make_subclass_object (SCM class, SCM layout) +GUILE_PROC (scm_make_subclass_object, "make-subclass-object", 2, 0, 0, + (SCM class, SCM layout), + "") +#define FUNC_NAME s_scm_make_subclass_object { SCM pl; - SCM_ASSERT (SCM_NIMP (class) && SCM_STRUCTP (class), - class, - SCM_ARG1, - s_make_subclass_object); - SCM_ASSERT (SCM_NIMP (layout) && SCM_STRINGP (layout), - layout, - SCM_ARG2, - s_make_subclass_object); + SCM_VALIDATE_STRUCT(1,class); + SCM_VALIDATE_STRING(2,layout); pl = SCM_STRUCT_DATA (class)[scm_vtable_index_layout]; /* Convert symbol->string */ pl = scm_makfromstr (SCM_CHARS (pl), (scm_sizet) SCM_LENGTH (pl), 0); @@ -470,6 +467,7 @@ scm_make_subclass_object (SCM class, SCM layout) scm_string_append (SCM_LIST2 (pl, layout)), SCM_CLASS_FLAGS (class)); } +#undef FUNC_NAME void scm_init_objects () diff --git a/libguile/objprop.c b/libguile/objprop.c index 00d46ea1c..5244e1581 100644 --- a/libguile/objprop.c +++ b/libguile/objprop.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -52,47 +56,42 @@ /* {Object Properties} */ -SCM_PROC(s_object_properties, "object-properties", 1, 0, 0, scm_object_properties); - -SCM -scm_object_properties (obj) - SCM obj; +GUILE_PROC(scm_object_properties, "object-properties", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_object_properties { return scm_hashq_ref (scm_object_whash, obj, SCM_EOL); } +#undef FUNC_NAME -SCM_PROC(s_set_object_properties_x, "set-object-properties!", 2, 0, 0, scm_set_object_properties_x); - -SCM -scm_set_object_properties_x (obj, plist) - SCM obj; - SCM plist; +GUILE_PROC(scm_set_object_properties_x, "set-object-properties!", 2, 0, 0, + (SCM obj, SCM plist), +"") +#define FUNC_NAME s_scm_set_object_properties_x { SCM handle = scm_hashq_create_handle_x (scm_object_whash, obj, plist); SCM_SETCDR (handle, plist); return plist; } +#undef FUNC_NAME -SCM_PROC(s_object_property, "object-property", 2, 0, 0, scm_object_property); - -SCM -scm_object_property (obj, key) - SCM obj; - SCM key; +GUILE_PROC(scm_object_property, "object-property", 2, 0, 0, + (SCM obj, SCM key), +"") +#define FUNC_NAME s_scm_object_property { SCM assoc; assoc = scm_assq (key, scm_object_properties (obj)); return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F); } +#undef FUNC_NAME -SCM_PROC(s_set_object_property_x, "set-object-property!", 3, 0, 0, scm_set_object_property_x); - -SCM -scm_set_object_property_x (obj, key, val) - SCM obj; - SCM key; - SCM val; +GUILE_PROC(scm_set_object_property_x, "set-object-property!", 3, 0, 0, + (SCM obj, SCM key, SCM val), +"") +#define FUNC_NAME s_scm_set_object_property_x { SCM h; SCM assoc; @@ -109,6 +108,7 @@ scm_set_object_property_x (obj, key, val) SCM_ALLOW_INTS; return val; } +#undef FUNC_NAME void diff --git a/libguile/pairs.c b/libguile/pairs.c index b595bdf47..8211426c4 100644 --- a/libguile/pairs.c +++ b/libguile/pairs.c @@ -38,21 +38,26 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include #include "_scm.h" + +#include "scm_validate.h" + /* {Pairs} */ -SCM_PROC(s_cons, "cons", 2, 0, 0, scm_cons); - -SCM -scm_cons (x, y) - SCM x; - SCM y; +GUILE_PROC(scm_cons, "cons", 2, 0, 0, + (SCM x, SCM y), +"") +#define FUNC_NAME s_scm_cons { register SCM z; SCM_NEWCELL (z); @@ -60,13 +65,11 @@ scm_cons (x, y) SCM_SETCDR (z, y); return z; } +#undef FUNC_NAME SCM -scm_cons2 (w, x, y) - SCM w; - SCM x; - SCM y; +scm_cons2 (SCM w, SCM x, SCM y) { register SCM z; SCM_NEWCELL (z); @@ -80,41 +83,38 @@ scm_cons2 (w, x, y) } -SCM_PROC (s_pair_p, "pair?", 1, 0, 0, scm_pair_p); - -SCM -scm_pair_p (x) - SCM x; +GUILE_PROC (scm_pair_p, "pair?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_pair_p { if (SCM_IMP (x)) return SCM_BOOL_F; - return SCM_CONSP (x) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(SCM_CONSP (x)); } +#undef FUNC_NAME -SCM_PROC (s_set_car_x, "set-car!", 2, 0, 0, scm_set_car_x); - -SCM -scm_set_car_x (pair, value) - SCM pair; - SCM value; +GUILE_PROC (scm_set_car_x, "set-car!", 2, 0, 0, + (SCM pair, SCM value), +"") +#define FUNC_NAME s_scm_set_car_x { - SCM_ASSERT (SCM_NIMP (pair) && SCM_CONSP (pair), - pair, SCM_ARG1, s_set_car_x); + SCM_VALIDATE_NIMCONS(1,pair); SCM_SETCAR (pair, value); return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_set_cdr_x, "set-cdr!", 2, 0, 0, scm_set_cdr_x); - -SCM -scm_set_cdr_x (pair, value) - SCM pair; - SCM value; +GUILE_PROC (scm_set_cdr_x, "set-cdr!", 2, 0, 0, + (SCM pair, SCM value), +"") +#define FUNC_NAME s_scm_set_cdr_x { - SCM_ASSERT (SCM_NIMP(pair) && SCM_CONSP (pair), pair, SCM_ARG1, s_set_cdr_x); + SCM_VALIDATE_NIMCONS(1,pair); SCM_SETCDR (pair, value); return SCM_UNSPECIFIED; } +#undef FUNC_NAME diff --git a/libguile/pairs.h b/libguile/pairs.h index 638e62d10..221a33382 100644 --- a/libguile/pairs.h +++ b/libguile/pairs.h @@ -42,6 +42,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include "libguile/__scm.h" @@ -155,6 +159,7 @@ typedef SCM huge *SCMPTR; { \ _into = scm_freelist; \ scm_freelist = SCM_CDR(scm_freelist);\ + SCM_SETCAR(_into, scm_tc16_allocated); \ ++scm_cells_allocated; \ } \ } while(0) diff --git a/libguile/ports.c b/libguile/ports.c index 5f9e6fd61..8788ba894 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + /* Headers. */ @@ -49,6 +53,7 @@ #include "keywords.h" +#include "scm_validate.h" #include "ports.h" #ifdef HAVE_MALLOC_H @@ -207,18 +212,17 @@ scm_set_port_input_waiting (long tc, int (*input_waiting) (SCM)) -SCM_PROC(s_char_ready_p, "char-ready?", 0, 1, 0, scm_char_ready_p); - -SCM -scm_char_ready_p (SCM port) +GUILE_PROC(scm_char_ready_p, "char-ready?", 0, 1, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_char_ready_p { scm_port *pt; if (SCM_UNBNDP (port)) port = scm_cur_inp; else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, - s_char_ready_p); + SCM_VALIDATE_OPINPORT(1,port); pt = SCM_PTAB_ENTRY (port); @@ -234,24 +238,25 @@ scm_char_ready_p (SCM port) scm_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; if (ptob->input_waiting) - return (ptob->input_waiting (port)) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(ptob->input_waiting (port)); else return SCM_BOOL_T; } } +#undef FUNC_NAME /* Clear a port's read buffers, returning the contents. */ -SCM_PROC (s_drain_input, "drain-input", 1, 0, 0, scm_drain_input); -SCM -scm_drain_input (SCM port) +GUILE_PROC (scm_drain_input, "drain-input", 1, 0, 0, + (SCM port), + "") +#define FUNC_NAME s_scm_drain_input { SCM result; scm_port *pt = SCM_PTAB_ENTRY (port); int count; char *dst; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, - s_drain_input); + SCM_VALIDATE_OPINPORT(1,port); count = pt->read_end - pt->read_pos; if (pt->read_buf == pt->putback_buf) @@ -271,78 +276,86 @@ scm_drain_input (SCM port) return result; } +#undef FUNC_NAME /* Standard ports --- current input, output, error, and more(!). */ -SCM_PROC(s_current_input_port, "current-input-port", 0, 0, 0, scm_current_input_port); - -SCM -scm_current_input_port () +GUILE_PROC(scm_current_input_port, "current-input-port", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_current_input_port { return scm_cur_inp; } +#undef FUNC_NAME -SCM_PROC(s_current_output_port, "current-output-port", 0, 0, 0, scm_current_output_port); - -SCM -scm_current_output_port () +GUILE_PROC(scm_current_output_port, "current-output-port", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_current_output_port { return scm_cur_outp; } +#undef FUNC_NAME -SCM_PROC(s_current_error_port, "current-error-port", 0, 0, 0, scm_current_error_port); - -SCM -scm_current_error_port () +GUILE_PROC(scm_current_error_port, "current-error-port", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_current_error_port { return scm_cur_errp; } +#undef FUNC_NAME -SCM_PROC(s_current_load_port, "current-load-port", 0, 0, 0, scm_current_load_port); - -SCM -scm_current_load_port () +GUILE_PROC(scm_current_load_port, "current-load-port", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_current_load_port { return scm_cur_loadp; } +#undef FUNC_NAME -SCM_PROC(s_set_current_input_port, "set-current-input-port", 1, 0, 0, scm_set_current_input_port); - -SCM -scm_set_current_input_port (SCM port) +GUILE_PROC(scm_set_current_input_port, "set-current-input-port", 1, 0, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_set_current_input_port { SCM oinp = scm_cur_inp; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_set_current_input_port); + SCM_VALIDATE_OPINPORT(1,port); scm_cur_inp = port; return oinp; } +#undef FUNC_NAME -SCM_PROC(s_set_current_output_port, "set-current-output-port", 1, 0, 0, scm_set_current_output_port); - -SCM -scm_set_current_output_port (SCM port) +GUILE_PROC(scm_set_current_output_port, "set-current-output-port", 1, 0, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_set_current_output_port { SCM ooutp = scm_cur_outp; port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_output_port); + SCM_VALIDATE_OPOUTPORT(1,port); scm_cur_outp = port; return ooutp; } +#undef FUNC_NAME -SCM_PROC(s_set_current_error_port, "set-current-error-port", 1, 0, 0, scm_set_current_error_port); - -SCM -scm_set_current_error_port (SCM port) +GUILE_PROC(scm_set_current_error_port, "set-current-error-port", 1, 0, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_set_current_error_port { SCM oerrp = scm_cur_errp; port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_error_port); + SCM_VALIDATE_OPOUTPORT(1,port); scm_cur_errp = port; return oerrp; } +#undef FUNC_NAME /* The port table --- an array of pointers to ports. */ @@ -419,26 +432,29 @@ scm_remove_from_port_table (SCM port) /* Undocumented functions for debugging. */ /* Return the number of ports in the table. */ -SCM_PROC(s_pt_size, "pt-size", 0, 0, 0, scm_pt_size); -SCM -scm_pt_size () +GUILE_PROC(scm_pt_size, "pt-size", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_pt_size { return SCM_MAKINUM (scm_port_table_size); } +#undef FUNC_NAME /* Return the ith member of the port table. */ -SCM_PROC(s_pt_member, "pt-member", 1, 0, 0, scm_pt_member); -SCM -scm_pt_member (SCM member) +GUILE_PROC(scm_pt_member, "pt-member", 1, 0, 0, + (SCM member), +"") +#define FUNC_NAME s_scm_pt_member { int i; - SCM_ASSERT (SCM_INUMP (member), member, SCM_ARG1, s_pt_member); - i = SCM_INUM (member); + SCM_VALIDATE_INT_copy(1,member,i); if (i < 0 || i >= scm_port_table_size) return SCM_BOOL_F; else return scm_port_table[i]->port; } +#undef FUNC_NAME #endif @@ -459,29 +475,30 @@ scm_revealed_count (SCM port) /* Return the revealed count for a port. */ -SCM_PROC(s_port_revealed, "port-revealed", 1, 0, 0, scm_port_revealed); - -SCM -scm_port_revealed (SCM port) +GUILE_PROC(scm_port_revealed, "port-revealed", 1, 0, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_port_revealed { port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_port_revealed); + SCM_VALIDATE_PORT(1,port); return SCM_MAKINUM (scm_revealed_count (port)); } +#undef FUNC_NAME /* Set the revealed count for a port. */ -SCM_PROC(s_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, scm_set_port_revealed_x); - -SCM -scm_set_port_revealed_x (SCM port, SCM rcount) +GUILE_PROC(scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, + (SCM port, SCM rcount), +"") +#define FUNC_NAME s_scm_set_port_revealed_x { port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), - port, SCM_ARG1, s_set_port_revealed_x); - SCM_ASSERT (SCM_INUMP (rcount), rcount, SCM_ARG2, s_set_port_revealed_x); + SCM_VALIDATE_PORT(1,port); + SCM_VALIDATE_INT(2,rcount); SCM_REVEALED (port) = SCM_INUM (rcount); return SCM_UNSPECIFIED; } +#undef FUNC_NAME @@ -510,16 +527,16 @@ scm_mode_bits (char *modes) * Some modes such as "append" are only used when opening * a file and are not returned here. */ -SCM_PROC(s_port_mode, "port-mode", 1, 0, 0, scm_port_mode); - -SCM -scm_port_mode (SCM port) +GUILE_PROC(scm_port_mode, "port-mode", 1, 0, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_port_mode { char modes[3]; modes[0] = '\0'; port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_port_mode); + SCM_VALIDATE_OPPORT(1,port); if (SCM_CAR (port) & SCM_RDNG) { if (SCM_CAR (port) & SCM_WRTNG) strcpy (modes, "r+"); @@ -532,6 +549,7 @@ scm_port_mode (SCM port) strcat (modes, "0"); return scm_makfromstr (modes, strlen (modes), 0); } +#undef FUNC_NAME @@ -541,18 +559,17 @@ scm_port_mode (SCM port) * Call the close operation on a port object. * see also scm_close. */ -SCM_PROC(s_close_port, "close-port", 1, 0, 0, scm_close_port); - -SCM -scm_close_port (SCM port) +GUILE_PROC(scm_close_port, "close-port", 1, 0, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_close_port { scm_sizet i; int rv; port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, - s_close_port); + SCM_VALIDATE_PORT(1,port); if (SCM_CLOSEDP (port)) return SCM_BOOL_F; i = SCM_PTOBNUM (port); @@ -562,16 +579,17 @@ scm_close_port (SCM port) rv = 0; scm_remove_from_port_table (port); SCM_SETAND_CAR (port, ~SCM_OPN); - return (rv < 0) ? SCM_BOOL_F : SCM_BOOL_T; + return SCM_NEGATE_BOOL(rv < 0); } +#undef FUNC_NAME -SCM_PROC(s_close_all_ports_except, "close-all-ports-except", 0, 0, 1, scm_close_all_ports_except); - -SCM -scm_close_all_ports_except (SCM ports) +GUILE_PROC(scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1, + (SCM ports), +"") +#define FUNC_NAME s_scm_close_all_ports_except { int i = 0; - SCM_ASSERT (SCM_NIMP (ports) && SCM_CONSP (ports), ports, SCM_ARG1, s_close_all_ports_except); + SCM_VALIDATE_NIMCONS(1,ports); while (i < scm_port_table_size) { SCM thisport = scm_port_table[i]->port; @@ -582,7 +600,7 @@ scm_close_all_ports_except (SCM ports) { SCM port = SCM_COERCE_OUTPORT (SCM_CAR (ports_ptr)); if (i == 0) - SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_close_all_ports_except); + SCM_VALIDATE_OPPORT(1,port); if (port == thisport) found = 1; ports_ptr = SCM_CDR (ports_ptr); @@ -595,70 +613,76 @@ scm_close_all_ports_except (SCM ports) } return SCM_UNSPECIFIED; } +#undef FUNC_NAME /* Utter miscellany. Gosh, we should clean this up some time. */ -SCM_PROC(s_input_port_p, "input-port?", 1, 0, 0, scm_input_port_p); - -SCM -scm_input_port_p (SCM x) +GUILE_PROC(scm_input_port_p, "input-port?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_input_port_p { if (SCM_IMP (x)) return SCM_BOOL_F; - return SCM_INPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(SCM_INPORTP (x)); } +#undef FUNC_NAME -SCM_PROC(s_output_port_p, "output-port?", 1, 0, 0, scm_output_port_p); - -SCM -scm_output_port_p (SCM x) +GUILE_PROC(scm_output_port_p, "output-port?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_output_port_p { if (SCM_IMP (x)) return SCM_BOOL_F; if (SCM_PORT_WITH_PS_P (x)) x = SCM_PORT_WITH_PS_PORT (x); - return SCM_OUTPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(SCM_OUTPORTP (x)); } +#undef FUNC_NAME -SCM_PROC(s_port_closed_p, "port-closed?", 1, 0, 0, scm_port_closed_p); -SCM -scm_port_closed_p (SCM port) +GUILE_PROC(scm_port_closed_p, "port-closed?", 1, 0, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_port_closed_p { - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, - s_port_closed_p); - return SCM_OPPORTP (port) ? SCM_BOOL_F : SCM_BOOL_T; + SCM_VALIDATE_OPPORT(1,port); + return SCM_NEGATE_BOOL(SCM_OPPORTP (port)); } +#undef FUNC_NAME -SCM_PROC(s_eof_object_p, "eof-object?", 1, 0, 0, scm_eof_object_p); - -SCM -scm_eof_object_p (SCM x) +GUILE_PROC(scm_eof_object_p, "eof-object?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_eof_object_p { - return SCM_EOF_OBJECT_P (x) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(SCM_EOF_OBJECT_P (x)); } +#undef FUNC_NAME -SCM_PROC(s_force_output, "force-output", 0, 1, 0, scm_force_output); - -SCM -scm_force_output (SCM port) +GUILE_PROC(scm_force_output, "force-output", 0, 1, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_force_output { if (SCM_UNBNDP (port)) port = scm_cur_outp; else { port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, - s_force_output); + SCM_VALIDATE_OPOUTPORT(1,port); } scm_flush (port); return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_flush_all_ports, "flush-all-ports", 0, 0, 0, scm_flush_all_ports); -SCM -scm_flush_all_ports () +GUILE_PROC (scm_flush_all_ports, "flush-all-ports", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_flush_all_ports { int i; @@ -669,21 +693,23 @@ scm_flush_all_ports () } return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_read_char, "read-char", 0, 1, 0, scm_read_char); - -SCM -scm_read_char (SCM port) +GUILE_PROC(scm_read_char, "read-char", 0, 1, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_read_char { int c; if (SCM_UNBNDP (port)) port = scm_cur_inp; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_char); + SCM_VALIDATE_OPINPORT(1,port); c = scm_getc (port); if (EOF == c) return SCM_EOF_VAL; return SCM_MAKICHR (c); } +#undef FUNC_NAME /* this should only be called when the read buffer is empty. it tries to refill the read buffer. it returns the first char from @@ -891,66 +917,65 @@ scm_ungets (char *s, int n, SCM port) } -SCM_PROC(s_peek_char, "peek-char", 0, 1, 0, scm_peek_char); - -SCM -scm_peek_char (SCM port) +GUILE_PROC(scm_peek_char, "peek-char", 0, 1, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_peek_char { int c; if (SCM_UNBNDP (port)) port = scm_cur_inp; else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_peek_char); + SCM_VALIDATE_OPINPORT(1,port); c = scm_getc (port); if (EOF == c) return SCM_EOF_VAL; scm_ungetc (c, port); return SCM_MAKICHR (c); } +#undef FUNC_NAME -SCM_PROC (s_unread_char, "unread-char", 2, 0, 0, scm_unread_char); - -SCM -scm_unread_char (SCM cobj, SCM port) +GUILE_PROC (scm_unread_char, "unread-char", 2, 0, 0, + (SCM cobj, SCM port), +"") +#define FUNC_NAME s_scm_unread_char { int c; - SCM_ASSERT (SCM_ICHRP (cobj), cobj, SCM_ARG1, s_unread_char); - + SCM_VALIDATE_CHAR(1,cobj); if (SCM_UNBNDP (port)) port = scm_cur_inp; else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG2, s_unread_char); - + SCM_VALIDATE_OPINPORT(1,port); c = SCM_ICHR (cobj); scm_ungetc (c, port); return cobj; } +#undef FUNC_NAME -SCM_PROC (s_unread_string, "unread-string", 2, 0, 0, scm_unread_string); - -SCM -scm_unread_string (SCM str, SCM port) +GUILE_PROC (scm_unread_string, "unread-string", 2, 0, 0, + (SCM str, SCM port), +"") +#define FUNC_NAME s_scm_unread_string { - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), - str, SCM_ARG1, s_unread_string); - + SCM_VALIDATE_STRING(1,str); if (SCM_UNBNDP (port)) port = scm_cur_inp; else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), - port, SCM_ARG2, s_unread_string); + SCM_VALIDATE_OPINPORT(1,port); scm_ungets (SCM_ROUCHARS (str), SCM_LENGTH (str), port); return str; } +#undef FUNC_NAME -SCM_PROC (s_seek, "seek", 3, 0, 0, scm_seek); -SCM -scm_seek (SCM object, SCM offset, SCM whence) +GUILE_PROC (scm_seek, "seek", 3, 0, 0, + (SCM object, SCM offset, SCM whence), +"") +#define FUNC_NAME s_scm_seek { off_t off; off_t rv; @@ -958,35 +983,35 @@ scm_seek (SCM object, SCM offset, SCM whence) object = SCM_COERCE_OUTPORT (object); - off = scm_num2long (offset, (char *)SCM_ARG2, s_seek); - SCM_ASSERT (SCM_INUMP (whence), whence, SCM_ARG3, s_seek); - how = SCM_INUM (whence); + off = SCM_NUM2LONG (2,offset); + SCM_VALIDATE_INT_COPY(3,whence,how); if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END) - scm_out_of_range (s_seek, whence); + SCM_OUT_OF_RANGE (3, whence); if (SCM_NIMP (object) && SCM_OPPORTP (object)) { scm_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object); if (!ptob->seek) - scm_misc_error (s_seek, "port is not seekable", - scm_cons (object, SCM_EOL)); + SCM_MISC_ERROR ("port is not seekable", + scm_cons (object, SCM_EOL)); else rv = ptob->seek (object, off, how); } else /* file descriptor?. */ { - SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_seek); + SCM_VALIDATE_INT(1,object); rv = lseek (SCM_INUM (object), off, how); if (rv == -1) - scm_syserror (s_seek); + SCM_SYSERROR; } return scm_long2num (rv); } +#undef FUNC_NAME -SCM_PROC (s_truncate_file, "truncate-file", 1, 1, 0, scm_truncate_file); - -SCM -scm_truncate_file (SCM object, SCM length) +GUILE_PROC (scm_truncate_file, "truncate-file", 1, 1, 0, + (SCM object, SCM length), +"") +#define FUNC_NAME s_scm_truncate_file { int rv; off_t c_length; @@ -997,13 +1022,13 @@ scm_truncate_file (SCM object, SCM length) { /* must supply length if object is a filename. */ if (SCM_NIMP (object) && SCM_ROSTRINGP (object)) - scm_wrong_num_args (scm_makfrom0str (s_truncate_file)); + scm_wrong_num_args (SCM_FUNC_NAME); length = scm_seek (object, SCM_INUM0, SCM_MAKINUM (SEEK_CUR)); } - c_length = scm_num2long (length, (char *)SCM_ARG2, s_truncate_file); + c_length = SCM_NUM2LONG (2,length); if (c_length < 0) - scm_misc_error (s_truncate_file, "negative offset", SCM_EOL); + SCM_MISC_ERROR ("negative offset", SCM_EOL); object = SCM_COERCE_OUTPORT (object); if (SCM_INUMP (object)) @@ -1016,7 +1041,7 @@ scm_truncate_file (SCM object, SCM length) scm_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object); if (!ptob->truncate) - scm_misc_error (s_truncate_file, "port is not truncatable", SCM_EOL); + SCM_MISC_ERROR ("port is not truncatable", SCM_EOL); if (pt->rw_active == SCM_PORT_READ) scm_end_input (object); else if (pt->rw_active == SCM_PORT_WRITE) @@ -1027,96 +1052,84 @@ scm_truncate_file (SCM object, SCM length) } else { - SCM_ASSERT (SCM_NIMP (object) && SCM_ROSTRINGP (object), - object, SCM_ARG1, s_truncate_file); + SCM_VALIDATE_ROSTRING(1,object); SCM_COERCE_SUBSTR (object); SCM_SYSCALL (rv = truncate (SCM_ROCHARS (object), c_length)); } if (rv == -1) - scm_syserror (s_truncate_file); + SCM_SYSERROR; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_port_line, "port-line", 1, 0, 0, scm_port_line); - -SCM -scm_port_line (SCM port) +GUILE_PROC (scm_port_line, "port-line", 1, 0, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_port_line { port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), - port, - SCM_ARG1, - s_port_line); + SCM_VALIDATE_OPENPORT(1,port); return SCM_MAKINUM (SCM_LINUM (port)); } +#undef FUNC_NAME -SCM_PROC (s_set_port_line_x, "set-port-line!", 2, 0, 0, scm_set_port_line_x); - -SCM -scm_set_port_line_x (SCM port, SCM line) +GUILE_PROC (scm_set_port_line_x, "set-port-line!", 2, 0, 0, + (SCM port, SCM line), +"") +#define FUNC_NAME s_scm_set_port_line_x { port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), - port, - SCM_ARG1, - s_set_port_line_x); - SCM_ASSERT (SCM_INUMP (line), line, SCM_ARG2, s_set_port_line_x); + SCM_VALIDATE_OPENPORT(1,port); + SCM_VALIDATE_INT(2,line); return SCM_PTAB_ENTRY (port)->line_number = SCM_INUM (line); } +#undef FUNC_NAME -SCM_PROC (s_port_column, "port-column", 1, 0, 0, scm_port_column); - -SCM -scm_port_column (SCM port) +GUILE_PROC (scm_port_column, "port-column", 1, 0, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_port_column { port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), - port, - SCM_ARG1, - s_port_column); + SCM_VALIDATE_OPENPORT(1,port); return SCM_MAKINUM (SCM_COL (port)); } +#undef FUNC_NAME -SCM_PROC (s_set_port_column_x, "set-port-column!", 2, 0, 0, scm_set_port_column_x); - -SCM -scm_set_port_column_x (SCM port, SCM column) +GUILE_PROC (scm_set_port_column_x, "set-port-column!", 2, 0, 0, + (SCM port, SCM column), +"") +#define FUNC_NAME s_scm_set_port_column_x { port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), - port, - SCM_ARG1, - s_set_port_column_x); - SCM_ASSERT (SCM_INUMP (column), column, SCM_ARG2, s_set_port_column_x); + SCM_VALIDATE_OPENPORT(1,port); + SCM_VALIDATE_INT(2,column); return SCM_PTAB_ENTRY (port)->column_number = SCM_INUM (column); } +#undef FUNC_NAME -SCM_PROC (s_port_filename, "port-filename", 1, 0, 0, scm_port_filename); - -SCM -scm_port_filename (SCM port) +GUILE_PROC (scm_port_filename, "port-filename", 1, 0, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_port_filename { port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), - port, - SCM_ARG1, - s_port_filename); + SCM_VALIDATE_OPENPORT(1,port); return SCM_PTAB_ENTRY (port)->file_name; } +#undef FUNC_NAME -SCM_PROC (s_set_port_filename_x, "set-port-filename!", 2, 0, 0, scm_set_port_filename_x); - -SCM -scm_set_port_filename_x (SCM port, SCM filename) +GUILE_PROC (scm_set_port_filename_x, "set-port-filename!", 2, 0, 0, + (SCM port, SCM filename), +"") +#define FUNC_NAME s_scm_set_port_filename_x { port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), - port, - SCM_ARG1, - s_set_port_filename_x); + SCM_VALIDATE_OPENPORT(1,port); /* We allow the user to set the filename to whatever he likes. */ return SCM_PTAB_ENTRY (port)->file_name = filename; } +#undef FUNC_NAME #ifndef ttyname extern char * ttyname(); @@ -1211,17 +1224,16 @@ scm_void_port (char *mode_str) } -SCM_PROC (s_sys_make_void_port, "%make-void-port", 1, 0, 0, scm_sys_make_void_port); - -SCM -scm_sys_make_void_port (SCM mode) +GUILE_PROC (scm_sys_make_void_port, "%make-void-port", 1, 0, 0, + (SCM mode), +"") +#define FUNC_NAME s_scm_sys_make_void_port { - SCM_ASSERT (SCM_NIMP (mode) && SCM_ROSTRINGP (mode), mode, - SCM_ARG1, s_sys_make_void_port); - + SCM_VALIDATE_ROSTRING(1,mode); SCM_COERCE_SUBSTR (mode); return scm_void_port (SCM_ROCHARS (mode)); } +#undef FUNC_NAME /* Initialization. */ diff --git a/libguile/posix.c b/libguile/posix.c index 975e36026..d224dd16c 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -46,6 +50,7 @@ #include "scmsigs.h" #include "feature.h" +#include "scm_validate.h" #include "posix.h" @@ -161,49 +166,49 @@ extern char ** environ; SCM_SYMBOL (sym_read_pipe, "read pipe"); SCM_SYMBOL (sym_write_pipe, "write pipe"); -SCM_PROC (s_pipe, "pipe", 0, 0, 0, scm_pipe); - -SCM -scm_pipe () +GUILE_PROC (scm_pipe, "pipe", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_pipe { int fd[2], rv; SCM p_rd, p_wt; rv = pipe (fd); if (rv) - scm_syserror (s_pipe); + SCM_SYSERROR; p_rd = scm_fdes_to_port (fd[0], "r", sym_read_pipe); p_wt = scm_fdes_to_port (fd[1], "w", sym_write_pipe); return scm_cons (p_rd, p_wt); } +#undef FUNC_NAME #ifdef HAVE_GETGROUPS -SCM_PROC (s_getgroups, "getgroups", 0, 0, 0, scm_getgroups); - -SCM -scm_getgroups() +GUILE_PROC (scm_getgroups, "getgroups", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_getgroups { SCM grps, ans; int ngroups = getgroups (0, NULL); if (!ngroups) - scm_syserror (s_getgroups); + SCM_SYSERROR; SCM_NEWCELL(grps); SCM_DEFER_INTS; { GETGROUPS_T *groups; int val; - groups = (GETGROUPS_T *) scm_must_malloc(ngroups * sizeof(GETGROUPS_T), - s_getgroups); + groups = SCM_MUST_MALLOC_TYPE_NUM(GETGROUPS_T,ngroups); val = getgroups(ngroups, groups); if (val < 0) { int en = errno; scm_must_free((char *)groups); errno = en; - scm_syserror (s_getgroups); + SCM_SYSERROR; } SCM_SETCHARS(grps, groups); /* set up grps as a GC protect */ SCM_SETLENGTH(grps, 0L + ngroups * sizeof(GETGROUPS_T), scm_tc7_string); @@ -213,15 +218,15 @@ scm_getgroups() SCM_ALLOW_INTS; return ans; } -} +} +#undef FUNC_NAME #endif -SCM_PROC (s_getpwuid, "getpw", 0, 1, 0, scm_getpwuid); - -SCM -scm_getpwuid (user) - SCM user; +GUILE_PROC (scm_getpwuid, "getpw", 0, 1, 0, + (SCM user), +"") +#define FUNC_NAME s_scm_getpwuid { SCM result; struct passwd *entry; @@ -243,13 +248,13 @@ scm_getpwuid (user) } else { - SCM_ASSERT (SCM_NIMP (user) && SCM_ROSTRINGP (user), user, SCM_ARG1, s_getpwuid); + SCM_VALIDATE_ROSTRING(1,user); if (SCM_SUBSTRP (user)) user = scm_makfromstr (SCM_ROCHARS (user), SCM_ROLENGTH (user), 0); entry = getpwnam (SCM_ROCHARS (user)); } if (!entry) - scm_misc_error (s_getpwuid, "entry not found", SCM_EOL); + SCM_MISC_ERROR ("entry not found", SCM_EOL); ve[0] = scm_makfrom0str (entry->pw_name); ve[1] = scm_makfrom0str (entry->pw_passwd); @@ -266,14 +271,14 @@ scm_getpwuid (user) ve[6] = scm_makfrom0str (entry->pw_shell); return result; } +#undef FUNC_NAME #ifdef HAVE_SETPWENT -SCM_PROC (s_setpwent, "setpw", 0, 1, 0, scm_setpwent); - -SCM -scm_setpwent (arg) - SCM arg; +GUILE_PROC (scm_setpwent, "setpw", 0, 1, 0, + (SCM arg), +"") +#define FUNC_NAME s_scm_setpwent { if (SCM_UNBNDP (arg) || SCM_FALSEP (arg)) endpwent (); @@ -281,16 +286,16 @@ scm_setpwent (arg) setpwent (); return SCM_UNSPECIFIED; } +#undef FUNC_NAME #endif /* Combines getgrgid and getgrnam. */ -SCM_PROC (s_getgrgid, "getgr", 0, 1, 0, scm_getgrgid); - -SCM -scm_getgrgid (name) - SCM name; +GUILE_PROC (scm_getgrgid, "getgr", 0, 1, 0, + (SCM name), +"") +#define FUNC_NAME s_scm_getgrgid { SCM result; struct group *entry; @@ -309,13 +314,12 @@ scm_getgrgid (name) SCM_SYSCALL (entry = getgrgid (SCM_INUM (name))); else { - SCM_ASSERT (SCM_NIMP (name) && SCM_ROSTRINGP (name), name, SCM_ARG1, - s_getgrgid); + SCM_VALIDATE_ROSTRING(1,name); SCM_COERCE_SUBSTR (name); SCM_SYSCALL (entry = getgrnam (SCM_ROCHARS (name))); } if (!entry) - scm_syserror (s_getgrgid); + SCM_SYSERROR; ve[0] = scm_makfrom0str (entry->gr_name); ve[1] = scm_makfrom0str (entry->gr_passwd); @@ -323,14 +327,14 @@ scm_getgrgid (name) ve[3] = scm_makfromstrs (-1, entry->gr_mem); return result; } +#undef FUNC_NAME -SCM_PROC (s_setgrent, "setgr", 0, 1, 0, scm_setgrent); - -SCM -scm_setgrent (arg) - SCM arg; +GUILE_PROC (scm_setgrent, "setgr", 0, 1, 0, + (SCM arg), +"") +#define FUNC_NAME s_scm_setgrent { if (SCM_UNBNDP (arg) || SCM_FALSEP (arg)) endgrent (); @@ -338,65 +342,64 @@ scm_setgrent (arg) setgrent (); return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_kill, "kill", 2, 0, 0, scm_kill); - -SCM -scm_kill (pid, sig) - SCM pid; - SCM sig; +GUILE_PROC (scm_kill, "kill", 2, 0, 0, + (SCM pid, SCM sig), +"") +#define FUNC_NAME s_scm_kill { - SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_kill); - SCM_ASSERT (SCM_INUMP (sig), sig, SCM_ARG2, s_kill); + SCM_VALIDATE_INT(1,pid); + SCM_VALIDATE_INT(2,sig); /* Signal values are interned in scm_init_posix(). */ if (kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig)) != 0) - scm_syserror (s_kill); + SCM_SYSERROR; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_waitpid, "waitpid", 1, 1, 0, scm_waitpid); - -SCM -scm_waitpid (pid, options) - SCM pid; - SCM options; +GUILE_PROC (scm_waitpid, "waitpid", 1, 1, 0, + (SCM pid, SCM options), +"") +#define FUNC_NAME s_scm_waitpid { #ifdef HAVE_WAITPID int i; int status; int ioptions; - SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_waitpid); + SCM_VALIDATE_INT(1,pid); if (SCM_UNBNDP (options)) ioptions = 0; else { - SCM_ASSERT (SCM_INUMP (options), options, SCM_ARG2, s_waitpid); + SCM_VALIDATE_INT(2,options); /* Flags are interned in scm_init_posix. */ ioptions = SCM_INUM (options); } SCM_SYSCALL (i = waitpid (SCM_INUM (pid), &status, ioptions)); if (i == -1) - scm_syserror (s_waitpid); + SCM_SYSERROR; return scm_cons (SCM_MAKINUM (0L + i), SCM_MAKINUM (0L + status)); #else - scm_sysmissing (s_waitpid); + SCM_SYSMISSING; /* not reached. */ return SCM_BOOL_F; #endif } +#undef FUNC_NAME -SCM_PROC (s_status_exit_val, "status:exit-val", 1, 0, 0, scm_status_exit_val); -SCM -scm_status_exit_val (status) - SCM status; +GUILE_PROC (scm_status_exit_val, "status:exit-val", 1, 0, 0, + (SCM status), +"") +#define FUNC_NAME s_scm_status_exit_val { int lstatus; - SCM_ASSERT (SCM_INUMP (status), status, SCM_ARG1,s_status_exit_val); + SCM_VALIDATE_INT(1,status); /* On Ultrix, the WIF... macros assume their argument is an lvalue; go figure. SCM_INUM does not yield an lvalue. */ @@ -406,15 +409,16 @@ scm_status_exit_val (status) else return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_status_term_sig, "status:term-sig", 1, 0, 0, scm_status_term_sig); -SCM -scm_status_term_sig (status) - SCM status; +GUILE_PROC (scm_status_term_sig, "status:term-sig", 1, 0, 0, + (SCM status), +"") +#define FUNC_NAME s_scm_status_term_sig { int lstatus; - SCM_ASSERT (SCM_INUMP (status), status, SCM_ARG1,s_status_term_sig); + SCM_VALIDATE_INT(1,status); lstatus = SCM_INUM (status); if (WIFSIGNALED (lstatus)) @@ -422,15 +426,16 @@ scm_status_term_sig (status) else return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_status_stop_sig, "status:stop-sig", 1, 0, 0, scm_status_stop_sig); -SCM -scm_status_stop_sig (status) - SCM status; +GUILE_PROC (scm_status_stop_sig, "status:stop-sig", 1, 0, 0, + (SCM status), +"") +#define FUNC_NAME s_scm_status_stop_sig { int lstatus; - SCM_ASSERT (SCM_INUMP (status), status, SCM_ARG1,s_status_stop_sig); + SCM_VALIDATE_INT(1,status); lstatus = SCM_INUM (status); if (WIFSTOPPED (lstatus)) @@ -438,41 +443,45 @@ scm_status_stop_sig (status) else return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_getppid, "getppid", 0, 0, 0, scm_getppid); - -SCM -scm_getppid () +GUILE_PROC (scm_getppid, "getppid", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_getppid { return SCM_MAKINUM (0L + getppid ()); } +#undef FUNC_NAME -SCM_PROC (s_getuid, "getuid", 0, 0, 0, scm_getuid); - -SCM -scm_getuid () +GUILE_PROC (scm_getuid, "getuid", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_getuid { return SCM_MAKINUM (0L + getuid ()); } +#undef FUNC_NAME -SCM_PROC (s_getgid, "getgid", 0, 0, 0, scm_getgid); - -SCM -scm_getgid () +GUILE_PROC (scm_getgid, "getgid", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_getgid { return SCM_MAKINUM (0L + getgid ()); } +#undef FUNC_NAME -SCM_PROC (s_geteuid, "geteuid", 0, 0, 0, scm_geteuid); - -SCM -scm_geteuid () +GUILE_PROC (scm_geteuid, "geteuid", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_geteuid { #ifdef HAVE_GETEUID return SCM_MAKINUM (0L + geteuid ()); @@ -480,13 +489,14 @@ scm_geteuid () return SCM_MAKINUM (0L + getuid ()); #endif } +#undef FUNC_NAME -SCM_PROC (s_getegid, "getegid", 0, 0, 0, scm_getegid); - -SCM -scm_getegid () +GUILE_PROC (scm_getegid, "getegid", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_getegid { #ifdef HAVE_GETEUID return SCM_MAKINUM (0L + getegid ()); @@ -494,159 +504,167 @@ scm_getegid () return SCM_MAKINUM (0L + getgid ()); #endif } +#undef FUNC_NAME -SCM_PROC (s_setuid, "setuid", 1, 0, 0, scm_setuid); - -SCM -scm_setuid (id) - SCM id; +GUILE_PROC (scm_setuid, "setuid", 1, 0, 0, + (SCM id), +"") +#define FUNC_NAME s_scm_setuid { - SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setuid); + SCM_VALIDATE_INT(1,id); if (setuid (SCM_INUM (id)) != 0) - scm_syserror (s_setuid); + SCM_SYSERROR; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_setgid, "setgid", 1, 0, 0, scm_setgid); - -SCM -scm_setgid (id) - SCM id; +GUILE_PROC (scm_setgid, "setgid", 1, 0, 0, + (SCM id), +"") +#define FUNC_NAME s_scm_setgid { - SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setgid); + SCM_VALIDATE_INT(1,id); if (setgid (SCM_INUM (id)) != 0) - scm_syserror (s_setgid); + SCM_SYSERROR; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_seteuid, "seteuid", 1, 0, 0, scm_seteuid); - -SCM -scm_seteuid (id) - SCM id; +GUILE_PROC (scm_seteuid, "seteuid", 1, 0, 0, + (SCM id), +"") +#define FUNC_NAME s_scm_seteuid { int rv; - SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_seteuid); + SCM_VALIDATE_INT(1,id); #ifdef HAVE_SETEUID rv = seteuid (SCM_INUM (id)); #else rv = setuid (SCM_INUM (id)); #endif if (rv != 0) - scm_syserror (s_seteuid); + SCM_SYSERROR; return SCM_UNSPECIFIED; } +#undef FUNC_NAME #ifdef HAVE_SETEGID -SCM_PROC (s_setegid, "setegid", 1, 0, 0, scm_setegid); - -SCM -scm_setegid (id) - SCM id; +GUILE_PROC (scm_setegid, "setegid", 1, 0, 0, + (SCM id), +"") +#define FUNC_NAME s_scm_setegid { int rv; - SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setegid); + SCM_VALIDATE_INT(1,id); #ifdef HAVE_SETEUID rv = setegid (SCM_INUM (id)); #else rv = setgid (SCM_INUM (id)); #endif if (rv != 0) - scm_syserror (s_setegid); + SCM_SYSERROR; return SCM_UNSPECIFIED; } +#undef FUNC_NAME #endif -SCM_PROC (s_getpgrp, "getpgrp", 0, 0, 0, scm_getpgrp); -SCM -scm_getpgrp () +GUILE_PROC (scm_getpgrp, "getpgrp", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_getpgrp { int (*fn)(); fn = (int (*) ()) getpgrp; return SCM_MAKINUM (fn (0)); } +#undef FUNC_NAME -SCM_PROC (s_setpgid, "setpgid", 2, 0, 0, scm_setpgid); -SCM -scm_setpgid (pid, pgid) - SCM pid, pgid; +GUILE_PROC (scm_setpgid, "setpgid", 2, 0, 0, + (SCM pid, SCM pgid), +"") +#define FUNC_NAME s_scm_setpgid { #ifdef HAVE_SETPGID - SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_setpgid); - SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_setpgid); + SCM_VALIDATE_INT(1,pid); + SCM_VALIDATE_INT(2,pgid); /* FIXME(?): may be known as setpgrp. */ if (setpgid (SCM_INUM (pid), SCM_INUM (pgid)) != 0) - scm_syserror (s_setpgid); + SCM_SYSERROR; return SCM_UNSPECIFIED; #else - scm_sysmissing (s_setpgid); + SCM_SYSMISSING; /* not reached. */ return SCM_BOOL_F; #endif } +#undef FUNC_NAME -SCM_PROC (s_setsid, "setsid", 0, 0, 0, scm_setsid); -SCM -scm_setsid () +GUILE_PROC (scm_setsid, "setsid", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_setsid { #ifdef HAVE_SETSID pid_t sid = setsid (); if (sid == -1) - scm_syserror (s_setsid); + SCM_SYSERROR; return SCM_UNSPECIFIED; #else - scm_sysmissing (s_setsid); + SCM_SYSMISSING; /* not reached. */ return SCM_BOOL_F; #endif } +#undef FUNC_NAME -SCM_PROC (s_ttyname, "ttyname", 1, 0, 0, scm_ttyname); - -SCM -scm_ttyname (port) - SCM port; +GUILE_PROC (scm_ttyname, "ttyname", 1, 0, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_ttyname { char *ans; int fd; port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_ttyname); + SCM_VALIDATE_OPPORT(1,port); if (scm_tc16_fport != SCM_TYP16 (port)) return SCM_BOOL_F; fd = SCM_FPORT_FDES (port); SCM_SYSCALL (ans = ttyname (fd)); if (!ans) - scm_syserror (s_ttyname); + SCM_SYSERROR; /* ans could be overwritten by another call to ttyname */ return (scm_makfrom0str (ans)); } +#undef FUNC_NAME -SCM_PROC (s_ctermid, "ctermid", 0, 0, 0, scm_ctermid); -SCM -scm_ctermid () +GUILE_PROC (scm_ctermid, "ctermid", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_ctermid { #ifdef HAVE_CTERMID char *result = ctermid (NULL); if (*result == '\0') - scm_syserror (s_ctermid); + SCM_SYSERROR; return scm_makfrom0str (result); #else - scm_sysmissing (s_ctermid); + SCM_SYSMISSING; /* not reached. */ return SCM_BOOL_F; #endif } +#undef FUNC_NAME -SCM_PROC (s_tcgetpgrp, "tcgetpgrp", 1, 0, 0, scm_tcgetpgrp); -SCM -scm_tcgetpgrp (port) - SCM port; +GUILE_PROC (scm_tcgetpgrp, "tcgetpgrp", 1, 0, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_tcgetpgrp { #ifdef HAVE_TCGETPGRP int fd; @@ -654,40 +672,43 @@ scm_tcgetpgrp (port) port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcgetpgrp); + SCM_VALIDATE_OPFPORT(1,port); fd = SCM_FPORT_FDES (port); if ((pgid = tcgetpgrp (fd)) == -1) - scm_syserror (s_tcgetpgrp); + SCM_SYSERROR; return SCM_MAKINUM (pgid); #else - scm_sysmissing (s_tcgetpgrp); + SCM_SYSMISSING; /* not reached. */ return SCM_BOOL_F; #endif -} +} +#undef FUNC_NAME -SCM_PROC (s_tcsetpgrp, "tcsetpgrp", 2, 0, 0, scm_tcsetpgrp); -SCM -scm_tcsetpgrp (port, pgid) - SCM port, pgid; +GUILE_PROC (scm_tcsetpgrp, "tcsetpgrp", 2, 0, 0, + (SCM port, SCM pgid), +"") +#define FUNC_NAME s_scm_tcsetpgrp { #ifdef HAVE_TCSETPGRP int fd; port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcsetpgrp); - SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_tcsetpgrp); + SCM_VALIDATE_OPFPORT(1,port); + SCM_VALIDATE_INT(2,pgid); fd = SCM_FPORT_FDES (port); if (tcsetpgrp (fd, SCM_INUM (pgid)) == -1) - scm_syserror (s_tcsetpgrp); + SCM_SYSERROR; return SCM_UNSPECIFIED; #else - scm_sysmissing (s_tcsetpgrp); + SCM_SYSMISSING; /* not reached. */ return SCM_BOOL_F; #endif -} +} +#undef FUNC_NAME + /* Copy exec args from an SCM vector into a new C array. */ @@ -722,39 +743,37 @@ scm_convert_exec_args (SCM args, int pos, const char *subr) return execargv; } -SCM_PROC (s_execl, "execl", 1, 0, 1, scm_execl); - -SCM -scm_execl (filename, args) - SCM filename, args; +GUILE_PROC (scm_execl, "execl", 1, 0, 1, + (SCM filename, SCM args), +"") +#define FUNC_NAME s_scm_execl { char **execargv; - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, - SCM_ARG1, s_execl); + SCM_VALIDATE_ROSTRING(1,filename); SCM_COERCE_SUBSTR (filename); - execargv = scm_convert_exec_args (args, SCM_ARG2, s_execl); + execargv = scm_convert_exec_args (args, SCM_ARG2, FUNC_NAME); execv (SCM_ROCHARS (filename), execargv); - scm_syserror (s_execl); + SCM_SYSERROR; /* not reached. */ return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_execlp, "execlp", 1, 0, 1, scm_execlp); - -SCM -scm_execlp (filename, args) - SCM filename, args; +GUILE_PROC (scm_execlp, "execlp", 1, 0, 1, + (SCM filename, SCM args), +"") +#define FUNC_NAME s_scm_execlp { char **execargv; - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, - SCM_ARG1, s_execlp); + SCM_VALIDATE_ROSTRING(1,filename); SCM_COERCE_SUBSTR (filename); - execargv = scm_convert_exec_args (args, SCM_ARG2, s_execlp); + execargv = scm_convert_exec_args (args, SCM_ARG2, FUNC_NAME); execvp (SCM_ROCHARS (filename), execargv); - scm_syserror (s_execlp); + SCM_SYSERROR; /* not reached. */ return SCM_BOOL_F; } +#undef FUNC_NAME static char ** environ_list_to_c (SCM envlist, int arg, const char *proc) @@ -792,51 +811,51 @@ environ_list_to_c (SCM envlist, int arg, const char *proc) return result; } -SCM_PROC (s_execle, "execle", 2, 0, 1, scm_execle); - -SCM -scm_execle (filename, env, args) - SCM filename, env, args; +GUILE_PROC (scm_execle, "execle", 2, 0, 1, + (SCM filename, SCM env, SCM args), +"") +#define FUNC_NAME s_scm_execle { char **execargv; char **exec_env; - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, - SCM_ARG1, s_execle); + SCM_VALIDATE_ROSTRING(1,filename); SCM_COERCE_SUBSTR (filename); - execargv = scm_convert_exec_args (args, SCM_ARG1, s_execle); - exec_env = environ_list_to_c (env, SCM_ARG2, s_execle); + execargv = scm_convert_exec_args (args, SCM_ARG1, FUNC_NAME); + exec_env = environ_list_to_c (env, SCM_ARG2, FUNC_NAME); execve (SCM_ROCHARS (filename), execargv, exec_env); - scm_syserror (s_execle); + SCM_SYSERROR; /* not reached. */ return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_fork, "primitive-fork", 0, 0, 0, scm_fork); - -SCM -scm_fork() +GUILE_PROC (scm_fork, "primitive-fork", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_fork { int pid; pid = fork (); if (pid == -1) - scm_syserror (s_fork); + SCM_SYSERROR; return SCM_MAKINUM (0L+pid); } +#undef FUNC_NAME -SCM_PROC (s_uname, "uname", 0, 0, 0, scm_uname); - -SCM -scm_uname () +GUILE_PROC (scm_uname, "uname", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_uname { #ifdef HAVE_UNAME struct utsname buf; SCM ans = scm_make_vector (SCM_MAKINUM(5), SCM_UNSPECIFIED); SCM *ve = SCM_VELTS (ans); if (uname (&buf) < 0) - scm_syserror (s_uname); + SCM_SYSERROR; ve[0] = scm_makfrom0str (buf.sysname); ve[1] = scm_makfrom0str (buf.nodename); ve[2] = scm_makfrom0str (buf.release); @@ -848,17 +867,17 @@ scm_uname () */ return ans; #else - scm_sysmissing (s_uname); + SCM_SYSMISSING; /* not reached. */ return SCM_BOOL_F; #endif } +#undef FUNC_NAME -SCM_PROC (s_environ, "environ", 0, 1, 0, scm_environ); - -SCM -scm_environ (env) - SCM env; +GUILE_PROC (scm_environ, "environ", 0, 1, 0, + (SCM env), +"") +#define FUNC_NAME s_scm_environ { if (SCM_UNBNDP (env)) return scm_makfromstrs (-1, environ); @@ -866,7 +885,7 @@ scm_environ (env) { char **new_environ; - new_environ = environ_list_to_c (env, SCM_ARG1, s_environ); + new_environ = environ_list_to_c (env, SCM_ARG1, FUNC_NAME); /* Free the old environment, except when called for the first * time. */ @@ -885,151 +904,144 @@ scm_environ (env) return SCM_UNSPECIFIED; } } +#undef FUNC_NAME #ifdef L_tmpnam -SCM_PROC (s_tmpnam, "tmpnam", 0, 0, 0, scm_tmpnam); - -SCM scm_tmpnam() +GUILE_PROC (scm_tmpnam, "tmpnam", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_tmpnam { char name[L_tmpnam]; SCM_SYSCALL (tmpnam (name);); return scm_makfrom0str (name); } -#endif +#undef FUNC_NAME; -SCM_PROC (s_utime, "utime", 1, 2, 0, scm_utime); +#endif -SCM -scm_utime (pathname, actime, modtime) - SCM pathname; - SCM actime; - SCM modtime; +GUILE_PROC (scm_utime, "utime", 1, 2, 0, + (SCM pathname, SCM actime, SCM modtime), +"") +#define FUNC_NAME s_scm_utime { int rv; struct utimbuf utm_tmp; - SCM_ASSERT (SCM_NIMP (pathname) && SCM_ROSTRINGP (pathname), pathname, - SCM_ARG1, s_utime); - + SCM_VALIDATE_ROSTRING(1,pathname); SCM_COERCE_SUBSTR (pathname); if (SCM_UNBNDP (actime)) SCM_SYSCALL (time (&utm_tmp.actime)); else - utm_tmp.actime = scm_num2ulong (actime, (char *) SCM_ARG2, s_utime); + utm_tmp.actime = SCM_NUM2ULONG (2,actime); if (SCM_UNBNDP (modtime)) SCM_SYSCALL (time (&utm_tmp.modtime)); else - utm_tmp.modtime = scm_num2ulong (modtime, (char *) SCM_ARG3, s_utime); + utm_tmp.modtime = SCM_NUM2ULONG (3,modtime); SCM_SYSCALL (rv = utime (SCM_ROCHARS (pathname), &utm_tmp)); if (rv != 0) - scm_syserror (s_utime); + SCM_SYSERROR; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_access, "access?", 2, 0, 0, scm_access); - -SCM -scm_access (path, how) - SCM path; - SCM how; +GUILE_PROC (scm_access, "access?", 2, 0, 0, + (SCM path, SCM how), +"") +#define FUNC_NAME s_scm_access { int rv; - SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, - s_access); + SCM_VALIDATE_ROSTRING(1,path); if (SCM_SUBSTRP (path)) path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0); - SCM_ASSERT (SCM_INUMP (how), how, SCM_ARG2, s_access); + SCM_VALIDATE_INT(2,how); rv = access (SCM_ROCHARS (path), SCM_INUM (how)); return rv ? SCM_BOOL_F : SCM_BOOL_T; } +#undef FUNC_NAME -SCM_PROC (s_getpid, "getpid", 0, 0, 0, scm_getpid); - -SCM -scm_getpid () +GUILE_PROC (scm_getpid, "getpid", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_getpid { return SCM_MAKINUM ((unsigned long) getpid ()); } +#undef FUNC_NAME -SCM_PROC (s_putenv, "putenv", 1, 0, 0, scm_putenv); - -SCM -scm_putenv (str) - SCM str; +GUILE_PROC (scm_putenv, "putenv", 1, 0, 0, + (SCM str), +"") +#define FUNC_NAME s_scm_putenv { int rv; char *ptr; - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_putenv); + SCM_VALIDATE_ROSTRING(1,str); /* must make a new copy to be left in the environment, safe from gc. */ ptr = malloc (SCM_LENGTH (str) + 1); if (ptr == NULL) - scm_memory_error (s_putenv); + SCM_MEMORY_ERROR; strncpy (ptr, SCM_ROCHARS (str), SCM_LENGTH (str)); ptr[SCM_LENGTH(str)] = 0; rv = putenv (ptr); if (rv < 0) - scm_syserror (s_putenv); + SCM_SYSERROR; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_setlocale, "setlocale", 1, 1, 0, scm_setlocale); - -SCM -scm_setlocale (category, locale) - SCM category; - SCM locale; +GUILE_PROC (scm_setlocale, "setlocale", 1, 1, 0, + (SCM category, SCM locale), +"") +#define FUNC_NAME s_scm_setlocale { #ifdef HAVE_SETLOCALE char *clocale; char *rv; - SCM_ASSERT (SCM_INUMP (category), category, SCM_ARG1, s_setlocale); + SCM_VALIDATE_INT(1,category); if (SCM_UNBNDP (locale)) { clocale = NULL; } else { - SCM_ASSERT (SCM_NIMP (locale) && SCM_ROSTRINGP (locale), locale, - SCM_ARG2, s_setlocale); + SCM_VALIDATE_ROSTRING(2,locale); SCM_COERCE_SUBSTR (locale); clocale = SCM_ROCHARS (locale); } rv = setlocale (SCM_INUM (category), clocale); if (rv == NULL) - scm_syserror (s_setlocale); + SCM_SYSERROR; return scm_makfrom0str (rv); #else - scm_sysmissing (s_setlocale); + SCM_SYSMISSING; /* not reached. */ return SCM_BOOL_F; #endif } +#undef FUNC_NAME -SCM_PROC (s_mknod, "mknod", 4, 0, 0, scm_mknod); - -SCM -scm_mknod(path, type, perms, dev) - SCM path; - SCM type; - SCM perms; - SCM dev; +GUILE_PROC (scm_mknod, "mknod", 4, 0, 0, + (SCM path, SCM type, SCM perms, SCM dev), +"") +#define FUNC_NAME s_scm_mknod { #ifdef HAVE_MKNOD int val; char *p; int ctype = 0; - SCM_ASSERT (SCM_NIMP(path) && SCM_ROSTRINGP(path), path, SCM_ARG1, s_mknod); - SCM_ASSERT (SCM_NIMP(type) && SCM_SYMBOLP (type), type, SCM_ARG2, s_mknod); - SCM_ASSERT (SCM_INUMP (perms), perms, SCM_ARG3, s_mknod); - SCM_ASSERT (SCM_INUMP(dev), dev, SCM_ARG4, s_mknod); + SCM_VALIDATE_ROSTRING(1,path); + SCM_VALIDATE_SYMBOL(2,type); + SCM_VALIDATE_INT(3,perms); + SCM_VALIDATE_INT(4,dev); SCM_COERCE_SUBSTR (path); p = SCM_CHARS (type); @@ -1048,53 +1060,55 @@ scm_mknod(path, type, perms, dev) else if (strcmp (p, "socket") == 0) ctype = S_IFSOCK; else - scm_out_of_range (s_mknod, type); + SCM_OUT_OF_RANGE (2,type); SCM_SYSCALL (val = mknod(SCM_ROCHARS(path), ctype | SCM_INUM (perms), SCM_INUM (dev))); if (val != 0) - scm_syserror (s_mknod); + SCM_SYSERROR; return SCM_UNSPECIFIED; #else - scm_sysmissing (s_mknod); + SCM_SYSMISSING; /* not reached. */ return SCM_BOOL_F; #endif } +#undef FUNC_NAME -SCM_PROC (s_nice, "nice", 1, 0, 0, scm_nice); - -SCM -scm_nice(incr) - SCM incr; +GUILE_PROC (scm_nice, "nice", 1, 0, 0, + (SCM incr), +"") +#define FUNC_NAME s_scm_nice { #ifdef HAVE_NICE - SCM_ASSERT(SCM_INUMP(incr), incr, SCM_ARG1, s_nice); + SCM_VALIDATE_INT(1,incr); if (nice(SCM_INUM(incr)) != 0) - scm_syserror (s_nice); + SCM_SYSERROR; return SCM_UNSPECIFIED; #else - scm_sysmissing (s_nice); + SCM_SYSMISSING; /* not reached. */ return SCM_BOOL_F; #endif } +#undef FUNC_NAME -SCM_PROC (s_sync, "sync", 0, 0, 0, scm_sync); - -SCM -scm_sync() +GUILE_PROC (scm_sync, "sync", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_sync { #ifdef HAVE_SYNC sync(); #else - scm_sysmissing (s_sync); + SCM_SYSMISSING; /* not reached. */ #endif return SCM_UNSPECIFIED; } +#undef FUNC_NAME void scm_init_posix () diff --git a/libguile/print.c b/libguile/print.c index ac19075b7..b28a86aa2 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -55,6 +59,7 @@ #include "struct.h" #include "objects.h" +#include "scm_validate.h" #include "print.h" @@ -121,18 +126,18 @@ scm_option scm_print_opts[] = { "Print closures with source." } }; -SCM_PROC (s_print_options, "print-options-interface", 0, 1, 0, scm_print_options); - -SCM -scm_print_options (setting) - SCM setting; +GUILE_PROC (scm_print_options, "print-options-interface", 0, 1, 0, + (SCM setting), +"") +#define FUNC_NAME s_scm_print_options { SCM ans = scm_options (setting, scm_print_opts, SCM_N_PRINT_OPTIONS, - s_print_options); + FUNC_NAME); return ans; } +#undef FUNC_NAME /* {Printing of Scheme Objects} @@ -146,14 +151,14 @@ scm_print_options (setting) * will be O(N). */ #define PUSH_REF(pstate, obj) \ -{ \ +do { \ pstate->ref_stack[pstate->top++] = (obj); \ if (pstate->top == pstate->ceiling) \ grow_ref_stack (pstate); \ -} +} while(0) #define ENTER_NESTED_DATA(pstate, obj, label) \ -{ \ +do { \ register unsigned long i; \ for (i = 0; i < pstate->top; ++i) \ if (pstate->ref_stack[i] == (obj)) \ @@ -167,7 +172,7 @@ scm_print_options (setting) } \ } \ PUSH_REF(pstate, obj); \ -} \ +} while(0) #define EXIT_NESTED_DATA(pstate) { --pstate->top; } @@ -176,21 +181,22 @@ SCM scm_print_state_vtable; static SCM print_state_pool; #ifdef GUILE_DEBUG /* Used for debugging purposes */ -SCM_PROC(s_current_pstate, "current-pstate", 0, 0, 0, scm_current_pstate); -SCM -scm_current_pstate () +GUILE_PROC(scm_current_pstate, "current-pstate", 0, 0, 0, + (), + "") +#define FUNC_NAME s_scm_current_pstate { return SCM_CADR (print_state_pool); } +#undef FUNC_NAME + #endif #define PSTATE_SIZE 50L -static SCM make_print_state SCM_P ((void)); - static SCM -make_print_state () +make_print_state (void) { SCM print_state = scm_make_struct (SCM_CAR (print_state_pool), /* pstate type */ SCM_INUM0, @@ -241,11 +247,8 @@ scm_free_print_state (print_state) SCM_ALLOW_INTS; } -static void grow_ref_stack SCM_P ((scm_print_state *pstate)); - static void -grow_ref_stack (pstate) - scm_print_state *pstate; +grow_ref_stack (scm_print_state *pstate) { int new_size = 2 * pstate->ceiling; scm_vector_set_length_x (pstate->ref_vect, SCM_MAKINUM (new_size)); @@ -254,13 +257,8 @@ grow_ref_stack (pstate) } -static void print_circref SCM_P ((SCM port, scm_print_state *pstate, SCM ref)); - static void -print_circref (port, pstate, ref) - SCM port; - scm_print_state *pstate; - SCM ref; +print_circref (SCM port,scm_print_state *pstate,SCM ref) { register int i; int self = pstate->top - 1; @@ -290,10 +288,7 @@ SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write); SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display); void -scm_iprin1 (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) { taloop: switch (7 & (int) exp) @@ -703,10 +698,7 @@ taloop: * useful for continuing a chain of print calls from Scheme. */ void -scm_prin1 (exp, port, writingp) - SCM exp; - SCM port; - int writingp; +scm_prin1 (SCM exp, SCM port, int writingp) { SCM handle = SCM_BOOL_F; /* Will GC protect the handle whilst unlinked */ SCM pstate_scm; @@ -756,10 +748,7 @@ scm_prin1 (exp, port, writingp) */ void -scm_intprint (n, radix, port) - long n; - int radix; - SCM port; +scm_intprint (long n, int radix, SCM port) { char num_buf[SCM_INTBUFLEN]; scm_lfwrite (num_buf, scm_iint2str (n, radix, num_buf), port); @@ -769,10 +758,7 @@ scm_intprint (n, radix, port) */ void -scm_ipruk (hdr, ptr, port) - char *hdr; - SCM ptr; - SCM port; +scm_ipruk (char *hdr, SCM ptr, SCM port) { scm_puts ("#top - 2; @@ -915,9 +896,7 @@ scm_valid_oport_value_p (SCM val) /* SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write); */ SCM -scm_write (obj, port) - SCM obj; - SCM port; +scm_write (SCM obj, SCM port) { if (SCM_UNBNDP (port)) port = scm_cur_outp; @@ -938,9 +917,7 @@ scm_write (obj, port) /* SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display); */ SCM -scm_display (obj, port) - SCM obj; - SCM port; +scm_display (SCM obj, SCM port) { if (SCM_UNBNDP (port)) port = scm_cur_outp; @@ -957,34 +934,32 @@ scm_display (obj, port) return SCM_UNSPECIFIED; } -SCM_PROC(s_newline, "newline", 0, 1, 0, scm_newline); - -SCM -scm_newline (port) - SCM port; +GUILE_PROC(scm_newline, "newline", 0, 1, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_newline { if (SCM_UNBNDP (port)) port = scm_cur_outp; - SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG1, s_newline); + SCM_VALIDATE_OPORT_VALUE(1,port); scm_putc ('\n', SCM_COERCE_OUTPORT (port)); return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_write_char, "write-char", 1, 1, 0, scm_write_char); - -SCM -scm_write_char (chr, port) - SCM chr; - SCM port; +GUILE_PROC(scm_write_char, "write-char", 1, 1, 0, + (SCM chr, SCM port), +"") +#define FUNC_NAME s_scm_write_char { if (SCM_UNBNDP (port)) port = scm_cur_outp; - SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write_char); + SCM_VALIDATE_CHAR(1,chr); + SCM_VALIDATE_OPORT_VALUE(2,port); - SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG1, s_write_char); scm_putc ((int) SCM_ICHR (chr), SCM_COERCE_OUTPORT (port)); #ifdef HAVE_PIPE # ifdef EPIPE @@ -994,6 +969,7 @@ scm_write_char (chr, port) #endif return SCM_UNSPECIFIED; } +#undef FUNC_NAME @@ -1017,9 +993,7 @@ print_port_with_ps (SCM obj, SCM port, scm_print_state *pstate) } SCM -scm_printer_apply (proc, exp, port, pstate) - SCM proc, exp, port; - scm_print_state *pstate; +scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *pstate) { SCM pwps; SCM pair = scm_cons (port, pstate->handle); @@ -1028,25 +1002,24 @@ scm_printer_apply (proc, exp, port, pstate) return scm_apply (proc, exp, scm_cons (pwps, scm_listofnull)); } -SCM_PROC (s_port_with_print_state, "port-with-print-state", 2, 0, 0, scm_port_with_print_state); - -SCM -scm_port_with_print_state (SCM port, SCM pstate) +GUILE_PROC (scm_port_with_print_state, "port-with-print-state", 2, 0, 0, + (SCM port, SCM pstate), +"") +#define FUNC_NAME s_scm_port_with_print_state { SCM pwps; - SCM_ASSERT (scm_valid_oport_value_p (port), - port, SCM_ARG1, s_port_with_print_state); - SCM_ASSERT (SCM_NIMP (pstate) && SCM_PRINT_STATE_P (pstate), - pstate, SCM_ARG2, s_port_with_print_state); + SCM_VALIDATE_OPORT_VALUE(1,port); + SCM_VALIDATE_PRINTSTATE(2,pstate); port = SCM_COERCE_OUTPORT (port); SCM_NEWSMOB (pwps, scm_tc16_port_with_ps, scm_cons (port, pstate)); return pwps; } +#undef FUNC_NAME -SCM_PROC (s_get_print_state, "get-print-state", 1, 0, 0, scm_get_print_state); - -SCM -scm_get_print_state (SCM port) +GUILE_PROC (scm_get_print_state, "get-print-state", 1, 0, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_get_print_state { if (SCM_NIMP (port)) { @@ -1055,8 +1028,9 @@ scm_get_print_state (SCM port) if (SCM_OUTPORTP (port)) return SCM_BOOL_F; } - return scm_wta (port, (char *) SCM_ARG1, s_get_print_state); + RETURN_SCM_WTA (1,port); } +#undef FUNC_NAME diff --git a/libguile/procprop.c b/libguile/procprop.c index d3ff6da38..efdc08318 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -49,6 +53,7 @@ #include "gsubr.h" #include "objects.h" +#include "scm_validate.h" #include "procprop.h" @@ -141,8 +146,7 @@ scm_i_procedure_arity (SCM proc) } static SCM -scm_stand_in_scm_proc(proc) - SCM proc; +scm_stand_in_scm_proc(SCM proc) { SCM answer; answer = scm_assoc (proc, scm_stand_in_procs); @@ -158,74 +162,65 @@ scm_stand_in_scm_proc(proc) return answer; } -SCM_PROC(s_procedure_properties, "procedure-properties", 1, 0, 0, scm_procedure_properties); - -SCM -scm_procedure_properties (proc) - SCM proc; +GUILE_PROC(scm_procedure_properties, "procedure-properties", 1, 0, 0, + (SCM proc), +"") +#define FUNC_NAME s_scm_procedure_properties { - SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (proc)), - proc, SCM_ARG1, s_procedure_properties); + SCM_VALIDATE_PROC(1,proc); return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc), SCM_PROCPROPS (SCM_NIMP (proc) && SCM_CLOSUREP (proc) ? proc : scm_stand_in_scm_proc (proc))); } +#undef FUNC_NAME -SCM_PROC(s_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0, scm_set_procedure_properties_x); - -SCM -scm_set_procedure_properties_x (proc, new_val) - SCM proc; - SCM new_val; +GUILE_PROC(scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0, + (SCM proc, SCM new_val), +"") +#define FUNC_NAME s_scm_set_procedure_properties_x { if (!(SCM_NIMP (proc) && SCM_CLOSUREP (proc))) proc = scm_stand_in_scm_proc(proc); - SCM_ASSERT (SCM_NIMP (proc) && SCM_CLOSUREP (proc), proc, SCM_ARG1, s_set_procedure_properties_x); + SCM_VALIDATE_CLOSURE(1,proc); SCM_SETPROCPROPS (proc, new_val); return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_procedure_property, "procedure-property", 2, 0, 0, scm_procedure_property); - -SCM -scm_procedure_property (p, k) - SCM p; - SCM k; +GUILE_PROC(scm_procedure_property, "procedure-property", 2, 0, 0, + (SCM p, SCM k), +"") +#define FUNC_NAME s_scm_procedure_property { SCM assoc; if (k == scm_sym_arity) { SCM arity; SCM_ASSERT (SCM_NFALSEP (arity = scm_i_procedure_arity (p)), - p, SCM_ARG1, s_procedure_property); + p, SCM_ARG1, FUNC_NAME); return arity; } - SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (p)), - p, SCM_ARG1, s_procedure_property); + SCM_VALIDATE_PROC(1,p); assoc = scm_sloppy_assq (k, SCM_PROCPROPS (SCM_NIMP (p) && SCM_CLOSUREP (p) ? p : scm_stand_in_scm_proc (p))); return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F); } +#undef FUNC_NAME -SCM_PROC(s_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, scm_set_procedure_property_x); - -SCM -scm_set_procedure_property_x (p, k, v) - SCM p; - SCM k; - SCM v; +GUILE_PROC(scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, + (SCM p, SCM k, SCM v), +"") +#define FUNC_NAME s_scm_set_procedure_property_x { SCM assoc; if (!(SCM_NIMP (p) && SCM_CLOSUREP (p))) p = scm_stand_in_scm_proc(p); - SCM_ASSERT (SCM_NIMP (p) && SCM_CLOSUREP (p), p, SCM_ARG1, s_set_procedure_property_x); + SCM_VALIDATE_CLOSURE(1,p); if (k == scm_sym_arity) - scm_misc_error (s_set_procedure_property_x, - "arity is a read-only property", - SCM_EOL); + SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL); assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p)); if (SCM_NIMP (assoc)) SCM_SETCDR (assoc, v); @@ -233,6 +228,7 @@ scm_set_procedure_property_x (p, k, v) SCM_SETPROCPROPS (p, scm_acons (k, v, SCM_PROCPROPS (p))); return SCM_UNSPECIFIED; } +#undef FUNC_NAME diff --git a/libguile/procs.c b/libguile/procs.c index 3ca45f1f5..fcd0bfa57 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -45,6 +49,7 @@ #include "objects.h" +#include "scm_validate.h" #include "procs.h" @@ -60,11 +65,7 @@ int scm_subr_table_size = 0; int scm_subr_table_room = 750; SCM -scm_make_subr_opt (name, type, fcn, set) - const char *name; - int type; - SCM (*fcn) (); - int set; +scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set) { SCM symcell; register SCM z; @@ -115,10 +116,7 @@ scm_free_subr_entry (SCM subr) } SCM -scm_make_subr (name, type, fcn) - const char *name; - int type; - SCM (*fcn) (); +scm_make_subr (const char *name, int type, SCM (*fcn) ()) { return scm_make_subr_opt (name, type, fcn, 1); } @@ -150,9 +148,7 @@ scm_mark_subr_table () #ifdef CCLO SCM -scm_makcclo (proc, len) - SCM proc; - long len; +scm_makcclo (SCM proc, long len) { SCM s; SCM_NEWCELL (s); @@ -168,25 +164,23 @@ scm_makcclo (proc, len) /* Undocumented debugging procedure */ #ifdef GUILE_DEBUG -SCM_PROC (s_make_cclo, "make-cclo", 2, 0, 0, scm_make_cclo); - -SCM -scm_make_cclo (proc, len) - SCM proc; - SCM len; +GUILE_PROC (scm_make_cclo, "make-cclo", 2, 0, 0, + (SCM proc, SCM len), +"") +#define FUNC_NAME s_scm_make_cclo { return scm_makcclo (proc, SCM_INUM (len)); } +#undef FUNC_NAME #endif #endif -SCM_PROC(s_procedure_p, "procedure?", 1, 0, 0, scm_procedure_p); - -SCM -scm_procedure_p (obj) - SCM obj; +GUILE_PROC(scm_procedure_p, "procedure?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_procedure_p { if (SCM_NIMP (obj)) switch (SCM_TYP7 (obj)) @@ -207,26 +201,21 @@ scm_procedure_p (obj) } return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC(s_closure_p, "closure?", 1, 0, 0, scm_closure_p); - -SCM -scm_closure_p (obj) - SCM obj; +GUILE_PROC(scm_closure_p, "closure?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_closure_p { - return SCM_NIMP (obj) && SCM_CLOSUREP (obj) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(SCM_NIMP (obj) && SCM_CLOSUREP (obj)); } +#undef FUNC_NAME -SCM_PROC(s_thunk_p, "thunk?", 1, 0, 0, scm_thunk_p); - -#ifdef __STDC__ -SCM -scm_thunk_p (SCM obj) -#else -SCM -scm_thunk_p (obj) - SCM obj; -#endif +GUILE_PROC(scm_thunk_p, "thunk?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_thunk_p { if (SCM_NIMP (obj)) { @@ -254,6 +243,7 @@ scm_thunk_p (obj) } return SCM_BOOL_F; } +#undef FUNC_NAME /* Only used internally. */ int @@ -270,15 +260,14 @@ scm_subr_p (SCM obj) return 0; } -SCM_PROC(s_procedure_documentation, "procedure-documentation", 1, 0, 0, scm_procedure_documentation); - -SCM -scm_procedure_documentation (proc) - SCM proc; +GUILE_PROC(scm_procedure_documentation, "procedure-documentation", 1, 0, 0, + (SCM proc), +"") +#define FUNC_NAME s_scm_procedure_documentation { SCM code; SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc) && SCM_NIMP (proc) && SCM_TYP7 (proc) != scm_tc7_contin, - proc, SCM_ARG1, s_procedure_documentation); + proc, SCM_ARG1, FUNC_NAME); switch (SCM_TYP7 (proc)) { case scm_tcs_closures: @@ -300,31 +289,29 @@ scm_procedure_documentation (proc) */ } } +#undef FUNC_NAME /* Procedure-with-setter */ -SCM_PROC (s_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0, scm_procedure_with_setter_p); - -SCM -scm_procedure_with_setter_p (SCM obj) +GUILE_PROC (scm_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_procedure_with_setter_p { - return (SCM_NIMP (obj) && SCM_PROCEDURE_WITH_SETTER_P (obj) - ? SCM_BOOL_T - : SCM_BOOL_F); + return SCM_BOOL(SCM_NIMP (obj) && SCM_PROCEDURE_WITH_SETTER_P (obj)); } +#undef FUNC_NAME -SCM_PROC (s_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, 0, scm_make_procedure_with_setter); - -SCM -scm_make_procedure_with_setter (SCM procedure, SCM setter) +GUILE_PROC (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, 0, + (SCM procedure, SCM setter), + "") +#define FUNC_NAME s_scm_make_procedure_with_setter { SCM z; - SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (procedure)), - procedure, SCM_ARG1, s_make_procedure_with_setter); - SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (setter)), - setter, SCM_ARG2, s_make_procedure_with_setter); + SCM_VALIDATE_PROC(1,procedure); + SCM_VALIDATE_PROC(2,setter); SCM_NEWCELL (z); SCM_ENTER_A_SECTION; SCM_SETCDR (z, scm_cons (procedure, setter)); @@ -332,23 +319,25 @@ scm_make_procedure_with_setter (SCM procedure, SCM setter) SCM_EXIT_A_SECTION; return z; } +#undef FUNC_NAME -SCM_PROC (s_procedure, "procedure", 1, 0, 0, scm_procedure); - -SCM -scm_procedure (SCM proc) +GUILE_PROC (scm_procedure, "procedure", 1, 0, 0, + (SCM proc), + "") +#define FUNC_NAME s_scm_procedure { - SCM_ASSERT (SCM_NIMP (proc), proc, SCM_ARG1, s_procedure); + SCM_VALIDATE_NIMP(1,proc); if (SCM_PROCEDURE_WITH_SETTER_P (proc)) return SCM_PROCEDURE (proc); else if (SCM_STRUCTP (proc)) { - SCM_ASSERT (SCM_I_OPERATORP (proc), proc, SCM_ARG1, s_procedure); + SCM_ASSERT (SCM_I_OPERATORP (proc), proc, SCM_ARG1, FUNC_NAME); return proc; } - scm_wrong_type_arg (s_procedure, SCM_ARG1, proc); + SCM_WRONG_TYPE_ARG (1, proc); return 0; /* not reached */ } +#undef FUNC_NAME SCM_GPROC (s_setter, "setter", 1, 0, 0, scm_setter, g_setter); @@ -376,9 +365,7 @@ scm_setter (SCM proc) void -scm_init_iprocs(subra, type) - const scm_iproc *subra; - int type; +scm_init_iprocs(const scm_iproc *subra, int type) { for(;subra->scm_string; subra++) scm_make_subr(subra->scm_string, diff --git a/libguile/ramap.c b/libguile/ramap.c index 3f09fad45..813fd1d7a 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + @@ -52,9 +56,12 @@ #include "eval.h" #include "feature.h" +#include "scm_validate.h" #include "ramap.h" +#define SCM_RAMAPC(ramap,proc,ra0,lra) do { scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME); } while (0) + typedef struct { char *name; @@ -111,12 +118,8 @@ static ra_iproc ra_asubrs[] = /* inds must be a uvect or ivect, no check. */ -static scm_sizet cind SCM_P ((SCM ra, SCM inds)); - static scm_sizet -cind (ra, inds) - SCM ra; - SCM inds; +cind (SCM ra, SCM inds) { scm_sizet i; int k; @@ -253,16 +256,16 @@ scm_ra_matchp (ra0, ras) return exact; } -/* array mapper: apply cproc to each dimension of the given arrays?. */ -int -scm_ramapc (cproc, data, ra0, lra, what) - int (*cproc) (); /* procedure to call on unrolled arrays? +/* array mapper: apply cproc to each dimension of the given arrays?. + int (*cproc) (); procedure to call on unrolled arrays? cproc (dest, source list) or - cproc (dest, data, source list). */ - SCM data; /* data to give to cproc or unbound. */ - SCM ra0; /* destination array. */ - SCM lra; /* list of source arrays. */ - const char *what; /* caller, for error reporting. */ + cproc (dest, data, source list). + SCM data; data to give to cproc or unbound. + SCM ra0; destination array. + SCM lra; list of source arrays. + const char *what; caller, for error reporting. */ +int +scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) { SCM inds, z; SCM vra0, ra1, vra1; @@ -404,24 +407,21 @@ scm_ramapc (cproc, data, ra0, lra, what) } -SCM_PROC(s_array_fill_x, "array-fill!", 2, 0, 0, scm_array_fill_x); - -SCM -scm_array_fill_x (ra, fill) - SCM ra; - SCM fill; +GUILE_PROC(scm_array_fill_x, "array-fill!", 2, 0, 0, + (SCM ra, SCM fill), +"") +#define FUNC_NAME s_scm_array_fill_x { - scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, s_array_fill_x); + SCM_RAMAPC (scm_array_fill_int, fill, ra, SCM_EOL); return SCM_UNSPECIFIED; } +#undef FUNC_NAME /* to be used as cproc in scm_ramapc to fill an array dimension with "fill". */ int -scm_array_fill_int (ra, fill, ignore) - SCM ra; - SCM fill; - SCM ignore; +scm_array_fill_int (SCM ra, SCM fill, SCM ignore) +#define FUNC_NAME s_scm_array_fill_x { scm_sizet i; scm_sizet n = SCM_ARRAY_DIMS (ra)->ubnd - SCM_ARRAY_DIMS (ra)->lbnd + 1; @@ -455,7 +455,7 @@ scm_array_fill_int (ra, fill, ignore) SCM_CHARS (ra)[i] = SCM_INUM (fill); break; case scm_tc7_bvect: - { + { /* scope */ long *ve = (long *) SCM_VELTS (ra); if (1 == inc && (n >= SCM_LONG_BIT || n == SCM_LENGTH (ra))) { @@ -479,7 +479,7 @@ scm_array_fill_int (ra, fill, ignore) ve[i] |= ~(~0L << ((base + n) % SCM_LONG_BIT)); } else - badarg2:scm_wta (fill, (char *) SCM_ARG2, s_array_fill_x); + badarg2:SCM_WTA (2,fill); } else { @@ -495,9 +495,8 @@ scm_array_fill_int (ra, fill, ignore) break; } case scm_tc7_uvect: - { - unsigned long f = scm_num2ulong (fill, (char *) SCM_ARG2, - s_array_fill_x); + { /* scope */ + unsigned long f = SCM_NUM2ULONG (2,fill); unsigned long *ve = (long *) SCM_VELTS (ra); for (i = base; n--; i += inc) @@ -505,8 +504,8 @@ scm_array_fill_int (ra, fill, ignore) break; } case scm_tc7_ivect: - { - long f = scm_num2long (fill, (char *) SCM_ARG2, s_array_fill_x); + { /* scope */ + long f = SCM_NUM2LONG (2,fill); long *ve = (long *) SCM_VELTS (ra); for (i = base; n--; i += inc) @@ -515,21 +514,20 @@ scm_array_fill_int (ra, fill, ignore) } case scm_tc7_svect: SCM_ASRTGO (SCM_INUMP (fill), badarg2); - { + { /* scope */ short f = SCM_INUM (fill); short *ve = (short *) SCM_VELTS (ra); if (f != SCM_INUM (fill)) - scm_out_of_range (s_array_fill_x, fill); + SCM_OUT_OF_RANGE (2, fill); for (i = base; n--; i += inc) ve[i] = f; break; } #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: - { - long long f = scm_num2long_long (fill, (char *) SCM_ARG2, - s_array_fill_x); + { /* scope */ + long long f = SCM_NUM2LONG_LONG (2,fill); long long *ve = (long long *) SCM_VELTS (ra); for (i = base; n--; i += inc) @@ -540,7 +538,7 @@ scm_array_fill_int (ra, fill, ignore) #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: - { + { /* scope */ float f, *ve = (float *) SCM_VELTS (ra); SCM_ASRTGO (SCM_NIMP (fill) && SCM_REALP (fill), badarg2); f = SCM_REALPART (fill); @@ -550,7 +548,7 @@ scm_array_fill_int (ra, fill, ignore) } #endif /* SCM_SINGLES */ case scm_tc7_dvect: - { + { /* scope */ double f, *ve = (double *) SCM_VELTS (ra); SCM_ASRTGO (SCM_NIMP (fill) && SCM_REALP (fill), badarg2); f = SCM_REALPART (fill); @@ -559,7 +557,7 @@ scm_array_fill_int (ra, fill, ignore) break; } case scm_tc7_cvect: - { + { /* scope */ double fr, fi; double (*ve)[2] = (double (*)[2]) SCM_VELTS (ra); SCM_ASRTGO (SCM_NIMP (fill) && SCM_INEXP (fill), badarg2); @@ -576,16 +574,11 @@ scm_array_fill_int (ra, fill, ignore) } return 1; } +#undef FUNC_NAME - - -static int racp SCM_P ((SCM dst, SCM src)); - static int -racp (src, dst) - SCM dst; - SCM src; +racp (SCM src, SCM dst) { long n = (SCM_ARRAY_DIMS (src)->ubnd - SCM_ARRAY_DIMS (src)->lbnd + 1); long inc_d, inc_s = SCM_ARRAY_DIMS (src)->inc; @@ -777,29 +770,29 @@ racp (src, dst) #endif /* SCM_FLOATS */ return 1; } +#undef FUNC_NAME /* This name is obsolete. Will go away in release 1.5. */ -SCM_PROC(s_serial_array_copy_x, "serial-array-copy!", 2, 0, 0, scm_array_copy_x); -SCM_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x); -SCM_PROC(s_array_copy_x, "array-copy!", 2, 0, 0, scm_array_copy_x); +SCM_REGISTER_PROC(s_serial_array_copy_x, "serial-array-copy!", 2, 0, 0, scm_array_copy_x); +SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x); -SCM -scm_array_copy_x (src, dst) - SCM src; - SCM dst; + +GUILE_PROC(scm_array_copy_x, "array-copy!", 2, 0, 0, + (SCM src, SCM dst), +"") +#define FUNC_NAME s_scm_array_copy_x { - scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), s_array_copy_x); + SCM_RAMAPC (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL)); return SCM_UNSPECIFIED; } +#undef FUNC_NAME /* Functions callable by ARRAY-MAP! */ int -scm_ra_eqp (ra0, ras) - SCM ra0; - SCM ras; +scm_ra_eqp (SCM ra0, SCM ras) { SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras)); long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; @@ -857,14 +850,8 @@ scm_ra_eqp (ra0, ras) /* opt 0 means <, nonzero means >= */ -static int ra_compare SCM_P ((SCM ra0, SCM ra1, SCM ra2, int opt)); - static int -ra_compare (ra0, ra1, ra2, opt) - SCM ra0; - SCM ra1; - SCM ra2; - int opt; +ra_compare (SCM ra0,SCM ra1,SCM ra2,int opt) { long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2); @@ -925,46 +912,35 @@ ra_compare (ra0, ra1, ra2, opt) int -scm_ra_lessp (ra0, ras) - SCM ra0; - SCM ras; +scm_ra_lessp (SCM ra0, SCM ras) { return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0); } int -scm_ra_leqp (ra0, ras) - SCM ra0; - SCM ras; +scm_ra_leqp (SCM ra0, SCM ras) { return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1); } int -scm_ra_grp (ra0, ras) - SCM ra0; - SCM ras; +scm_ra_grp (SCM ra0, SCM ras) { return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0); } int -scm_ra_greqp (ra0, ras) - SCM ra0; - SCM ras; +scm_ra_greqp (SCM ra0, SCM ras) { return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1); } - int -scm_ra_sum (ra0, ras) - SCM ra0; - SCM ras; +scm_ra_sum (SCM ra0, SCM ras) { long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; scm_sizet i0 = SCM_ARRAY_BASE (ra0); @@ -1039,9 +1015,7 @@ scm_ra_sum (ra0, ras) int -scm_ra_difference (ra0, ras) - SCM ra0; - SCM ras; +scm_ra_difference (SCM ra0, SCM ras) { long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; scm_sizet i0 = SCM_ARRAY_BASE (ra0); @@ -1146,9 +1120,7 @@ scm_ra_difference (ra0, ras) int -scm_ra_product (ra0, ras) - SCM ra0; - SCM ras; +scm_ra_product (SCM ra0, SCM ras) { long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; scm_sizet i0 = SCM_ARRAY_BASE (ra0); @@ -1224,9 +1196,7 @@ scm_ra_product (ra0, ras) int -scm_ra_divide (ra0, ras) - SCM ra0; - SCM ras; +scm_ra_divide (SCM ra0, SCM ras) { long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; scm_sizet i0 = SCM_ARRAY_BASE (ra0); @@ -1335,22 +1305,15 @@ scm_ra_divide (ra0, ras) int -scm_array_identity (dst, src) - SCM src; - SCM dst; +scm_array_identity (SCM dst, SCM src) { return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL)); } -static int ramap SCM_P ((SCM ra0, SCM proc, SCM ras)); - static int -ramap (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; +ramap (SCM ra0,SCM proc,SCM ras) { long i = SCM_ARRAY_DIMS (ra0)->lbnd; long inc = SCM_ARRAY_DIMS (ra0)->inc; @@ -1388,13 +1351,8 @@ ramap (ra0, proc, ras) } -static int ramap_cxr SCM_P ((SCM ra0, SCM proc, SCM ras)); - static int -ramap_cxr (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; +ramap_cxr (SCM ra0,SCM proc,SCM ras) { SCM ra1 = SCM_CAR (ras); SCM e1 = SCM_UNDEFINED; @@ -1458,13 +1416,8 @@ ramap_cxr (ra0, proc, ras) -static int ramap_rp SCM_P ((SCM ra0, SCM proc, SCM ras)); - static int -ramap_rp (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; +ramap_rp (SCM ra0,SCM proc,SCM ras) { SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras)); SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED; @@ -1545,13 +1498,8 @@ ramap_rp (ra0, proc, ras) -static int ramap_1 SCM_P ((SCM ra0, SCM proc, SCM ras)); - static int -ramap_1 (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; +ramap_1 (SCM ra0,SCM proc,SCM ras) { SCM ra1 = SCM_CAR (ras); SCM e1 = SCM_UNDEFINED; @@ -1571,13 +1519,8 @@ ramap_1 (ra0, proc, ras) -static int ramap_2o SCM_P ((SCM ra0, SCM proc, SCM ras)); - static int -ramap_2o (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; +ramap_2o (SCM ra0,SCM proc,SCM ras) { SCM ra1 = SCM_CAR (ras); SCM e1 = SCM_UNDEFINED; @@ -1623,13 +1566,8 @@ ramap_2o (ra0, proc, ras) -static int ramap_a SCM_P ((SCM ra0, SCM proc, SCM ras)); - static int -ramap_a (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; +ramap_a (SCM ra0,SCM proc,SCM ras) { SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; @@ -1653,34 +1591,33 @@ ramap_a (ra0, proc, ras) } /* This name is obsolete. Will go away in release 1.5. */ -SCM_PROC(s_serial_array_map_x, "serial-array-map!", 2, 0, 1, scm_array_map_x); -SCM_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x); -SCM_PROC(s_array_map_x, "array-map!", 2, 0, 1, scm_array_map_x); +SCM_REGISTER_PROC(s_serial_array_map_x, "serial-array-map!", 2, 0, 1, scm_array_map_x); +SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x); -SCM -scm_array_map_x (ra0, proc, lra) - SCM ra0; - SCM proc; - SCM lra; + +GUILE_PROC(scm_array_map_x, "array-map!", 2, 0, 1, + (SCM ra0, SCM proc, SCM lra), +"") +#define FUNC_NAME s_scm_array_map_x { - SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG2, s_array_map_x); + SCM_VALIDATE_PROC(2,proc); switch (SCM_TYP7 (proc)) { default: gencase: - scm_ramapc (ramap, proc, ra0, lra, s_array_map_x); + SCM_RAMAPC (ramap, proc, ra0, lra); return SCM_UNSPECIFIED; case scm_tc7_subr_1: - scm_ramapc (ramap_1, proc, ra0, lra, s_array_map_x); + SCM_RAMAPC (ramap_1, proc, ra0, lra); return SCM_UNSPECIFIED; case scm_tc7_subr_2: case scm_tc7_subr_2o: - scm_ramapc (ramap_2o, proc, ra0, lra, s_array_map_x); + SCM_RAMAPC (ramap_2o, proc, ra0, lra); return SCM_UNSPECIFIED; case scm_tc7_cxr: if (!SCM_SUBRF (proc)) goto gencase; - scm_ramapc (ramap_cxr, proc, ra0, lra, s_array_map_x); + SCM_RAMAPC (ramap_cxr, proc, ra0, lra); return SCM_UNSPECIFIED; case scm_tc7_rpsubr: { @@ -1693,14 +1630,14 @@ scm_array_map_x (ra0, proc, lra) { while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra))) { - scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, s_array_map_x); + SCM_RAMAPC (p->vproc, SCM_UNDEFINED, ra0, lra); lra = SCM_CDR (lra); } return SCM_UNSPECIFIED; } while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra))) { - scm_ramapc (ramap_rp, proc, ra0, lra, s_array_map_x); + SCM_RAMAPC (ramap_rp, proc, ra0, lra); lra = SCM_CDR (lra); } return SCM_UNSPECIFIED; @@ -1739,34 +1676,30 @@ scm_array_map_x (ra0, proc, lra) if (proc == p->sproc) { if (ra0 != SCM_CAR (lra)) - scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), s_array_map_x); + SCM_RAMAPC (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL)); lra = SCM_CDR (lra); while (1) { - scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, s_array_map_x); + SCM_RAMAPC (p->vproc, SCM_UNDEFINED, ra0, lra); if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra))) return SCM_UNSPECIFIED; lra = SCM_CDR (lra); } } - scm_ramapc (ramap_2o, proc, ra0, lra, s_array_map_x); + SCM_RAMAPC (ramap_2o, proc, ra0, lra); lra = SCM_CDR (lra); if (SCM_NIMP (lra)) for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra)) - scm_ramapc (ramap_a, proc, ra0, lra, s_array_map_x); + SCM_RAMAPC (ramap_a, proc, ra0, lra); } return SCM_UNSPECIFIED; } } +#undef FUNC_NAME -static int rafe SCM_P ((SCM ra0, SCM proc, SCM ras)); - static int -rafe (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; +rafe (SCM ra0,SCM proc,SCM ras) { long i = SCM_ARRAY_DIMS (ra0)->lbnd; scm_sizet i0 = SCM_ARRAY_BASE (ra0); @@ -1804,34 +1737,29 @@ rafe (ra0, proc, ras) } -SCM_PROC(s_array_for_each, "array-for-each", 2, 0, 1, scm_array_for_each); - -SCM -scm_array_for_each (proc, ra0, lra) - SCM proc; - SCM ra0; - SCM lra; +GUILE_PROC(scm_array_for_each, "array-for-each", 2, 0, 1, + (SCM proc, SCM ra0, SCM lra), +"") +#define FUNC_NAME s_scm_array_for_each { - SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG1, s_array_for_each); - scm_ramapc (rafe, proc, ra0, lra, s_array_for_each); + SCM_VALIDATE_PROC(1,proc); + SCM_RAMAPC (rafe, proc, ra0, lra); return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_array_index_map_x, "array-index-map!", 2, 0, 0, scm_array_index_map_x); - -SCM -scm_array_index_map_x (ra, proc) - SCM ra; - SCM proc; +GUILE_PROC(scm_array_index_map_x, "array-index-map!", 2, 0, 0, + (SCM ra, SCM proc), +"") +#define FUNC_NAME s_scm_array_index_map_x { scm_sizet i; - SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, s_array_index_map_x); - SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG2, - s_array_index_map_x); + SCM_VALIDATE_NIMP(1,ra); + SCM_VALIDATE_PROC(2,proc); switch (SCM_TYP7(ra)) { default: - badarg:scm_wta (ra, (char *) SCM_ARG1, s_array_index_map_x); + badarg:SCM_WTA (1,ra); case scm_tc7_vector: case scm_tc7_wvect: { @@ -1901,15 +1829,11 @@ scm_array_index_map_x (ra, proc) } } } +#undef FUNC_NAME -static int raeql_1 SCM_P ((SCM ra0, SCM as_equal, SCM ra1)); - static int -raeql_1 (ra0, as_equal, ra1) - SCM ra0; - SCM as_equal; - SCM ra1; +raeql_1 (SCM ra0,SCM as_equal,SCM ra1) { SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; scm_sizet i0 = 0, i1 = 0; @@ -2030,13 +1954,8 @@ raeql_1 (ra0, as_equal, ra1) -static int raeql SCM_P ((SCM ra0, SCM as_equal, SCM ra1)); - static int -raeql (ra0, as_equal, ra1) - SCM ra0; - SCM as_equal; - SCM ra1; +raeql (SCM ra0,SCM as_equal,SCM ra1) { SCM v0 = ra0, v1 = ra1; scm_array_dim dim0, dim1; @@ -2093,9 +2012,7 @@ raeql (ra0, as_equal, ra1) SCM -scm_raequal (ra0, ra1) - SCM ra0; - SCM ra1; +scm_raequal (SCM ra0, SCM ra1) { return (raeql (ra0, SCM_BOOL_T, ra1) ? SCM_BOOL_T : SCM_BOOL_F); } @@ -2104,9 +2021,7 @@ static char s_array_equal_p[] = "array-equal?"; SCM -scm_array_equal_p (ra0, ra1) - SCM ra0; - SCM ra1; +scm_array_equal_p (SCM ra0, SCM ra1) { if (SCM_IMP (ra0) || SCM_IMP (ra1)) callequal:return scm_equal_p (ra0, ra1); @@ -2154,8 +2069,7 @@ scm_array_equal_p (ra0, ra1) static void -init_raprocs (subra) - ra_iproc *subra; +init_raprocs (ra_iproc *subra) { for (; subra->name; subra++) subra->sproc = SCM_CDR (scm_intern (subra->name, strlen (subra->name))); @@ -2170,5 +2084,5 @@ scm_init_ramap () scm_make_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p); scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp = scm_raequal; #include "ramap.x" - scm_add_feature (s_array_for_each); + scm_add_feature (s_scm_array_for_each); } diff --git a/libguile/random.c b/libguile/random.c index de4c6a797..cdfbb0b83 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -38,6 +38,10 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + + /* Author: Mikael Djurfeldt */ #include "_scm.h" @@ -49,6 +53,7 @@ #include "numbers.h" #include "feature.h" +#include "scm_validate.h" #include "random.h" @@ -345,85 +350,77 @@ free_rstate (SCM rstate) SCM_GLOBAL_VCELL_INIT (scm_var_random_state, "*random-state*", scm_seed_to_random_state (scm_makfrom0str ("URL:http://stat.fsu.edu/~geo/diehard.html"))); -SCM_PROC (s_random, "random", 1, 1, 0, scm_random); - -SCM -scm_random (SCM n, SCM state) +GUILE_PROC (scm_random, "random", 1, 1, 0, + (SCM n, SCM state), + "") +#define FUNC_NAME s_scm_random { if (SCM_UNBNDP (state)) state = SCM_CDR (scm_var_random_state); - SCM_ASSERT (SCM_NIMP (state) && SCM_RSTATEP (state), - state, SCM_ARG2, s_random); + SCM_VALIDATE_RSTATE(2,state); if (SCM_INUMP (n)) { unsigned long m = SCM_INUM (n); - SCM_ASSERT (m > 0, n, SCM_ARG1, s_random); + SCM_ASSERT_RANGE (1,n,m > 0); return SCM_MAKINUM (scm_c_random (SCM_RSTATE (state), m)); } - SCM_ASSERT (SCM_NIMP (n), n, SCM_ARG1, s_random); + SCM_VALIDATE_NIMP(1,n); if (SCM_REALP (n)) return scm_makdbl (SCM_REALPART (n) * scm_c_uniform01 (SCM_RSTATE (state)), 0.0); - SCM_ASSERT (SCM_TYP16 (n) == scm_tc16_bigpos, n, SCM_ARG1, s_random); + SCM_VALIDATE_SMOB (1,n,bigpos); return scm_c_random_bignum (SCM_RSTATE (state), n); } +#undef FUNC_NAME -SCM_PROC (s_copy_random_state, "copy-random-state", 0, 1, 0, scm_copy_random_state); - -SCM -scm_copy_random_state (SCM state) +GUILE_PROC (scm_copy_random_state, "copy-random-state", 0, 1, 0, + (SCM state), + "") +#define FUNC_NAME s_scm_copy_random_state { if (SCM_UNBNDP (state)) state = SCM_CDR (scm_var_random_state); - SCM_ASSERT (SCM_NIMP (state) && SCM_RSTATEP (state), - state, - SCM_ARG1, - s_copy_random_state); + SCM_VALIDATE_RSTATE(2,state); return make_rstate (scm_the_rng.copy_rstate (SCM_RSTATE (state))); } +#undef FUNC_NAME -SCM_PROC (s_seed_to_random_state, "seed->random-state", 1, 0, 0, scm_seed_to_random_state); - -SCM -scm_seed_to_random_state (SCM seed) +GUILE_PROC (scm_seed_to_random_state, "seed->random-state", 1, 0, 0, + (SCM seed), + "") +#define FUNC_NAME s_scm_seed_to_random_state { if (SCM_NUMBERP (seed)) seed = scm_number_to_string (seed, SCM_UNDEFINED); - SCM_ASSERT (SCM_NIMP (seed) && SCM_STRINGP (seed), - seed, - SCM_ARG1, - s_seed_to_random_state); + SCM_VALIDATE_STRING(1,seed); return make_rstate (scm_c_make_rstate (SCM_ROCHARS (seed), SCM_LENGTH (seed))); } +#undef FUNC_NAME -SCM_PROC (s_random_uniform, "random:uniform", 0, 1, 0, scm_random_uniform); - -SCM -scm_random_uniform (SCM state) +GUILE_PROC (scm_random_uniform, "random:uniform", 0, 1, 0, + (SCM state), + "") +#define FUNC_NAME s_scm_random_uniform { if (SCM_UNBNDP (state)) state = SCM_CDR (scm_var_random_state); - SCM_ASSERT (SCM_NIMP (state) && SCM_RSTATEP (state), - state, - SCM_ARG1, - s_random_uniform); + SCM_VALIDATE_RSTATE(1,state); return scm_makdbl (scm_c_uniform01 (SCM_RSTATE (state)), 0.0); } +#undef FUNC_NAME -SCM_PROC (s_random_normal, "random:normal", 0, 1, 0, scm_random_normal); - -SCM -scm_random_normal (SCM state) +GUILE_PROC (scm_random_normal, "random:normal", 0, 1, 0, + (SCM state), + "") +#define FUNC_NAME s_scm_random_normal { if (SCM_UNBNDP (state)) state = SCM_CDR (scm_var_random_state); - SCM_ASSERT (SCM_NIMP (state) && SCM_RSTATEP (state), - state, - SCM_ARG1, - s_random_normal); + SCM_VALIDATE_RSTATE(1,state); return scm_makdbl (scm_c_normal01 (SCM_RSTATE (state)), 0.0); } +#undef FUNC_NAME #ifdef HAVE_ARRAYS @@ -464,20 +461,17 @@ vector_sum_squares (SCM v) * distribution r^n; i.e., u=r^n is uniform [0,1], so r can be * generated as r=u^(1/n). */ -SCM_PROC (s_random_solid_sphere_x, "random:solid-sphere!", 1, 1, 0, scm_random_solid_sphere_x); - -SCM -scm_random_solid_sphere_x (SCM v, SCM state) +GUILE_PROC (scm_random_solid_sphere_x, "random:solid-sphere!", 1, 1, 0, + (SCM v, SCM state), + "") +#define FUNC_NAME s_scm_random_solid_sphere_x { SCM_ASSERT (SCM_NIMP (v) && (SCM_VECTORP (v) || SCM_TYP7 (v) == scm_tc7_dvect), - v, SCM_ARG1, s_random_solid_sphere_x); + v, SCM_ARG1, FUNC_NAME); if (SCM_UNBNDP (state)) state = SCM_CDR (scm_var_random_state); - SCM_ASSERT (SCM_NIMP (state) && SCM_RSTATEP (state), - state, - SCM_ARG2, - s_random_solid_sphere_x); + SCM_VALIDATE_RSTATE(2,state); scm_random_normal_vector_x (v, state); vector_scale (v, pow (scm_c_uniform01 (SCM_RSTATE (state)), @@ -485,40 +479,38 @@ scm_random_solid_sphere_x (SCM v, SCM state) / sqrt (vector_sum_squares (v))); return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_random_hollow_sphere_x, "random:hollow-sphere!", 1, 1, 0, scm_random_hollow_sphere_x); - -SCM -scm_random_hollow_sphere_x (SCM v, SCM state) +GUILE_PROC (scm_random_hollow_sphere_x, "random:hollow-sphere!", 1, 1, 0, + (SCM v, SCM state), + "") +#define FUNC_NAME s_scm_random_hollow_sphere_x { SCM_ASSERT (SCM_NIMP (v) && (SCM_VECTORP (v) || SCM_TYP7 (v) == scm_tc7_dvect), - v, SCM_ARG1, s_random_solid_sphere_x); + v, SCM_ARG1, FUNC_NAME); if (SCM_UNBNDP (state)) state = SCM_CDR (scm_var_random_state); - SCM_ASSERT (SCM_NIMP (state) && SCM_RSTATEP (state), - state, - SCM_ARG2, - s_random_hollow_sphere_x); + SCM_VALIDATE_RSTATE(2,state); scm_random_normal_vector_x (v, state); vector_scale (v, 1 / sqrt (vector_sum_squares (v))); return SCM_UNSPECIFIED; } -SCM_PROC (s_random_normal_vector_x, "random:normal-vector!", 1, 1, 0, scm_random_normal_vector_x); +#undef FUNC_NAME -SCM -scm_random_normal_vector_x (SCM v, SCM state) + +GUILE_PROC (scm_random_normal_vector_x, "random:normal-vector!", 1, 1, 0, + (SCM v, SCM state), +"") +#define FUNC_NAME s_scm_random_normal_vector_x { int n; SCM_ASSERT (SCM_NIMP (v) && (SCM_VECTORP (v) || SCM_TYP7 (v) == scm_tc7_dvect), - v, SCM_ARG1, s_random_solid_sphere_x); + v, SCM_ARG1, FUNC_NAME); if (SCM_UNBNDP (state)) state = SCM_CDR (scm_var_random_state); - SCM_ASSERT (SCM_NIMP (state) && SCM_RSTATEP (state), - state, - SCM_ARG2, - s_random_normal_vector_x); + SCM_VALIDATE_RSTATE(2,state); n = SCM_LENGTH (v); if (SCM_VECTORP (v)) while (--n >= 0) @@ -528,22 +520,21 @@ scm_random_normal_vector_x (SCM v, SCM state) ((double *) SCM_VELTS (v))[n] = scm_c_normal01 (SCM_RSTATE (state)); return SCM_UNSPECIFIED; } +#undef FUNC_NAME #endif /* HAVE_ARRAYS */ -SCM_PROC (s_random_exp, "random:exp", 0, 1, 0, scm_random_exp); - -SCM -scm_random_exp (SCM state) +GUILE_PROC (scm_random_exp, "random:exp", 0, 1, 0, + (SCM state), + "") +#define FUNC_NAME s_scm_random_exp { if (SCM_UNBNDP (state)) state = SCM_CDR (scm_var_random_state); - SCM_ASSERT (SCM_NIMP (state) && SCM_RSTATEP (state), - state, - SCM_ARG1, - s_random_exp); + SCM_VALIDATE_RSTATE(2,state); return scm_makdbl (scm_c_exp1 (SCM_RSTATE (state)), 0.0); } +#undef FUNC_NAME void scm_init_random () diff --git a/libguile/read.c b/libguile/read.c index 51e197d03..4b6a5806b 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -52,6 +56,7 @@ #include "hashtab.h" #include "hash.h" +#include "scm_validate.h" #include "read.h" @@ -69,39 +74,35 @@ scm_option scm_read_opts[] = { "Style of keyword recognition: #f or 'prefix"} }; -SCM_PROC (s_read_options, "read-options-interface", 0, 1, 0, scm_read_options); - -SCM -scm_read_options (setting) - SCM setting; +GUILE_PROC (scm_read_options, "read-options-interface", 0, 1, 0, + (SCM setting), +"") +#define FUNC_NAME s_scm_read_options { SCM ans = scm_options (setting, scm_read_opts, SCM_N_READ_OPTIONS, - s_read_options); + FUNC_NAME); if (SCM_COPY_SOURCE_P) SCM_RECORD_POSITIONS_P = 1; return ans; } +#undef FUNC_NAME /* An association list mapping extra hash characters to procedures. */ static SCM *scm_read_hash_procedures; -SCM_PROC (s_read, "read", 0, 1, 0, scm_read); - -SCM -scm_read (port) - SCM port; +GUILE_PROC (scm_read, "read", 0, 1, 0, + (SCM port), +"") +#define FUNC_NAME s_scm_read { int c; SCM tok_buf, copy; if (SCM_UNBNDP (port)) port = scm_cur_inp; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), - port, - SCM_ARG1, - s_read); + SCM_VALIDATE_OPINPORT(1,port); c = scm_flush_ws (port, (char *) NULL); if (EOF == c) @@ -111,6 +112,7 @@ scm_read (port) tok_buf = scm_makstr (30L, 0); return scm_lreadr (&tok_buf, port, ©); } +#undef FUNC_NAME @@ -184,14 +186,8 @@ scm_casei_streq (s1, s2) #ifndef DEBUG_EXTENSIONS #define recsexpr(obj, line, column, filename) (obj) #else -static SCM recsexpr SCM_P ((SCM obj, int line, int column, SCM filename)); - static SCM -recsexpr (obj, line, column, filename) - SCM obj; - int line; - int column; - SCM filename; +recsexpr (SCM obj,int line,int column,SCM filename) { if (SCM_IMP (obj) || SCM_NCONSP(obj)) return obj; @@ -264,23 +260,19 @@ skip_scsh_block_comment (port) } } -static SCM -scm_get_hash_procedure SCM_P ((int c)); +static SCM scm_get_hash_procedure(int c); static char s_list[]="list"; SCM -scm_lreadr (tok_buf, port, copy) - SCM *tok_buf; - SCM port; - SCM *copy; +scm_lreadr (SCM *tok_buf,SCM port,SCM *copy) { int c; scm_sizet j; SCM p; tryagain: - c = scm_flush_ws (port, s_read); + c = scm_flush_ws (port, s_scm_read); tryagain_no_flush_ws: switch (c) { @@ -428,7 +420,7 @@ tryagain_no_flush_ws: } } unkshrp: - scm_misc_error (s_read, "Unknown # object: %S", + scm_misc_error (s_scm_read, "Unknown # object: %S", scm_listify (SCM_MAKICHR (c), SCM_UNDEFINED)); } @@ -727,18 +719,17 @@ exit: /* Manipulate the read-hash-procedures alist. This could be written in Scheme, but maybe it will also be used by C code during initialisation. */ -SCM_PROC (s_read_hash_extend, "read-hash-extend", 2, 0, 0, scm_read_hash_extend); -SCM -scm_read_hash_extend (chr, proc) - SCM chr; - SCM proc; +GUILE_PROC (scm_read_hash_extend, "read-hash-extend", 2, 0, 0, + (SCM chr, SCM proc), +"") +#define FUNC_NAME s_scm_read_hash_extend { SCM this; SCM prev; - SCM_ASSERT (SCM_ICHRP(chr), chr, SCM_ARG1, s_read_hash_extend); + SCM_VALIDATE_CHAR(1,chr); SCM_ASSERT (SCM_FALSEP (proc) || SCM_NIMP(proc), proc, SCM_ARG2, - s_read_hash_extend); + FUNC_NAME); /* Check if chr is already in the alist. */ this = *scm_read_hash_procedures; @@ -782,6 +773,7 @@ scm_read_hash_extend (chr, proc) return SCM_UNSPECIFIED; } +#undef FUNC_NAME /* Recover the read-hash procedure corresponding to char c. */ static SCM diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index 167542fa4..d00d003f8 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -39,6 +39,10 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + /* regex-posix.c -- POSIX regular expression support. @@ -79,6 +83,7 @@ #include "ports.h" #include "feature.h" +#include "scm_validate.h" #include "regex-posix.h" /* This is defined by some regex libraries and omitted by others. */ @@ -89,8 +94,7 @@ long scm_tc16_regex; static scm_sizet -free_regex (obj) - SCM obj; +free_regex (SCM obj) { regfree (SCM_RGX (obj)); free (SCM_RGX (obj)); @@ -129,26 +133,25 @@ scm_regexp_error_msg (int regerrno, regex_t *rx) return SCM_CHARS (errmsg); } -SCM_PROC (s_regexp_p, "regexp?", 1, 0, 0, scm_regexp_p); - -SCM -scm_regexp_p (x) - SCM x; +GUILE_PROC (scm_regexp_p, "regexp?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_regexp_p { - return (SCM_NIMP (x) && SCM_RGXP (x) ? SCM_BOOL_T : SCM_BOOL_F); + return SCM_BOOL(SCM_NIMP (x) && SCM_RGXP (x)); } +#undef FUNC_NAME -SCM_PROC (s_make_regexp, "make-regexp", 1, 0, 1, scm_make_regexp); - -SCM -scm_make_regexp (SCM pat, SCM flags) +GUILE_PROC (scm_make_regexp, "make-regexp", 1, 0, 1, + (SCM pat, SCM flags), +"") +#define FUNC_NAME s_scm_make_regexp { SCM flag; regex_t *rx; int status, cflags; - SCM_ASSERT (SCM_NIMP(pat) && SCM_ROSTRINGP(pat), pat, SCM_ARG1, - s_make_regexp); + SCM_VALIDATE_ROSTRING(1,pat); SCM_COERCE_SUBSTR (pat); /* Examine list of regexp flags. If REG_BASIC is supplied, then @@ -164,7 +167,7 @@ scm_make_regexp (SCM pat, SCM flags) flag = SCM_CDR (flag); } - rx = (regex_t *) scm_must_malloc (sizeof (regex_t), s_make_regexp); + rx = SCM_MUST_MALLOC_TYPE(regex_t); status = regcomp (rx, SCM_ROCHARS (pat), /* Make sure they're not passing REG_NOSUB; regexp-exec assumes we're getting match data. */ @@ -172,7 +175,7 @@ scm_make_regexp (SCM pat, SCM flags) if (status != 0) { scm_error (scm_regexp_error_key, - s_make_regexp, + FUNC_NAME, scm_regexp_error_msg (status, rx), SCM_BOOL_F, SCM_BOOL_F); @@ -180,34 +183,24 @@ scm_make_regexp (SCM pat, SCM flags) } SCM_RETURN_NEWSMOB (scm_tc16_regex, rx); } +#undef FUNC_NAME -SCM_PROC (s_regexp_exec, "regexp-exec", 2, 2, 0, scm_regexp_exec); - -SCM -scm_regexp_exec (SCM rx, SCM str, SCM start, SCM flags) +GUILE_PROC (scm_regexp_exec, "regexp-exec", 2, 2, 0, + (SCM rx, SCM str, SCM start, SCM flags), + "") +#define FUNC_NAME s_scm_regexp_exec { int status, nmatches, offset; regmatch_t *matches; SCM mvec = SCM_BOOL_F; - SCM_ASSERT (SCM_NIMP (rx) && SCM_RGXP (rx), rx, SCM_ARG1, s_regexp_exec); - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG2, - s_regexp_exec); - - if (SCM_UNBNDP (start)) - offset = 0; - else - { - SCM_ASSERT (SCM_INUMP (start), start, SCM_ARG3, s_regexp_exec); - offset = SCM_INUM (start); - SCM_ASSERT (offset >= 0 && (unsigned) offset <= SCM_LENGTH (str), start, - SCM_OUTOFRANGE, s_regexp_exec); - } - + SCM_VALIDATE_RGXP(1,rx); + SCM_VALIDATE_ROSTRING(2,str); + SCM_VALIDATE_INT_DEF_COPY(3,start,0,offset); + SCM_ASSERT_RANGE (3,start,offset >= 0 && (unsigned) offset <= SCM_LENGTH (str)); if (SCM_UNBNDP (flags)) flags = SCM_INUM0; - SCM_ASSERT (SCM_INUMP (flags), flags, SCM_ARG2, s_regexp_exec); - + SCM_VALIDATE_INT(4,flags); SCM_COERCE_SUBSTR (str); /* re_nsub doesn't account for the `subexpression' representing the @@ -215,8 +208,7 @@ scm_regexp_exec (SCM rx, SCM str, SCM start, SCM flags) nmatches = SCM_RGX(rx)->re_nsub + 1; SCM_DEFER_INTS; - matches = (regmatch_t *) scm_must_malloc (sizeof (regmatch_t) * nmatches, - s_regexp_exec); + matches = SCM_MUST_MALLOC_TYPE_NUM (regmatch_t,nmatches); status = regexec (SCM_RGX (rx), SCM_ROCHARS (str) + offset, nmatches, matches, SCM_INUM (flags)); @@ -240,12 +232,13 @@ scm_regexp_exec (SCM rx, SCM str, SCM start, SCM flags) if (status != 0 && status != REG_NOMATCH) scm_error (scm_regexp_error_key, - s_regexp_exec, + FUNC_NAME, scm_regexp_error_msg (status, SCM_RGX (rx)), SCM_BOOL_F, SCM_BOOL_F); return mvec; } +#undef FUNC_NAME void scm_init_regex_posix () diff --git a/libguile/root.c b/libguile/root.c index b0b0c7cd7..5d2dd8d43 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -70,11 +74,8 @@ struct scm_root_state *scm_root; -static SCM mark_root SCM_P ((SCM)); - static SCM -mark_root (root) - SCM root; +mark_root (SCM root) { scm_root_state *s = SCM_ROOT_STATE (root); @@ -98,13 +99,8 @@ mark_root (root) } -static int print_root SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - static int -print_root (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +print_root (SCM exp,SCM port,scm_print_state *pstate) { scm_puts ("# rootcont), 16, port); @@ -116,8 +112,7 @@ print_root (exp, port, pstate) SCM -scm_make_root (parent) - SCM parent; +scm_make_root (SCM parent) { SCM root; scm_root_state *root_state; @@ -340,30 +335,27 @@ cwdr (SCM proc, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start) stack_start); } -SCM_PROC(s_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0, scm_call_with_dynamic_root); -SCM -scm_call_with_dynamic_root (thunk, handler) - SCM thunk; - SCM handler; +GUILE_PROC(scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0, + (SCM thunk, SCM handler), +"") +#define FUNC_NAME s_scm_call_with_dynamic_root { SCM_STACKITEM stack_place; - return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place); } +#undef FUNC_NAME -SCM_PROC(s_dynamic_root, "dynamic-root", 0, 0, 0, scm_dynamic_root); -SCM -scm_dynamic_root () +GUILE_PROC(scm_dynamic_root, "dynamic-root", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_dynamic_root { return scm_ulong2num (SCM_SEQ (scm_root->rootcont)); } +#undef FUNC_NAME SCM -scm_apply_with_dynamic_root (proc, a1, args, handler) - SCM proc; - SCM a1; - SCM args; - SCM handler; +scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler) { SCM_STACKITEM stack_place; return cwdr (proc, a1, args, handler, &stack_place); @@ -386,10 +378,7 @@ typedef long setjmp_type; SCM -scm_call_catching_errors (thunk, err_filter, closure) - SCM (*thunk)(); - SCM (*err_filter)(); - void *closure; +scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void *closure) { SCM answer; setjmp_type i; diff --git a/libguile/scm_validate.h b/libguile/scm_validate.h new file mode 100644 index 000000000..54b529b43 --- /dev/null +++ b/libguile/scm_validate.h @@ -0,0 +1,267 @@ +/* $Id: scm_validate.h,v 1.1 1999-12-12 02:36:16 gjb Exp $ + * scm_validate.h + * Copyright (C) 1999, Greg J. Badros + * + */ + +#ifndef SCM_VALIDATE_H__ +#define SCM_VALIDATE_H__ + +#define SCM_BOOL(f) ((f)? SCM_BOOL_T : SCM_BOOL_F) +#define SCM_NEGATE_BOOL(f) ((f)? SCM_BOOL_F : SCM_BOOL_T) + +#define SCM_FUNC_NAME (scm_makfrom0str(FUNC_NAME)) + +#define SCM_SYSERROR do { scm_syserror(FUNC_NAME); } while (0) + +#define SCM_MEMORY_ERROR do { scm_memory_error(FUNC_NAME); } while (0) + +#define SCM_SYSERROR_MSG(str,args,val) \ + do { scm_syserror_msg(FUNC_NAME,(str),(args),(val)); } while (0) + +#define SCM_SYSMISSING \ + do { scm_sysmissing(FUNC_NAME); } while (0) + +#define SCM_WTA(pos,scm) \ + do { scm_wta(scm,(char *)pos,FUNC_NAME); } while (0) + +#define RETURN_SCM_WTA(pos,scm) \ + do { return scm_wta(scm,(char *)pos,FUNC_NAME); } while (0) + +#define SCM_MISC_ERROR(str,args) \ + do { scm_misc_error(FUNC_NAME,str,args); } while (0) + +#define SCM_WRONG_TYPE_ARG(pos,obj) \ + do { scm_wrong_type_arg(FUNC_NAME,pos,obj); } while (0) + +#define SCM_NUM2ULONG(pos,arg) (scm_num2ulong(arg, (char *) pos, FUNC_NAME)) + +#define SCM_NUM2LONG(pos,arg) (scm_num2long(arg, (char *) pos, FUNC_NAME)) + +#define SCM_NUM2LONG_LONG(pos,arg) (scm_num2long_long(arg, (char *) pos, FUNC_NAME)) + +#define SCM_OUT_OF_RANGE(pos,arg) do { scm_out_of_range(FUNC_NAME,arg); } while (0) + +#define SCM_ASSERT_RANGE(pos,arg,f) do { SCM_ASSERT(f,arg,SCM_OUTOFRANGE,FUNC_NAME); } while (0) + +#define SCM_MUST_MALLOC_TYPE(type) ((type *) scm_must_malloc(sizeof(type), FUNC_NAME)) + +#define SCM_MUST_MALLOC_TYPE_NUM(type,num) ((type *) scm_must_malloc(sizeof(type)*(num), FUNC_NAME)) + +#define SCM_MUST_MALLOC(size) (scm_must_malloc((size), FUNC_NAME)) + +#define SCM_VALIDATE_NIMP(pos,scm) \ + do { SCM_ASSERT(SCM_NIMP(scm), scm, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_BOOL(pos,flag) \ + do { SCM_ASSERT(SCM_BOOL_T == flag || SCM_BOOL_F == flag, flag, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_BOOL_COPY(pos,flag,cvar) \ + do { SCM_ASSERT(SCM_BOOL_T == flag || SCM_BOOL_F == flag, flag, pos, FUNC_NAME); \ + cvar = (SCM_BOOL_T == flag)? 1: 0; } while (0) + +#define SCM_VALIDATE_CHAR(pos,scm) \ + do { SCM_ASSERT(SCM_ICHRP(scm), scm, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_CHAR_COPY(pos,scm,cvar) \ + do { SCM_ASSERT(SCM_ICHRP(scm), scm, pos, FUNC_NAME); \ + cvar = SCM_ICHR(scm); } while (0) + +#define SCM_VALIDATE_ROSTRING(pos,str) \ + do { SCM_ASSERT(SCM_NIMP (str) && SCM_ROSTRINGP (str), str, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_ROSTRING_COPY(pos,str,cvar) \ + do { SCM_ASSERT(SCM_NIMP (str) && SCM_ROSTRINGP (str), str, pos, FUNC_NAME); \ + cvar = SCM_ROCHARS(str); } while (0) + +#define SCM_VALIDATE_NULLORROSTRING_COPY(pos,str,cvar) \ + do { SCM_ASSERT(SCM_FALSEP(str) || (SCM_NIMP (str) && SCM_ROSTRINGP (str)), str, pos, FUNC_NAME); \ + if (SCM_FALSEP(str)) cvar = NULL; else cvar = SCM_ROCHARS(str); } while (0) + +#define SCM_VALIDATE_STRING(pos,str) \ + do { SCM_ASSERT(SCM_NIMP (str) && SCM_STRINGP (str), str, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_STRINGORSUBSTR(pos,str) \ + do { SCM_ASSERT(SCM_NIMP (str) && (SCM_STRINGP (str) || SCM_SUBSTRP(str)), str, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_STRING_COPY(pos,str,cvar) \ + do { SCM_ASSERT(SCM_NIMP (str) && SCM_STRINGP (str), str, pos, FUNC_NAME); \ + cvar = SCM_CHARS(str); } while (0) + +#define SCM_VALIDATE_RWSTRING(pos,str) \ + do { SCM_ASSERT(SCM_NIMP (str) && SCM_STRINGP (str), str, pos, FUNC_NAME); \ + if (!SCM_RWSTRINGP(str)) scm_misc_error(FUNC_NAME, "argument is a read-only string", str); } while (0) + +#define SCM_VALIDATE_REAL(pos,z) \ + do { SCM_ASSERT (SCM_NIMP (z) && SCM_REALP (z), z, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_INT(pos,k) \ + do { SCM_ASSERT(SCM_INUMP(k), k, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_INT_COPY(pos,k,cvar) \ + do { cvar = scm_num2ulong(k,(char *)pos,FUNC_NAME); } while (0) + +#define SCM_VALIDATE_BIGINT(pos,k) \ + do { SCM_ASSERT(SCM_NIMP(k) && SCM_BIGP(k), k, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_INT_MIN(pos,k,min) \ + do { SCM_ASSERT(SCM_INUMP(k), k, pos, FUNC_NAME); \ + SCM_ASSERT(SCM_INUM(k) >= min, k, SCM_OUTOFRANGE, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_INT_MIN_COPY(pos,k,min,cvar) \ + do { SCM_ASSERT(SCM_INUMP(k), k, pos, FUNC_NAME); \ + cvar = SCM_INUM(k); \ + SCM_ASSERT(cvar >= min, k, SCM_OUTOFRANGE, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_INT_MIN_DEF_COPY(pos,k,min,default,cvar) \ + do { if (SCM_UNBNDP(k)) k = SCM_MAKINUM(default); \ + SCM_ASSERT(SCM_INUMP(k), k, pos, FUNC_NAME); \ + cvar = SCM_INUM(k); \ + SCM_ASSERT(cvar >= min, k, SCM_OUTOFRANGE, FUNC_NAME); } while (0) + + +#define SCM_VALIDATE_INT_DEF(pos,k,default) \ + do { if (SCM_UNDEFINED==k) k = SCM_MAKINUM(default); else SCM_ASSERT(SCM_INUMP(k), k, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_INT_DEF_COPY(pos,k,default,cvar) \ + do { if (SCM_UNDEFINED==k) { k = SCM_MAKINUM(default); cvar=default; } \ + else { SCM_ASSERT(SCM_INUMP(k), k, pos, FUNC_NAME); cvar = SCM_INUM(k); } } while (0) + +/* [low,high) */ +#define SCM_VALIDATE_INT_RANGE(pos,k,low,high) \ + do { SCM_ASSERT(SCM_INUMP(k), k, pos, FUNC_NAME); \ + SCM_ASSERT(SCM_INUM (k) >= low && ((unsigned) SCM_INUM (k)) < high, \ + k, SCM_OUTOFRANGE, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_NULL(pos,scm) \ + do { SCM_ASSERT(SCM_NULLP(scm), scm, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_CONS(pos,scm) \ + do { SCM_ASSERT(SCM_CONSP(scm), scm, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_NIMCONS(pos,scm) \ + do { SCM_ASSERT(SCM_CONSP(scm), scm, pos, FUNC_NAME); } while (0) + + +#define SCM_VALIDATE_LIST(pos,lst) \ + do { SCM_ASSERT (scm_ilength (lst) >= 0, lst, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_LIST_COPYLEN(pos,lst,cvar) \ + do { cvar = scm_ilength(lst); SCM_ASSERT(cvar >= 0,lst,pos,FUNC_NAME); } while (0) + +#define SCM_VALIDATE_NONEMPTYLIST_COPYLEN(pos,lst,cvar) \ + do { cvar = scm_ilength(lst); SCM_ASSERT(cvar >= 1,lst,pos,FUNC_NAME); } while (0) + +#define SCM_VALIDATE_ALISTCELL(pos,alist) \ + do { \ + SCM_ASSERT(SCM_CONSP(alist), alist, pos, FUNC_NAME); \ + { SCM tmp = SCM_CAR(alist); \ + SCM_ASSERT(SCM_NIMP(tmp) && SCM_CONSP(tmp), alist, pos, FUNC_NAME); } } while (0) + +#define SCM_VALIDATE_ALISTCELL_COPYSCM(pos,alist,tmp) \ + do { \ + SCM_ASSERT(SCM_CONSP(alist), alist, pos, FUNC_NAME); \ + tmp = SCM_CAR(alist); \ + SCM_ASSERT(SCM_NIMP(tmp) && SCM_CONSP(tmp), alist, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_OPORT_VALUE(pos,port) \ + do { SCM_ASSERT (scm_valid_oport_value_p (port), port, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_PRINTSTATE(pos,a) \ + do { SCM_ASSERT (SCM_NIMP (a) && SCM_PRINT_STATE_P (a), a, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_SMOB(pos,obj,type) \ + do { SCM_ASSERT ((SCM_NIMP(obj) && SCM_TYP16 (obj) == scm_tc16_ ## type), obj, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_ASYNC(pos,a) \ + do { SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_ASYNC_COPY(pos,a,cvar) \ + do { SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, pos, FUNC_NAME); \ + cvar = SCM_ASYNC(a); } while (0) + +#define SCM_VALIDATE_THUNK(pos,thunk) \ + do { SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)), thunk, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_SYMBOL(pos,sym) \ + do { SCM_ASSERT (SCM_NIMP(sym) && SCM_SYMBOLP(sym), sym, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_VARIABLE(pos,var) \ + do { SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP(var), var, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_MEMOIZED(pos,obj) \ + do { SCM_ASSERT (SCM_NIMP(obj) && SCM_MEMOIZEDP(obj), obj, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_CLOSURE(pos,obj) \ + do { SCM_ASSERT (SCM_NIMP(obj) && SCM_CLOSUREP(obj), obj, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_PROC(pos,proc) \ + do { SCM_ASSERT ( SCM_BOOL_T == scm_procedure_p(proc), proc, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_NULLORCONS(pos,env) \ + do { SCM_ASSERT (SCM_NULLP (env) || (SCM_NIMP (env) && SCM_CONSP (env)), env, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_HOOK(pos,a) \ + do { SCM_ASSERT (SCM_NIMP (a) && SCM_HOOKP (a), a, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_RGXP(pos,a) \ + do { SCM_ASSERT (SCM_NIMP (a) && SCM_RGXP (a), a, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_OPDIR(pos,port) \ + do { SCM_ASSERT (SCM_NIMP (port) && SCM_OPDIRP (port), port, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_DIR(pos,port) \ + do { SCM_ASSERT (SCM_NIMP (port) && SCM_DIRP (port), port, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_PORT(pos,port) \ + do { SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_FPORT(pos,port) \ + do { SCM_ASSERT (SCM_NIMP (port) && SCM_FPORTP (port), port, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_OPFPORT(pos,port) \ + do { SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_OPINPORT(pos,port) \ + do { SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_OPENPORT(pos,port) \ + do { SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP(port), port, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_OPPORT(pos,port) \ + do { SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_OPOUTPORT(pos,port) \ + do { SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_FLUID(pos,fluid) \ + do { SCM_ASSERT (SCM_NIMP (fluid) && SCM_FLUIDP (fluid), fluid, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_KEYWORD(pos,v) \ + do { SCM_ASSERT (SCM_NIMP (v) && SCM_KEYWORDP (v), v, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_STACK(pos,v) \ + do { SCM_ASSERT (SCM_NIMP (v) && SCM_STACKP (v), v, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_FRAME(pos,v) \ + do { SCM_ASSERT (SCM_NIMP (v) && SCM_FRAMEP (v), v, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_RSTATE(pos,v) \ + do { SCM_ASSERT (SCM_NIMP (v) && SCM_RSTATEP (v), v, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_ARRAY(pos,v) \ + do { SCM_ASSERT (SCM_NIMP (v) && SCM_BOOL_F != scm_array_p(v,SCM_UNDEFINED), v, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_VECTOR(pos,v) \ + do { SCM_ASSERT (SCM_NIMP (v) && SCM_VECTORP (v), v, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_STRUCT(pos,v) \ + do { SCM_ASSERT (SCM_NIMP (v) && SCM_STRUCTP (v), v, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_VTABLE(pos,v) \ + do { SCM_ASSERT (SCM_NIMP (v) && SCM_NFALSEP(scm_struct_vtable_p(v)), v, pos, FUNC_NAME); } while (0) + +#define SCM_VALIDATE_VECTOR_LEN(pos,v,len) \ + do { SCM_ASSERT (SCM_NIMP (v) && SCM_VECTORP (v) && len == SCM_LENGTH(v), v, pos, FUNC_NAME); } while (0) + +#endif diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index c0c995e28..b8e190899 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -46,6 +50,8 @@ #include "async.h" #include "eval.h" + +#include "scm_validate.h" #include "scmsigs.h" #ifdef HAVE_UNISTD_H @@ -173,9 +179,10 @@ sys_deliver_signals (void) } /* user interface for installation of signal handlers. */ -SCM_PROC(s_sigaction, "sigaction", 1, 2, 0, scm_sigaction); -SCM -scm_sigaction (SCM signum, SCM handler, SCM flags) +GUILE_PROC(scm_sigaction, "sigaction", 1, 2, 0, + (SCM signum, SCM handler, SCM flags), +"") +#define FUNC_NAME s_scm_sigaction { int csig; #ifdef HAVE_SIGACTION @@ -190,8 +197,7 @@ scm_sigaction (SCM signum, SCM handler, SCM flags) SCM *scheme_handlers = SCM_VELTS (*signal_handlers); SCM old_handler; - SCM_ASSERT (SCM_INUMP (signum), signum, SCM_ARG1, s_sigaction); - csig = SCM_INUM (signum); + SCM_VALIDATE_INT_COPY(1,signum,csig); #if defined(HAVE_SIGACTION) #if defined(SA_RESTART) && defined(HAVE_RESTARTABLE_SYSCALLS) /* don't allow SA_RESTART to be omitted if HAVE_RESTARTABLE_SYSCALLS @@ -203,7 +209,7 @@ scm_sigaction (SCM signum, SCM handler, SCM flags) #endif if (!SCM_UNBNDP (flags)) { - SCM_ASSERT (SCM_INUMP (flags), flags, SCM_ARG3, s_sigaction); + SCM_VALIDATE_INT(3,flags); action.sa_flags |= SCM_INUM (flags); } sigemptyset (&action.sa_mask); @@ -214,10 +220,8 @@ scm_sigaction (SCM signum, SCM handler, SCM flags) query_only = 1; else if (scm_integer_p (handler) == SCM_BOOL_T) { - if (scm_num2long (handler, (char *) SCM_ARG2, s_sigaction) - == (long) SIG_DFL - || scm_num2long (handler, (char *) SCM_ARG2, s_sigaction) - == (long) SIG_IGN) + if (SCM_NUM2LONG (2,handler) == (long) SIG_DFL + || SCM_NUM2LONG (2,handler) == (long) SIG_IGN) { #ifdef HAVE_SIGACTION action.sa_handler = (SIGRETTYPE (*) (int)) SCM_INUM (handler); @@ -227,7 +231,7 @@ scm_sigaction (SCM signum, SCM handler, SCM flags) scheme_handlers[csig] = SCM_BOOL_F; } else - scm_out_of_range (s_sigaction, handler); + SCM_OUT_OF_RANGE (2, handler); } else if (SCM_FALSEP (handler)) { @@ -254,7 +258,7 @@ scm_sigaction (SCM signum, SCM handler, SCM flags) } else { - SCM_ASSERT (SCM_NIMP (handler), handler, SCM_ARG2, s_sigaction); + SCM_VALIDATE_NIMP(2,handler); #ifdef HAVE_SIGACTION action.sa_handler = take_signal; if (orig_handlers[csig].sa_handler == SIG_ERR) @@ -270,12 +274,12 @@ scm_sigaction (SCM signum, SCM handler, SCM flags) if (query_only) { if (sigaction (csig, 0, &old_action) == -1) - scm_syserror (s_sigaction); + SCM_SYSERROR; } else { if (sigaction (csig, &action , &old_action) == -1) - scm_syserror (s_sigaction); + SCM_SYSERROR; if (save_handler) orig_handlers[csig] = old_action; } @@ -287,14 +291,14 @@ scm_sigaction (SCM signum, SCM handler, SCM flags) if (query_only) { if ((old_chandler = signal (csig, SIG_IGN)) == SIG_ERR) - scm_syserror (s_sigaction); + SCM_SYSERROR; if (signal (csig, old_chandler) == SIG_ERR) - scm_syserror (s_sigaction); + SCM_SYSERROR; } else { if ((old_chandler = signal (csig, chandler)) == SIG_ERR) - scm_syserror (s_sigaction); + SCM_SYSERROR; if (save_handler) orig_handlers[csig] = old_chandler; } @@ -304,10 +308,12 @@ scm_sigaction (SCM signum, SCM handler, SCM flags) return scm_cons (old_handler, SCM_MAKINUM (0)); #endif } +#undef FUNC_NAME -SCM_PROC (s_restore_signals, "restore-signals", 0, 0, 0, scm_restore_signals); -SCM -scm_restore_signals (void) +GUILE_PROC (scm_restore_signals, "restore-signals", 0, 0, 0, + (void), +"") +#define FUNC_NAME s_scm_restore_signals { int i; SCM *scheme_handlers = SCM_VELTS (*signal_handlers); @@ -318,7 +324,7 @@ scm_restore_signals (void) if (orig_handlers[i].sa_handler != SIG_ERR) { if (sigaction (i, &orig_handlers[i], NULL) == -1) - scm_syserror (s_restore_signals); + SCM_SYSERROR; orig_handlers[i].sa_handler = SIG_ERR; scheme_handlers[i] = SCM_BOOL_F; } @@ -326,7 +332,7 @@ scm_restore_signals (void) if (orig_handlers[i] != SIG_ERR) { if (signal (i, orig_handlers[i]) == SIG_ERR) - scm_syserror (s_restore_signals); + SCM_SYSERROR; orig_handlers[i] = SIG_ERR; scheme_handlers[i] = SCM_BOOL_F; } @@ -334,38 +340,39 @@ scm_restore_signals (void) } return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_alarm, "alarm", 1, 0, 0, scm_alarm); - -SCM -scm_alarm (i) - SCM i; +GUILE_PROC(scm_alarm, "alarm", 1, 0, 0, + (SCM i), +"") +#define FUNC_NAME s_scm_alarm { unsigned int j; - SCM_ASSERT (SCM_INUMP (i) && (SCM_INUM (i) >= 0), i, SCM_ARG1, s_alarm); + SCM_VALIDATE_INT(1,i); j = alarm (SCM_INUM (i)); return SCM_MAKINUM (j); } +#undef FUNC_NAME #ifdef HAVE_PAUSE -SCM_PROC(s_pause, "pause", 0, 0, 0, scm_pause); - -SCM -scm_pause () +GUILE_PROC(scm_pause, "pause", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_pause { pause (); return SCM_UNSPECIFIED; } +#undef FUNC_NAME #endif -SCM_PROC(s_sleep, "sleep", 1, 0, 0, scm_sleep); - -SCM -scm_sleep (i) - SCM i; +GUILE_PROC(scm_sleep, "sleep", 1, 0, 0, + (SCM i), +"") +#define FUNC_NAME s_scm_sleep { unsigned long j; - SCM_ASSERT (SCM_INUMP (i) && (SCM_INUM (i) >= 0), i, SCM_ARG1, s_sleep); + SCM_VALIDATE_INT_MIN(1,i,0); #ifdef USE_THREADS j = scm_thread_sleep (SCM_INUM(i)); #else @@ -373,15 +380,15 @@ scm_sleep (i) #endif return scm_ulong2num (j); } +#undef FUNC_NAME #if defined(USE_THREADS) || defined(HAVE_USLEEP) -SCM_PROC(s_usleep, "usleep", 1, 0, 0, scm_usleep); - -SCM -scm_usleep (i) - SCM i; +GUILE_PROC(scm_usleep, "usleep", 1, 0, 0, + (SCM i), +"") +#define FUNC_NAME s_scm_usleep { - SCM_ASSERT (SCM_INUMP (i) && (SCM_INUM (i) >= 0), i, SCM_ARG1, s_usleep); + SCM_VALIDATE_INT_MIN(1,i,0); #ifdef USE_THREADS /* If we have threads, we use the thread system's sleep function. */ @@ -401,21 +408,22 @@ scm_usleep (i) #endif #endif } +#undef FUNC_NAME #endif /* GUILE_ISELECT || HAVE_USLEEP */ -SCM_PROC(s_raise, "raise", 1, 0, 0, scm_raise); - -SCM -scm_raise(sig) - SCM sig; +GUILE_PROC(scm_raise, "raise", 1, 0, 0, + (SCM sig), +"") +#define FUNC_NAME s_scm_raise { - SCM_ASSERT(SCM_INUMP(sig), sig, SCM_ARG1, s_raise); + SCM_VALIDATE_INT(1,sig); SCM_DEFER_INTS; if (kill (getpid (), (int) SCM_INUM (sig)) != 0) - scm_syserror (s_raise); + SCM_SYSERROR; SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } +#undef FUNC_NAME diff --git a/libguile/simpos.c b/libguile/simpos.c index acb8a7b2e..66981d708 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -38,12 +38,18 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include #include "_scm.h" #include "scmsigs.h" + +#include "scm_validate.h" #include "simpos.h" #ifdef HAVE_STRING_H @@ -57,11 +63,10 @@ extern int system(); -SCM_PROC(s_system, "system", 0, 1, 0, scm_system); - -SCM -scm_system(cmd) - SCM cmd; +GUILE_PROC(scm_system, "system", 0, 1, 0, + (SCM cmd), +"") +#define FUNC_NAME s_scm_system { int rv; @@ -72,9 +77,9 @@ scm_system(cmd) #else rv = 0; #endif - return rv ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(rv); } - SCM_ASSERT(SCM_NIMP(cmd) && SCM_ROSTRINGP(cmd), cmd, SCM_ARG1, s_system); + SCM_VALIDATE_ROSTRING(1,cmd); #ifdef HAVE_SYSTEM SCM_DEFER_INTS; errno = 0; @@ -82,42 +87,44 @@ scm_system(cmd) cmd = scm_makfromstr (SCM_ROCHARS (cmd), SCM_ROLENGTH (cmd), 0); rv = system(SCM_ROCHARS(cmd)); if (rv == -1 || (rv == 127 && errno != 0)) - scm_syserror (s_system); + SCM_SYSERROR; SCM_ALLOW_INTS; return SCM_MAKINUM (rv); #else - scm_sysmissing (s_system); + SCM_SYSMISSING; #endif } +#undef FUNC_NAME extern char *getenv(); -SCM_PROC (s_getenv, "getenv", 1, 0, 0, scm_getenv); - -SCM -scm_getenv(nam) - SCM nam; +GUILE_PROC (scm_getenv, "getenv", 1, 0, 0, + (SCM nam), +"") +#define FUNC_NAME s_scm_getenv { char *val; - SCM_ASSERT(SCM_NIMP(nam) && SCM_ROSTRINGP(nam), nam, SCM_ARG1, s_getenv); - if (SCM_ROSTRINGP (nam)) - nam = scm_makfromstr (SCM_ROCHARS (nam), SCM_ROLENGTH (nam), 0); + SCM_VALIDATE_ROSTRING(1,nam); + nam = scm_makfromstr (SCM_ROCHARS (nam), SCM_ROLENGTH (nam), 0); val = getenv(SCM_CHARS(nam)); return (val) ? scm_makfromstr(val, (scm_sizet)strlen(val), 0) : SCM_BOOL_F; } +#undef FUNC_NAME /* simple exit, without unwinding the scheme stack or flushing ports. */ -SCM_PROC (s_primitive_exit, "primitive-exit", 0, 1, 0, scm_primitive_exit); -SCM -scm_primitive_exit (SCM status) +GUILE_PROC (scm_primitive_exit, "primitive-exit", 0, 1, 0, + (SCM status), + "") +#define FUNC_NAME s_scm_primitive_exit { int cstatus = 0; if (!SCM_UNBNDP (status)) { - SCM_ASSERT (SCM_INUMP (status), status, SCM_ARG1, s_primitive_exit); + SCM_VALIDATE_INT(1,status); cstatus = SCM_INUM (status); } exit (cstatus); } +#undef FUNC_NAME void diff --git a/libguile/smob.c b/libguile/smob.c index 54189bddd..b9651c252 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -273,4 +277,6 @@ scm_smob_prehistory () scm_make_smob_type_mfpe ("bigneg", 0, NULL, NULL, scm_bigprint, scm_bigequal); + + scm_make_smob_type("allocated", 0); } diff --git a/libguile/snarf.h b/libguile/snarf.h index dbb6c91e2..06baaf351 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -1,4 +1,3 @@ - /* classes: h_files */ /* Macros for snarfing initialization actions from C source. */ @@ -46,11 +45,25 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #ifndef SCM_MAGIC_SNARFER + +#define GUILE_PROC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \ +static const char s_ ## FNAME [] = PRIMNAME; \ +SCM FNAME ARGLIST +#define GUILE_PROC1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \ +static const char s_ ## FNAME [] = PRIMNAME; \ +SCM FNAME ARGLIST + #define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ static const char RANAME[]=STR +#define SCM_REGISTER_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ + static const char RANAME[]=STR #define SCM_GPROC(RANAME, STR, REQ, OPT, VAR, CFN, GF) \ static const char RANAME[]=STR; \ static SCM GF = 0 @@ -61,8 +74,16 @@ static SCM GF = 0 #else #if defined(__cplusplus) || defined(GUILE_CPLUSPLUS_SNARF) + +#define GUILE_PROC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \ +%%% scm_make_gsubr (s_ ## FNAME, REQ, OPT, VAR, (SCM (*)(...)) FNAME); +#define GUILE_PROC1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \ +%%% scm_make_subr (s_ ## FNAME, TYPE, FNAME); + #define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ -%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, (SCM (*)(...))CFN) +%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, (SCM (*)(...)) CFN) +#define SCM_REGISTER_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ +%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, (SCM (*)(...)) CFN) #define SCM_GPROC(RANAME, STR, REQ, OPT, VAR, CFN, GF) \ %%% scm_make_gsubr_with_generic (RANAME, REQ, OPT, VAR, (SCM (*)(...))CFN, &GF) #define SCM_PROC1(RANAME, STR, TYPE, CFN) \ @@ -70,8 +91,17 @@ #define SCM_GPROC1(RANAME, STR, TYPE, CFN, GF) \ %%% scm_make_subr_with_generic(RANAME, TYPE, (SCM (*)(...))CFN, &GF) #else + +#define GUILE_PROC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \ +%%% scm_make_gsubr (s_ ## FNAME, REQ, OPT, VAR, (SCM (*)()) FNAME); +#define GUILE_PROC1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \ +%%% scm_make_subr (s_ ## FNAME, TYPE, FNAME); + + #define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ %%% scm_make_gsubr (RANAME, REQ, OPT, VAR, (SCM (*)()) CFN) +#define SCM_REGISTER_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ +%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, (SCM (*)()) CFN) #define SCM_GPROC(RANAME, STR, REQ, OPT, VAR, CFN, GF) \ %%% scm_make_gsubr_with_generic (RANAME, REQ, OPT, VAR, (SCM (*)()) CFN, &GF) #define SCM_PROC1(RANAME, STR, TYPE, CFN) \ diff --git a/libguile/socket.c b/libguile/socket.c index dcaa32b08..e844e1288 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -47,6 +51,7 @@ #include "feature.h" #include "fports.h" +#include "scm_validate.h" #include "socket.h" #ifdef HAVE_STRING_H @@ -66,125 +71,121 @@ -SCM_PROC (s_htons, "htons", 1, 0, 0, scm_htons); -SCM -scm_htons (SCM in) +GUILE_PROC (scm_htons, "htons", 1, 0, 0, + (SCM in), + "") +#define FUNC_NAME s_scm_htons { unsigned short c_in; - SCM_ASSERT (SCM_INUMP (in), in, SCM_ARG1, s_htons); - c_in = SCM_INUM (in); + SCM_VALIDATE_INT_COPY(1,in,c_in); if (c_in != SCM_INUM (in)) - scm_out_of_range (s_htons, in); + SCM_OUT_OF_RANGE (1,in); return SCM_MAKINUM (htons (c_in)); } +#undef FUNC_NAME -SCM_PROC (s_ntohs, "ntohs", 1, 0, 0, scm_ntohs); -SCM -scm_ntohs (SCM in) +GUILE_PROC (scm_ntohs, "ntohs", 1, 0, 0, + (SCM in), + "") +#define FUNC_NAME s_scm_ntohs { unsigned short c_in; - SCM_ASSERT (SCM_INUMP (in), in, SCM_ARG1, s_ntohs); - c_in = SCM_INUM (in); + SCM_VALIDATE_INT_COPY(1,in,c_in); if (c_in != SCM_INUM (in)) - scm_out_of_range (s_ntohs, in); + SCM_OUT_OF_RANGE (1,in); return SCM_MAKINUM (ntohs (c_in)); } +#undef FUNC_NAME -SCM_PROC (s_htonl, "htonl", 1, 0, 0, scm_htonl); -SCM -scm_htonl (SCM in) +GUILE_PROC (scm_htonl, "htonl", 1, 0, 0, + (SCM in), + "") +#define FUNC_NAME s_scm_htonl { - unsigned long c_in = scm_num2ulong (in, (char *) SCM_ARG1, s_htonl); - + unsigned long c_in = SCM_NUM2ULONG (1,in); return scm_ulong2num (htonl (c_in)); } +#undef FUNC_NAME -SCM_PROC (s_ntohl, "ntohl", 1, 0, 0, scm_ntohl); -SCM -scm_ntohl (SCM in) +GUILE_PROC (scm_ntohl, "ntohl", 1, 0, 0, + (SCM in), + "") +#define FUNC_NAME s_scm_ntohl { - unsigned long c_in = scm_num2ulong (in, (char *) SCM_ARG1, s_ntohl); - + unsigned long c_in = SCM_NUM2ULONG (1,in); return scm_ulong2num (ntohl (c_in)); } +#undef FUNC_NAME SCM_SYMBOL (sym_socket, "socket"); -static SCM scm_sock_fd_to_port SCM_P ((int fd, const char *proc)); static SCM -scm_sock_fd_to_port (fd, proc) - int fd; - const char *proc; +scm_sock_fd_to_port (int fd, const char *proc) { SCM result; - if (fd == -1) scm_syserror (proc); result = scm_fdes_to_port (fd, "r+0", sym_socket); return result; } -SCM_PROC (s_socket, "socket", 3, 0, 0, scm_socket); -SCM -scm_socket (family, style, proto) - SCM family; - SCM style; - SCM proto; +#define SCM_SOCK_FD_TO_PORT(fd) (scm_sock_fd_to_port((fd),FUNC_NAME)) + +GUILE_PROC (scm_socket, "socket", 3, 0, 0, + (SCM family, SCM style, SCM proto), +"") +#define FUNC_NAME s_scm_socket { int fd; SCM result; - SCM_ASSERT (SCM_INUMP (family), family, SCM_ARG1, s_socket); - SCM_ASSERT (SCM_INUMP (style), style, SCM_ARG2, s_socket); - SCM_ASSERT (SCM_INUMP (proto), proto, SCM_ARG3, s_socket); + SCM_VALIDATE_INT(1,family); + SCM_VALIDATE_INT(2,style); + SCM_VALIDATE_INT(3,proto); fd = socket (SCM_INUM (family), SCM_INUM (style), SCM_INUM (proto)); - result = scm_sock_fd_to_port (fd, s_socket); + result = SCM_SOCK_FD_TO_PORT (fd); return result; } +#undef FUNC_NAME #ifdef HAVE_SOCKETPAIR -SCM_PROC (s_socketpair, "socketpair", 3, 0, 0, scm_socketpair); - -SCM -scm_socketpair (family, style, proto) - SCM family; - SCM style; - SCM proto; +GUILE_PROC (scm_socketpair, "socketpair", 3, 0, 0, + (SCM family, SCM style, SCM proto), +"") +#define FUNC_NAME s_scm_socketpair { int fam; int fd[2]; SCM a; SCM b; - SCM_ASSERT (SCM_INUMP (family), family, SCM_ARG1, s_socketpair); - SCM_ASSERT (SCM_INUMP (style), style, SCM_ARG2, s_socketpair); - SCM_ASSERT (SCM_INUMP (proto), proto, SCM_ARG3, s_socketpair); + SCM_VALIDATE_INT(1,family); + SCM_VALIDATE_INT(2,style); + SCM_VALIDATE_INT(3,proto); fam = SCM_INUM (family); if (socketpair (fam, SCM_INUM (style), SCM_INUM (proto), fd) == -1) - scm_syserror (s_socketpair); + SCM_SYSERROR; - a = scm_sock_fd_to_port (fd[0], s_socketpair); - b = scm_sock_fd_to_port (fd[1], s_socketpair); + a = SCM_SOCK_FD_TO_PORT(fd[0]); + b = SCM_SOCK_FD_TO_PORT(fd[1]); return scm_cons (a, b); } +#undef FUNC_NAME #endif -SCM_PROC (s_getsockopt, "getsockopt", 3, 0, 0, scm_getsockopt); - -SCM -scm_getsockopt (sock, level, optname) - SCM sock; - SCM level; - SCM optname; +GUILE_PROC (scm_getsockopt, "getsockopt", 3, 0, 0, + (SCM sock, SCM level, SCM optname), +"") +#define FUNC_NAME s_scm_getsockopt { int fd; int optlen; @@ -203,16 +204,13 @@ scm_getsockopt (sock, level, optname) #endif sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, - s_getsockopt); - SCM_ASSERT (SCM_INUMP (level), level, SCM_ARG2, s_getsockopt); - SCM_ASSERT (SCM_INUMP (optname), optname, SCM_ARG3, s_getsockopt); + SCM_VALIDATE_OPFPORT(1,sock); + SCM_VALIDATE_INT_COPY(2,level,ilevel); + SCM_VALIDATE_INT_COPY(3,optname,ioptname); fd = SCM_FPORT_FDES (sock); - ilevel = SCM_INUM (level); - ioptname = SCM_INUM (optname); if (getsockopt (fd, ilevel, ioptname, (void *) optval, &optlen) == -1) - scm_syserror (s_getsockopt); + SCM_SYSERROR; #ifdef SO_LINGER if (ilevel == SOL_SOCKET && ioptname == SO_LINGER) @@ -244,15 +242,12 @@ scm_getsockopt (sock, level, optname) #endif return SCM_MAKINUM (*(int *) optval); } +#undef FUNC_NAME -SCM_PROC (s_setsockopt, "setsockopt", 4, 0, 0, scm_setsockopt); - -SCM -scm_setsockopt (sock, level, optname, value) - SCM sock; - SCM level; - SCM optname; - SCM value; +GUILE_PROC (scm_setsockopt, "setsockopt", 4, 0, 0, + (SCM sock, SCM level, SCM optname, SCM value), +"") +#define FUNC_NAME s_scm_setsockopt { int fd; int optlen; @@ -263,13 +258,10 @@ scm_setsockopt (sock, level, optname, value) #endif int ilevel, ioptname; sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, - s_setsockopt); - SCM_ASSERT (SCM_INUMP (level), level, SCM_ARG2, s_setsockopt); - SCM_ASSERT (SCM_INUMP (optname), optname, SCM_ARG3, s_setsockopt); + SCM_VALIDATE_OPFPORT(1,sock); + SCM_VALIDATE_INT_COPY(2,level,ilevel); + SCM_VALIDATE_INT_COPY(3,optname,ioptname); fd = SCM_FPORT_FDES (sock); - ilevel = SCM_INUM (level); - ioptname = SCM_INUM (optname); if (0); #ifdef SO_LINGER else if (ilevel == SOL_SOCKET && ioptname == SO_LINGER) @@ -279,7 +271,7 @@ scm_setsockopt (sock, level, optname, value) SCM_ASSERT (SCM_NIMP (value) && SCM_CONSP (value) && SCM_INUMP (SCM_CAR (value)) && SCM_INUMP (SCM_CDR (value)), - value, SCM_ARG4, s_setsockopt); + value, SCM_ARG4, FUNC_NAME); ling.l_onoff = SCM_INUM (SCM_CAR (value)); ling.l_linger = SCM_INUM (SCM_CDR (value)); optlen = (int) sizeof (struct linger); @@ -289,7 +281,7 @@ scm_setsockopt (sock, level, optname, value) SCM_ASSERT (SCM_NIMP (value) && SCM_CONSP (value) && SCM_INUMP (SCM_CAR (value)) && SCM_INUMP (SCM_CDR (value)), - value, SCM_ARG4, s_setsockopt); + value, SCM_ARG4, FUNC_NAME); ling = SCM_INUM (SCM_CAR (value)); optlen = (int) sizeof (scm_sizet); (*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value); @@ -299,7 +291,7 @@ scm_setsockopt (sock, level, optname, value) #ifdef SO_SNDBUF else if (ilevel == SOL_SOCKET && ioptname == SO_SNDBUF) { - SCM_ASSERT (SCM_INUMP (value), value, SCM_ARG4, s_setsockopt); + SCM_VALIDATE_INT(4,value); optlen = (int) sizeof (scm_sizet); (*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value); } @@ -307,7 +299,7 @@ scm_setsockopt (sock, level, optname, value) #ifdef SO_RCVBUF else if (ilevel == SOL_SOCKET && ioptname == SO_RCVBUF) { - SCM_ASSERT (SCM_INUMP (value), value, SCM_ARG4, s_setsockopt); + SCM_VALIDATE_INT(4,value); optlen = (int) sizeof (scm_sizet); (*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value); } @@ -315,33 +307,32 @@ scm_setsockopt (sock, level, optname, value) else { /* Most options just take an int. */ - SCM_ASSERT (SCM_INUMP (value), value, SCM_ARG4, s_setsockopt); + SCM_VALIDATE_INT(4,value); optlen = (int) sizeof (int); (*(int *) optval) = (int) SCM_INUM (value); } if (setsockopt (fd, ilevel, ioptname, (void *) optval, optlen) == -1) - scm_syserror (s_setsockopt); + SCM_SYSERROR; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_shutdown, "shutdown", 2, 0, 0, scm_shutdown); - -SCM -scm_shutdown (sock, how) - SCM sock; - SCM how; +GUILE_PROC (scm_shutdown, "shutdown", 2, 0, 0, + (SCM sock, SCM how), +"") +#define FUNC_NAME s_scm_shutdown { int fd; sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, - s_shutdown); - SCM_ASSERT (SCM_INUMP (how) && 0 <= SCM_INUM (how) && 2 >= SCM_INUM (how), - how, SCM_ARG2, s_shutdown); + SCM_VALIDATE_OPFPORT(1,sock); + SCM_VALIDATE_INT(2,how); + SCM_ASSERT_RANGE(2,how,0 <= SCM_INUM (how) && 2 >= SCM_INUM (how)); fd = SCM_FPORT_FDES (sock); if (shutdown (fd, SCM_INUM (how)) == -1) - scm_syserror (s_shutdown); + SCM_SYSERROR; return SCM_UNSPECIFIED; } +#undef FUNC_NAME /* convert fam/address/args into a sockaddr of the appropriate type. args is modified by removing the arguments actually used. @@ -351,16 +342,8 @@ scm_shutdown (sock, how) size returns the size of the structure allocated. */ -static struct sockaddr * scm_fill_sockaddr SCM_P ((int fam, SCM address, SCM *args, int which_arg, const char *proc, scm_sizet *size)); - static struct sockaddr * -scm_fill_sockaddr (fam, address, args, which_arg, proc, size) - int fam; - SCM address; - SCM *args; - int which_arg; - const char *proc; - scm_sizet *size; +scm_fill_sockaddr (int fam,SCM address,SCM *args,int which_arg,const char *proc,scm_sizet *size) { switch (fam) { @@ -407,39 +390,31 @@ scm_fill_sockaddr (fam, address, args, which_arg, proc, size) } } -SCM_PROC (s_connect, "connect", 3, 0, 1, scm_connect); - -SCM -scm_connect (sock, fam, address, args) - - SCM sock; - SCM fam; - SCM address; - SCM args; +GUILE_PROC (scm_connect, "connect", 3, 0, 1, + (SCM sock, SCM fam, SCM address, SCM args), +"") +#define FUNC_NAME s_scm_connect { int fd; struct sockaddr *soka; scm_sizet size; sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_connect); - SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG2, s_connect); + SCM_VALIDATE_OPFPORT(1,sock); + SCM_VALIDATE_INT(2,fam); fd = SCM_FPORT_FDES (sock); - soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, s_connect, &size); + soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, FUNC_NAME, &size); if (connect (fd, soka, size) == -1) - scm_syserror (s_connect); + SCM_SYSERROR; scm_must_free ((char *) soka); return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_bind, "bind", 3, 0, 1, scm_bind); - -SCM -scm_bind (sock, fam, address, args) - SCM sock; - SCM fam; - SCM address; - SCM args; +GUILE_PROC (scm_bind, "bind", 3, 0, 1, + (SCM sock, SCM fam, SCM address, SCM args), +"") +#define FUNC_NAME s_scm_bind { int rv; struct sockaddr *soka; @@ -447,42 +422,38 @@ scm_bind (sock, fam, address, args) int fd; sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_bind); - SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG2, s_bind); - soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, s_bind, &size); + SCM_VALIDATE_OPFPORT(1,sock); + SCM_VALIDATE_INT(2,fam); + soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, FUNC_NAME, &size); fd = SCM_FPORT_FDES (sock); rv = bind (fd, soka, size); if (rv == -1) - scm_syserror (s_bind); + SCM_SYSERROR; scm_must_free ((char *) soka); return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_listen, "listen", 2, 0, 0, scm_listen); - -SCM -scm_listen (sock, backlog) - SCM sock; - SCM backlog; +GUILE_PROC (scm_listen, "listen", 2, 0, 0, + (SCM sock, SCM backlog), +"") +#define FUNC_NAME s_scm_listen { int fd; sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_listen); - SCM_ASSERT (SCM_INUMP (backlog), backlog, SCM_ARG2, s_listen); + SCM_VALIDATE_OPFPORT(1,sock); + SCM_VALIDATE_INT(2,backlog); fd = SCM_FPORT_FDES (sock); if (listen (fd, SCM_INUM (backlog)) == -1) - scm_syserror (s_listen); + SCM_SYSERROR; return SCM_UNSPECIFIED; } +#undef FUNC_NAME /* Put the components of a sockaddr into a new SCM vector. */ -static SCM scm_addr_vector SCM_P ((struct sockaddr *address, const char *proc)); - static SCM -scm_addr_vector (address, proc) - struct sockaddr *address; - const char *proc; +scm_addr_vector (struct sockaddr *address,const char *proc) { short int fam = address->sa_family; SCM result; @@ -519,10 +490,8 @@ scm_addr_vector (address, proc) static char *scm_addr_buffer; static int scm_addr_buffer_size; -static void scm_init_addr_buffer SCM_P ((void)); - static void -scm_init_addr_buffer () +scm_init_addr_buffer (void) { scm_addr_buffer_size = #ifdef HAVE_UNIX_DOMAIN_SOCKETS @@ -536,11 +505,10 @@ scm_init_addr_buffer () scm_addr_buffer = scm_must_malloc (scm_addr_buffer_size, "address buffer"); } -SCM_PROC (s_accept, "accept", 1, 0, 0, scm_accept); - -SCM -scm_accept (sock) - SCM sock; +GUILE_PROC (scm_accept, "accept", 1, 0, 0, + (SCM sock), +"") +#define FUNC_NAME s_scm_accept { int fd; int newfd; @@ -549,128 +517,112 @@ scm_accept (sock) int tmp_size; sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_accept); + SCM_VALIDATE_OPFPORT(1,sock); fd = SCM_FPORT_FDES (sock); tmp_size = scm_addr_buffer_size; newfd = accept (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size); - newsock = scm_sock_fd_to_port (newfd, s_accept); + newsock = scm_sock_fd_to_port (newfd, FUNC_NAME); if (tmp_size > 0) - address = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_accept); + address = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, FUNC_NAME); else address = SCM_BOOL_F; return scm_cons (newsock, address); } +#undef FUNC_NAME -SCM_PROC (s_getsockname, "getsockname", 1, 0, 0, scm_getsockname); - -SCM -scm_getsockname (sock) - SCM sock; +GUILE_PROC (scm_getsockname, "getsockname", 1, 0, 0, + (SCM sock), +"") +#define FUNC_NAME s_scm_getsockname { int tmp_size; int fd; SCM result; sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_getsockname); + SCM_VALIDATE_OPFPORT(1,sock); fd = SCM_FPORT_FDES (sock); tmp_size = scm_addr_buffer_size; if (getsockname (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size) == -1) - scm_syserror (s_getsockname); + SCM_SYSERROR; if (tmp_size > 0) - result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_getsockname); + result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, FUNC_NAME); else result = SCM_BOOL_F; return result; } +#undef FUNC_NAME -SCM_PROC (s_getpeername, "getpeername", 1, 0, 0, scm_getpeername); - -SCM -scm_getpeername (sock) - SCM sock; +GUILE_PROC (scm_getpeername, "getpeername", 1, 0, 0, + (SCM sock), +"") +#define FUNC_NAME s_scm_getpeername { int tmp_size; int fd; SCM result; sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_getpeername); + SCM_VALIDATE_OPFPORT(1,sock); fd = SCM_FPORT_FDES (sock); tmp_size = scm_addr_buffer_size; if (getpeername (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size) == -1) - scm_syserror (s_getpeername); + SCM_SYSERROR; if (tmp_size > 0) - result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_getpeername); + result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, FUNC_NAME); else result = SCM_BOOL_F; return result; } +#undef FUNC_NAME -SCM_PROC (s_recv, "recv!", 2, 1, 0, scm_recv); - -SCM -scm_recv (sock, buf, flags) - SCM sock; - SCM buf; - SCM flags; +GUILE_PROC (scm_recv, "recv!", 2, 1, 0, + (SCM sock, SCM buf, SCM flags), +"") +#define FUNC_NAME s_scm_recv { int rv; int fd; int flg; - SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_recv); - SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), buf, SCM_ARG2, s_recv); - + SCM_VALIDATE_OPFPORT(1,sock); + SCM_VALIDATE_STRING(2,buf); + SCM_VALIDATE_INT_DEF_COPY(3,flags,0,flg); fd = SCM_FPORT_FDES (sock); - if (SCM_UNBNDP (flags)) - flg = 0; - else - flg = scm_num2ulong (flags, (char *) SCM_ARG3, s_recv); SCM_SYSCALL (rv = recv (fd, SCM_CHARS (buf), SCM_LENGTH (buf), flg)); if (rv == -1) - scm_syserror (s_recv); + SCM_SYSERROR; return SCM_MAKINUM (rv); } +#undef FUNC_NAME -SCM_PROC (s_send, "send", 2, 1, 0, scm_send); - -SCM -scm_send (sock, message, flags) - SCM sock; - SCM message; - SCM flags; +GUILE_PROC (scm_send, "send", 2, 1, 0, + (SCM sock, SCM message, SCM flags), +"") +#define FUNC_NAME s_scm_send { int rv; int fd; int flg; sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_send); - SCM_ASSERT (SCM_NIMP (message) && SCM_ROSTRINGP (message), message, SCM_ARG2, s_send); - + SCM_VALIDATE_OPFPORT(1,sock); + SCM_VALIDATE_ROSTRING(2,message); + SCM_VALIDATE_INT_DEF_COPY(3,flags,0,flg); fd = SCM_FPORT_FDES (sock); - if (SCM_UNBNDP (flags)) - flg = 0; - else - flg = scm_num2ulong (flags, (char *) SCM_ARG3, s_send); SCM_SYSCALL (rv = send (fd, SCM_ROCHARS (message), SCM_ROLENGTH (message), flg)); if (rv == -1) - scm_syserror (s_send); + SCM_SYSERROR; return SCM_MAKINUM (rv); } +#undef FUNC_NAME -SCM_PROC (s_recvfrom, "recvfrom!", 2, 3, 0, scm_recvfrom); - -SCM -scm_recvfrom (sock, buf, flags, start, end) - SCM sock; - SCM buf; - SCM flags; - SCM start; - SCM end; +GUILE_PROC (scm_recvfrom, "recvfrom!", 2, 3, 0, + (SCM sock, SCM buf, SCM flags, SCM start, SCM end), +"") +#define FUNC_NAME s_scm_recvfrom { int rv; int fd; @@ -680,32 +632,29 @@ scm_recvfrom (sock, buf, flags, start, end) int tmp_size; SCM address; - SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, - s_recvfrom); - SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), buf, SCM_ARG2, s_recvfrom); + SCM_VALIDATE_OPFPORT(1,sock); + SCM_VALIDATE_STRING(2,buf); cend = SCM_LENGTH (buf); if (SCM_UNBNDP (flags)) flg = 0; else { - flg = scm_num2ulong (flags, (char *) SCM_ARG3, s_recvfrom); + flg = SCM_NUM2ULONG (3,flags); if (!SCM_UNBNDP (start)) { - offset = (int) scm_num2long (start, - (char *) SCM_ARG4, s_recvfrom); + offset = (int) SCM_NUM2LONG (4,start); if (offset < 0 || offset >= cend) - scm_out_of_range (s_recvfrom, start); + SCM_OUT_OF_RANGE (4, start); if (!SCM_UNBNDP (end)) { - int tend = (int) scm_num2long (end, - (char *) SCM_ARG5, s_recvfrom); + int tend = (int) SCM_NUM2LONG (5,end); if (tend <= offset || tend > cend) - scm_out_of_range (s_recvfrom, end); + SCM_OUT_OF_RANGE (5, end); cend = tend; } @@ -720,24 +669,20 @@ scm_recvfrom (sock, buf, flags, start, end) (struct sockaddr *) scm_addr_buffer, &tmp_size)); if (rv == -1) - scm_syserror (s_recvfrom); + SCM_SYSERROR; if (tmp_size > 0) - address = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_recvfrom); + address = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, FUNC_NAME); else address = SCM_BOOL_F; return scm_cons (SCM_MAKINUM (rv), address); } +#undef FUNC_NAME -SCM_PROC (s_sendto, "sendto", 4, 0, 1, scm_sendto); - -SCM -scm_sendto (sock, message, fam, address, args_and_flags) - SCM sock; - SCM message; - SCM fam; - SCM address; - SCM args_and_flags; +GUILE_PROC (scm_sendto, "sendto", 4, 0, 1, + (SCM sock, SCM message, SCM fam, SCM address, SCM args_and_flags), +"") +#define FUNC_NAME s_scm_sendto { int rv; int fd; @@ -747,20 +692,18 @@ scm_sendto (sock, message, fam, address, args_and_flags) int save_err; sock = SCM_COERCE_OUTPORT (sock); - SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_sendto); - SCM_ASSERT (SCM_NIMP (message) && SCM_ROSTRINGP (message), message, - SCM_ARG2, s_sendto); - SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG3, s_sendto); + SCM_VALIDATE_FPORT(1,sock); + SCM_VALIDATE_ROSTRING(2,message); + SCM_VALIDATE_INT(3,fam); fd = SCM_FPORT_FDES (sock); soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args_and_flags, 4, - s_sendto, &size); + FUNC_NAME, &size); if (SCM_NULLP (args_and_flags)) flg = 0; else { - SCM_ASSERT (SCM_NIMP (args_and_flags) && SCM_CONSP (args_and_flags), - args_and_flags, SCM_ARG5, s_sendto); - flg = scm_num2ulong (SCM_CAR (args_and_flags), (char *) SCM_ARG5, s_sendto); + SCM_VALIDATE_NIMCONS(5,args_and_flags); + flg = SCM_NUM2ULONG (5,SCM_CAR (args_and_flags)); } SCM_SYSCALL (rv = sendto (fd, SCM_ROCHARS (message), SCM_ROLENGTH (message), flg, soka, size)); @@ -768,9 +711,10 @@ scm_sendto (sock, message, fam, address, args_and_flags) scm_must_free ((char *) soka); errno = save_err; if (rv == -1) - scm_syserror (s_sendto); + SCM_SYSERROR; return SCM_MAKINUM (rv); } +#undef FUNC_NAME diff --git a/libguile/sort.c b/libguile/sort.c index 382fd7409..716d75f3c 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -38,6 +38,10 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + + /* Written in December 1998 by Roland Orre * This implements the same sort interface as slib/sort.scm * for lists and vectors where slib defines: @@ -82,6 +86,7 @@ char *alloca (); #include "alist.h" #include "feature.h" +#include "scm_validate.h" #include "sort.h" /* The routine quicksort was extracted from the GNU C Library qsort.c @@ -404,20 +409,22 @@ scm_cmp_function (SCM p) } } /* scm_cmp_function */ -SCM_PROC (s_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0, scm_restricted_vector_sort_x); /* Question: Is there any need to make this a more general array sort? It is probably enough to manage the vector type. */ /* endpos equal as for substring, i.e. endpos is not included. */ /* More natural wih length? */ -SCM -scm_restricted_vector_sort_x (SCM vec, SCM less, SCM startpos, SCM endpos) + +GUILE_PROC (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0, + (SCM vec, SCM less, SCM startpos, SCM endpos), +"") +#define FUNC_NAME s_scm_restricted_vector_sort_x { size_t vlen, spos, len, size = sizeof (SCM); SCM *vp; - SCM_ASSERT (SCM_NIMP (vec), vec, SCM_ARG1, s_restricted_vector_sort_x); - SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_restricted_vector_sort_x); + SCM_VALIDATE_NIMP(1,vec); + SCM_VALIDATE_NIMP(2,less); switch (SCM_TYP7 (vec)) { case scm_tc7_vector: /* the only type we manage is vector */ @@ -429,33 +436,30 @@ scm_restricted_vector_sort_x (SCM vec, SCM less, SCM startpos, SCM endpos) case scm_tc7_dvect: /* double */ #endif default: - scm_wta (vec, (char *) SCM_ARG1, s_restricted_vector_sort_x); + SCM_WTA (1,vec); } vp = SCM_VELTS (vec); /* vector pointer */ vlen = SCM_LENGTH (vec); - SCM_ASSERT (SCM_INUMP(startpos), - startpos, SCM_ARG3, s_restricted_vector_sort_x); - spos = SCM_INUM (startpos); - SCM_ASSERT ((spos >= 0) && (spos <= vlen), - startpos, SCM_ARG3, s_restricted_vector_sort_x); - SCM_ASSERT ((SCM_INUMP (endpos)) && (SCM_INUM (endpos) <= vlen), - endpos, SCM_ARG4, s_restricted_vector_sort_x); + SCM_VALIDATE_INT_COPY(3,startpos,spos); + SCM_ASSERT_RANGE (3,startpos,(spos >= 0) && (spos <= vlen)); + SCM_VALIDATE_INT_RANGE(4,endpos,0,vlen+1); len = SCM_INUM (endpos) - spos; quicksort (&vp[spos], len, size, scm_cmp_function (less), less); return SCM_UNSPECIFIED; /* return vec; */ -} /* scm_restricted_vector_sort_x */ +} +#undef FUNC_NAME /* (sorted? sequence less?) * is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm) * such that for all 1 <= i <= m, * (not (less? (list-ref list i) (list-ref list (- i 1)))). */ -SCM_PROC (s_sorted_p, "sorted?", 2, 0, 0, scm_sorted_p); - -SCM -scm_sorted_p (SCM items, SCM less) +GUILE_PROC (scm_sorted_p, "sorted?", 2, 0, 0, + (SCM items, SCM less), +"") +#define FUNC_NAME s_scm_sorted_p { long len, j; /* list/vector length, temp j */ SCM item, rest; /* rest of items loop variable */ @@ -464,13 +468,14 @@ scm_sorted_p (SCM items, SCM less) if (SCM_NULLP (items)) return SCM_BOOL_T; - SCM_ASSERT (SCM_NIMP (items), items, SCM_ARG1, s_sorted_p); - SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_sorted_p); + + SCM_VALIDATE_NIMP(1,items); + SCM_VALIDATE_NIMP(2,less); if (SCM_CONSP (items)) { len = scm_ilength (items); /* also checks that it's a pure list */ - SCM_ASSERT (len >= 0, items, SCM_ARG1, s_sorted_p); + SCM_ASSERT_RANGE (1,items,len >= 0); if (len <= 1) return SCM_BOOL_T; @@ -519,26 +524,27 @@ scm_sorted_p (SCM items, SCM less) case scm_tc7_dvect: /* double */ #endif default: - scm_wta (items, (char *) SCM_ARG1, s_sorted_p); + SCM_WTA (1,items); } } return SCM_BOOL_F; -} /* scm_sorted_p */ +} +#undef FUNC_NAME /* (merge a b less?) takes two lists a and b such that (sorted? a less?) and (sorted? b less?) and returns a new list in which the elements of a and b have been stably interleaved so that (sorted? (merge a b less?) less?). Note: this does _not_ accept vectors. */ -SCM_PROC (s_merge, "merge", 3, 0, 0, scm_merge); - -SCM -scm_merge (SCM alist, SCM blist, SCM less) +GUILE_PROC (scm_merge, "merge", 3, 0, 0, + (SCM alist, SCM blist, SCM less), +"") +#define FUNC_NAME s_scm_merge { long alen, blen; /* list lengths */ SCM build, last; cmp_fun_t cmp = scm_cmp_function (less); - SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_merge); + SCM_VALIDATE_NIMP(3,less); if (SCM_NULLP (alist)) return blist; @@ -546,10 +552,8 @@ scm_merge (SCM alist, SCM blist, SCM less) return alist; else { - alen = scm_ilength (alist); /* checks that it's a pure list */ - blen = scm_ilength (blist); /* checks that it's a pure list */ - SCM_ASSERT (alen > 0, alist, SCM_ARG1, s_merge); - SCM_ASSERT (blen > 0, blist, SCM_ARG2, s_merge); + SCM_VALIDATE_NONEMPTYLIST_COPYLEN(1,alist,alen); + SCM_VALIDATE_NONEMPTYLIST_COPYLEN(2,blist,blen); if ((*cmp) (less, &SCM_CAR (blist), &SCM_CAR (alist))) { build = scm_cons (SCM_CAR (blist), SCM_EOL); @@ -585,7 +589,9 @@ scm_merge (SCM alist, SCM blist, SCM less) SCM_SETCDR (last, blist); } return build; -} /* scm_merge */ +} +#undef FUNC_NAME + static SCM scm_merge_list_x (SCM alist, SCM blist, @@ -637,30 +643,29 @@ scm_merge_list_x (SCM alist, SCM blist, return build; } /* scm_merge_list_x */ -SCM_PROC (s_merge_x, "merge!", 3, 0, 0, scm_merge_x); - -SCM -scm_merge_x (SCM alist, SCM blist, SCM less) +GUILE_PROC (scm_merge_x, "merge!", 3, 0, 0, + (SCM alist, SCM blist, SCM less), +"") +#define FUNC_NAME s_scm_merge_x { long alen, blen; /* list lengths */ - SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_merge_x); + SCM_VALIDATE_NIMP(3,less); if (SCM_NULLP (alist)) return blist; else if (SCM_NULLP (blist)) return alist; else { - alen = scm_ilength (alist); /* checks that it's a pure list */ - blen = scm_ilength (blist); /* checks that it's a pure list */ - SCM_ASSERT (alen >= 0, alist, SCM_ARG1, s_merge); - SCM_ASSERT (blen >= 0, blist, SCM_ARG2, s_merge); + SCM_VALIDATE_NONEMPTYLIST_COPYLEN(1,alist,alen); + SCM_VALIDATE_NONEMPTYLIST_COPYLEN(2,blist,blen); return scm_merge_list_x (alist, blist, alen, blen, scm_cmp_function (less), less); } -} /* scm_merge_x */ +} +#undef FUNC_NAME /* This merge sort algorithm is same as slib's by Richard A. O'Keefe. The algorithm is stable. We also tried to use the algorithm used by @@ -709,22 +714,21 @@ scm_merge_list_step (SCM * seq, } /* scm_merge_list_step */ -SCM_PROC (s_sort_x, "sort!", 2, 0, 0, scm_sort_x); - /* scm_sort_x manages lists and vectors, not stable sort */ -SCM -scm_sort_x (SCM items, SCM less) +GUILE_PROC (scm_sort_x, "sort!", 2, 0, 0, + (SCM items, SCM less), +"") +#define FUNC_NAME s_scm_sort_x { long len; /* list/vector length */ if (SCM_NULLP(items)) return SCM_EOL; - SCM_ASSERT (SCM_NIMP (items), items, SCM_ARG1, s_sort_x); - SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_sort_x); + SCM_VALIDATE_NIMP(1,items); + SCM_VALIDATE_NIMP(2,less); if (SCM_CONSP (items)) { - len = scm_ilength (items); - SCM_ASSERT (len >= 0, items, SCM_ARG1, s_sort_x); + SCM_VALIDATE_LIST_COPYLEN(1,items,len); return scm_merge_list_step (&items, scm_cmp_function (less), less, len); } else if (SCM_VECTORP (items)) @@ -737,25 +741,26 @@ scm_sort_x (SCM items, SCM less) return items; } else - return scm_wta (items, (char *) SCM_ARG1, s_sort_x); -} /* scm_sort_x */ - -SCM_PROC (s_sort, "sort", 2, 0, 0, scm_sort); + RETURN_SCM_WTA (1,items); +} +#undef FUNC_NAME /* scm_sort_x */ /* scm_sort manages lists and vectors, not stable sort */ -SCM -scm_sort (SCM items, SCM less) + +GUILE_PROC (scm_sort, "sort", 2, 0, 0, + (SCM items, SCM less), +"") +#define FUNC_NAME s_scm_sort { SCM sortvec; /* the vector we actually sort */ long len; /* list/vector length */ if (SCM_NULLP(items)) return SCM_EOL; - SCM_ASSERT (SCM_NIMP (items), items, SCM_ARG1, s_sort); - SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_sort); + SCM_VALIDATE_NIMP(1,items); + SCM_VALIDATE_NIMP(2,less); if (SCM_CONSP (items)) { - len = scm_ilength (items); - SCM_ASSERT (len >= 0, items, SCM_ARG1, s_sort); + SCM_VALIDATE_LIST_COPYLEN(1,items,len); items = scm_list_copy (items); return scm_merge_list_step (&items, scm_cmp_function (less), less, len); } @@ -774,8 +779,9 @@ scm_sort (SCM items, SCM less) } #endif else - return scm_wta (items, (char *) SCM_ARG1, s_sort_x); -} /* scm_sort */ + RETURN_SCM_WTA (1,items); +} +#undef FUNC_NAME /* scm_sort */ static void scm_merge_vector_x (void *const vecbase, @@ -830,22 +836,22 @@ scm_merge_vector_step (void *const vp, } /* scm_merge_vector_step */ -SCM_PROC (s_stable_sort_x, "stable-sort!", 2, 0, 0, scm_stable_sort_x); /* stable-sort! manages lists and vectors */ -SCM -scm_stable_sort_x (SCM items, SCM less) +GUILE_PROC (scm_stable_sort_x, "stable-sort!", 2, 0, 0, + (SCM items, SCM less), +"") +#define FUNC_NAME s_scm_stable_sort_x { long len; /* list/vector length */ if (SCM_NULLP (items)) return SCM_EOL; - SCM_ASSERT (SCM_NIMP (items), items, SCM_ARG1, s_stable_sort_x); - SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_stable_sort_x); + SCM_VALIDATE_NIMP(1,items); + SCM_VALIDATE_NIMP(2,less); if (SCM_CONSP (items)) { - len = scm_ilength (items); - SCM_ASSERT (len >= 0, items, SCM_ARG1, s_sort_x); + SCM_VALIDATE_LIST_COPYLEN(1,items,len); return scm_merge_list_step (&items, scm_cmp_function (less), less, len); } else if (SCM_VECTORP (items)) @@ -864,24 +870,25 @@ scm_stable_sort_x (SCM items, SCM less) return items; } else - return scm_wta (items, (char *) SCM_ARG1, s_stable_sort_x); -} /* scm_stable_sort_x */ - -SCM_PROC (s_stable_sort, "stable-sort", 2, 0, 0, scm_stable_sort); + RETURN_SCM_WTA (1,items); +} +#undef FUNC_NAME /* scm_stable_sort_x */ /* stable_sort manages lists and vectors */ -SCM -scm_stable_sort (SCM items, SCM less) + +GUILE_PROC (scm_stable_sort, "stable-sort", 2, 0, 0, + (SCM items, SCM less), +"") +#define FUNC_NAME s_scm_stable_sort { long len; /* list/vector length */ if (SCM_NULLP (items)) return SCM_EOL; - SCM_ASSERT (SCM_NIMP (items), items, SCM_ARG1, s_stable_sort); - SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_stable_sort); + SCM_VALIDATE_NIMP(1,items); + SCM_VALIDATE_NIMP(2,less); if (SCM_CONSP (items)) { - len = scm_ilength (items); - SCM_ASSERT (len >= 0, items, SCM_ARG1, s_sort); + SCM_VALIDATE_LIST_COPYLEN(1,items,len); items = scm_list_copy (items); return scm_merge_list_step (&items, scm_cmp_function (less), less, len); } @@ -907,31 +914,36 @@ scm_stable_sort (SCM items, SCM less) } #endif else - return scm_wta (items, (char *) SCM_ARG1, s_stable_sort); -} /* scm_stable_sort */ - -SCM_PROC (s_sort_list_x, "sort-list!", 2, 0, 0, scm_sort_list_x); + RETURN_SCM_WTA (1,items); +} +#undef FUNC_NAME /* scm_stable_sort */ -SCM /* stable */ -scm_sort_list_x (SCM items, SCM less) +/* stable */ +GUILE_PROC (scm_sort_list_x, "sort-list!", 2, 0, 0, + (SCM items, SCM less), +"") +#define FUNC_NAME s_scm_sort_list_x { - long len = scm_ilength (items); - SCM_ASSERT (len >= 0, items, SCM_ARG1, s_sort_list_x); - SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_sort_list_x); + long len; + SCM_VALIDATE_LIST_COPYLEN(1,items,len); + SCM_VALIDATE_NIMP(2,less); return scm_merge_list_step (&items, scm_cmp_function (less), less, len); -} /* scm_sort_list_x */ - -SCM_PROC (s_sort_list, "sort-list", 2, 0, 0, scm_sort_list); +} +#undef FUNC_NAME /* scm_sort_list_x */ -SCM /* stable */ -scm_sort_list (SCM items, SCM less) +/* stable */ +GUILE_PROC (scm_sort_list, "sort-list", 2, 0, 0, + (SCM items, SCM less), +"") +#define FUNC_NAME s_scm_sort_list { - long len = scm_ilength (items); - SCM_ASSERT (len >= 0, items, SCM_ARG1, s_sort_list); - SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_sort_list); + long len; + SCM_VALIDATE_LIST_COPYLEN(1,items,len); + SCM_VALIDATE_NIMP(2,less); items = scm_list_copy (items); return scm_merge_list_step (&items, scm_cmp_function (less), less, len); -} /* scm_sort_list_x */ +} +#undef FUNC_NAME /* scm_sort_list_x */ void scm_init_sort () diff --git a/libguile/srcprop.c b/libguile/srcprop.c index fd53092b4..9c0be93b4 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -41,6 +41,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 @@ -53,6 +57,7 @@ #include "hash.h" #include "weaks.h" +#include "scm_validate.h" #include "srcprop.h" /* {Source Properties} @@ -81,11 +86,8 @@ static scm_srcprops_chunk *srcprops_chunklist = 0; static scm_srcprops *srcprops_freelist = 0; -static SCM marksrcprops SCM_P ((SCM obj)); - static SCM -marksrcprops (obj) - SCM obj; +marksrcprops (SCM obj) { scm_gc_mark (SRCPROPFNAME (obj)); scm_gc_mark (SRCPROPCOPY (obj)); @@ -93,11 +95,8 @@ marksrcprops (obj) } -static scm_sizet freesrcprops SCM_P ((SCM obj)); - static scm_sizet -freesrcprops (obj) - SCM obj; +freesrcprops (SCM obj) { *((scm_srcprops **) SCM_CDR (obj)) = srcprops_freelist; srcprops_freelist = (scm_srcprops *) SCM_CDR (obj); @@ -105,13 +104,8 @@ freesrcprops (obj) } -static int prinsrcprops SCM_P ((SCM obj, SCM port, scm_print_state *pstate)); - static int -prinsrcprops (obj, port, pstate) - SCM obj; - SCM port; - scm_print_state *pstate; +prinsrcprops (SCM obj,SCM port,scm_print_state *pstate) { int writingp = SCM_WRITINGP (pstate); scm_puts ("# @@ -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 diff --git a/libguile/stime.c b/libguile/stime.c index 8db49928d..5965b5dca 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -38,12 +38,17 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include #include "_scm.h" #include "feature.h" +#include "scm_validate.h" #include "stime.h" #ifdef HAVE_UNISTD_H @@ -123,9 +128,11 @@ extern int errno; #ifdef HAVE_FTIME struct timeb scm_your_base = {0}; -SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time); -SCM -scm_get_internal_real_time() + +GUILE_PROC(scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_get_internal_real_time { struct timeb time_buffer; @@ -138,22 +145,29 @@ scm_get_internal_real_time() SCM_MAKINUM (time_buffer.time))); return scm_quotient (scm_product (tmp, SCM_MAKINUM (CLKTCK)), SCM_MAKINUM (1000)); -}; +} +#undef FUNC_NAME + #else timet scm_your_base = 0; -SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time); -SCM -scm_get_internal_real_time() + +GUILE_PROC(scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0, + (), + "") +#define FUNC_NAME s_scm_get_internal_real_time { return scm_long2num((time((timet*)0) - scm_your_base) * (int)CLKTCK); } +#undef FUNC_NAME + #endif -SCM_PROC (s_times, "times", 0, 0, 0, scm_times); -SCM -scm_times (void) +GUILE_PROC (scm_times, "times", 0, 0, 0, + (void), +"") +#define FUNC_NAME s_scm_times { #ifdef HAVE_TIMES struct tms t; @@ -162,7 +176,7 @@ scm_times (void) SCM result = scm_make_vector (SCM_MAKINUM(5), SCM_UNDEFINED); rv = times (&t); if (rv == -1) - scm_syserror (s_times); + SCM_SYSERROR; SCM_VELTS (result)[0] = scm_long2num (rv); SCM_VELTS (result)[1] = scm_long2num (t.tms_utime); SCM_VELTS (result)[2] = scm_long2num (t.tms_stime); @@ -170,9 +184,10 @@ scm_times (void) SCM_VELTS (result)[4] = scm_long2num (t.tms_cstime); return result; #else - scm_sysmissing (s_times); + SCM_SYSMISSING; #endif } +#undef FUNC_NAME #ifndef HAVE_TZSET /* GNU-WIN32's cygwin.dll doesn't have this. */ @@ -182,36 +197,41 @@ scm_times (void) static long scm_my_base = 0; -SCM_PROC(s_get_internal_run_time, "get-internal-run-time", 0, 0, 0, scm_get_internal_run_time); -SCM -scm_get_internal_run_time() +GUILE_PROC(scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0, + (void), +"") +#define FUNC_NAME s_scm_get_internal_run_time { return scm_long2num(mytime()-scm_my_base); } +#undef FUNC_NAME -SCM_PROC(s_current_time, "current-time", 0, 0, 0, scm_current_time); -SCM -scm_current_time() +GUILE_PROC(scm_current_time, "current-time", 0, 0, 0, + (void), +"") +#define FUNC_NAME s_scm_current_time { timet timv; SCM_DEFER_INTS; if ((timv = time (0)) == -1) - scm_syserror (s_current_time); + SCM_SYSERROR; SCM_ALLOW_INTS; return scm_long2num((long) timv); } +#undef FUNC_NAME -SCM_PROC (s_gettimeofday, "gettimeofday", 0, 0, 0, scm_gettimeofday); -SCM -scm_gettimeofday (void) +GUILE_PROC (scm_gettimeofday, "gettimeofday", 0, 0, 0, + (void), + "") +#define FUNC_NAME s_scm_gettimeofday { #ifdef HAVE_GETTIMEOFDAY struct timeval time; SCM_DEFER_INTS; if (gettimeofday (&time, NULL) == -1) - scm_syserror (s_gettimeofday); + SCM_SYSERROR; SCM_ALLOW_INTS; return scm_cons (scm_long2num ((long) time.tv_sec), scm_long2num ((long) time.tv_usec)); @@ -227,12 +247,13 @@ scm_gettimeofday (void) SCM_DEFER_INTS; if ((timv = time (0)) == -1) - scm_syserror (s_gettimeofday); + SCM_SYSERROR; SCM_ALLOW_INTS; return scm_cons (scm_long2num (timv), SCM_MAKINUM (0)); # endif #endif } +#undef FUNC_NAME static SCM filltime (struct tm *bd_time, int zoff, char *zname) @@ -293,9 +314,10 @@ restorezone (SCM zone, char **oldenv, const char *subr) } -SCM_PROC (s_localtime, "localtime", 1, 1, 0, scm_localtime); -SCM -scm_localtime (SCM time, SCM zone) +GUILE_PROC (scm_localtime, "localtime", 1, 1, 0, + (SCM time, SCM zone), +"") +#define FUNC_NAME s_scm_localtime { timet itime; struct tm *ltptr, lt, *utc; @@ -305,9 +327,9 @@ scm_localtime (SCM time, SCM zone) char **oldenv; int err; - itime = scm_num2long (time, (char *) SCM_ARG1, s_localtime); + itime = SCM_NUM2LONG (1,time); SCM_DEFER_INTS; - oldenv = setzone (zone, SCM_ARG2, s_localtime); + oldenv = setzone (zone, SCM_ARG2, FUNC_NAME); ltptr = localtime (&itime); err = errno; if (ltptr) @@ -321,11 +343,10 @@ scm_localtime (SCM time, SCM zone) # ifdef HAVE_TZNAME ptr = tzname[ (ltptr->tm_isdst == 1) ? 1 : 0 ]; # else - scm_misc_error (s_localtime, "Not fully implemented on this platform", - SCM_EOL); + SCM_MISC_ERROR ("Not fully implemented on this platform",_EOL); # endif #endif - zname = scm_must_malloc (strlen (ptr) + 1, s_localtime); + zname = SCM_MUST_MALLOC (strlen (ptr) + 1); strcpy (zname, ptr); } /* the struct is copied in case localtime and gmtime share a buffer. */ @@ -334,11 +355,11 @@ scm_localtime (SCM time, SCM zone) utc = gmtime (&itime); if (utc == NULL) err = errno; - restorezone (zone, oldenv, s_localtime); + restorezone (zone, oldenv, FUNC_NAME); /* delayed until zone has been restored. */ errno = err; if (utc == NULL || ltptr == NULL) - scm_syserror (s_localtime); + SCM_SYSERROR; /* calculate timezone offset in seconds west of UTC. */ zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60 @@ -357,24 +378,27 @@ scm_localtime (SCM time, SCM zone) scm_must_free (zname); return result; } +#undef FUNC_NAME -SCM_PROC (s_gmtime, "gmtime", 1, 0, 0, scm_gmtime); -SCM -scm_gmtime (SCM time) +GUILE_PROC (scm_gmtime, "gmtime", 1, 0, 0, + (SCM time), +"") +#define FUNC_NAME s_scm_gmtime { timet itime; struct tm *bd_time; SCM result; - itime = scm_num2long (time, (char *) SCM_ARG1, s_gmtime); + itime = SCM_NUM2LONG (1,time); SCM_DEFER_INTS; bd_time = gmtime (&itime); if (bd_time == NULL) - scm_syserror (s_gmtime); + SCM_SYSERROR; result = filltime (bd_time, 0, "GMT"); SCM_ALLOW_INTS; return result; } +#undef FUNC_NAME /* copy time components from a Scheme object to a struct tm. */ static void @@ -413,9 +437,10 @@ bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr) #endif } -SCM_PROC (s_mktime, "mktime", 1, 1, 0, scm_mktime); -SCM -scm_mktime (SCM sbd_time, SCM zone) +GUILE_PROC (scm_mktime, "mktime", 1, 1, 0, + (SCM sbd_time, SCM zone), +"") +#define FUNC_NAME s_scm_mktime { timet itime; struct tm lt, *utc; @@ -425,10 +450,10 @@ scm_mktime (SCM sbd_time, SCM zone) char **oldenv; int err; - bdtime2c (sbd_time, <, SCM_ARG1, s_mktime); + bdtime2c (sbd_time, <, SCM_ARG1, FUNC_NAME); SCM_DEFER_INTS; - oldenv = setzone (zone, SCM_ARG2, s_mktime); + oldenv = setzone (zone, SCM_ARG2, FUNC_NAME); itime = mktime (<); err = errno; @@ -447,7 +472,7 @@ scm_mktime (SCM sbd_time, SCM zone) SCM_EOL); # endif #endif - zname = scm_must_malloc (strlen (ptr) + 1, s_mktime); + zname = SCM_MUST_MALLOC (strlen (ptr) + 1); strcpy (zname, ptr); } @@ -456,11 +481,11 @@ scm_mktime (SCM sbd_time, SCM zone) if (utc == NULL) err = errno; - restorezone (zone, oldenv, s_mktime); + restorezone (zone, oldenv, FUNC_NAME); /* delayed until zone has been restored. */ errno = err; if (utc == NULL || itime == -1) - scm_syserror (s_mktime); + SCM_SYSERROR; zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60 + utc->tm_sec - lt.tm_sec; @@ -479,21 +504,22 @@ scm_mktime (SCM sbd_time, SCM zone) scm_must_free (zname); return result; } +#undef FUNC_NAME -SCM_PROC (s_tzset, "tzset", 0, 0, 0, scm_tzset); -SCM -scm_tzset (void) +GUILE_PROC (scm_tzset, "tzset", 0, 0, 0, + (void), +"") +#define FUNC_NAME s_scm_tzset { tzset(); return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_strftime, "strftime", 2, 0, 0, scm_strftime); - -SCM -scm_strftime (format, stime) - SCM format; - SCM stime; +GUILE_PROC (scm_strftime, "strftime", 2, 0, 0, + (SCM format, SCM stime), +"") +#define FUNC_NAME s_scm_strftime { struct tm t; @@ -503,41 +529,37 @@ scm_strftime (format, stime) int len; SCM result; - SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1, - s_strftime); - bdtime2c (stime, &t, SCM_ARG2, s_strftime); + SCM_VALIDATE_ROSTRING(1,format); + bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME); SCM_COERCE_SUBSTR (format); fmt = SCM_ROCHARS (format); len = SCM_ROLENGTH (format); - tbuf = scm_must_malloc (size, s_strftime); + tbuf = SCM_MUST_MALLOC (size); while ((len = strftime (tbuf, size, fmt, &t)) == size) { scm_must_free (tbuf); size *= 2; - tbuf = scm_must_malloc (size, s_strftime); + tbuf = SCM_MUST_MALLOC (size); } result = scm_makfromstr (tbuf, len, 0); scm_must_free (tbuf); return result; } +#undef FUNC_NAME -SCM_PROC (s_strptime, "strptime", 2, 0, 0, scm_strptime); - -SCM -scm_strptime (format, string) - SCM format; - SCM string; +GUILE_PROC (scm_strptime, "strptime", 2, 0, 0, + (SCM format, SCM string), +"") +#define FUNC_NAME s_scm_strptime { #ifdef HAVE_STRPTIME struct tm t; char *fmt, *str, *rest; - SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1, - s_strptime); - SCM_ASSERT (SCM_NIMP (string) && SCM_ROSTRINGP (string), string, SCM_ARG2, - s_strptime); + SCM_VALIDATE_ROSTRING(1,format); + SCM_VALIDATE_ROSTRING(2,string); SCM_COERCE_SUBSTR (format); SCM_COERCE_SUBSTR (string); @@ -559,15 +581,16 @@ scm_strptime (format, string) t.tm_isdst = -1; SCM_DEFER_INTS; if ((rest = strptime (str, fmt, &t)) == NULL) - scm_syserror (s_strptime); + SCM_SYSERROR; SCM_ALLOW_INTS; return scm_cons (filltime (&t, 0, NULL), SCM_MAKINUM (rest - str)); #else - scm_sysmissing (s_strptime); + SCM_SYSMISSING; #endif } +#undef FUNC_NAME void scm_init_stime() diff --git a/libguile/strings.c b/libguile/strings.c index 708ef7581..4989436e1 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -45,39 +49,41 @@ #include "chars.h" #include "strings.h" +#include "scm_validate.h" /* {Strings} */ -SCM_PROC(s_string_p, "string?", 1, 0, 0, scm_string_p); - -SCM -scm_string_p (x) - SCM x; +GUILE_PROC(scm_string_p, "string?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_string_p { if (SCM_IMP (x)) return SCM_BOOL_F; - return SCM_STRINGP (x) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(SCM_STRINGP (x)); } +#undef FUNC_NAME -SCM_PROC(s_read_only_string_p, "read-only-string?", 1, 0, 0, scm_read_only_string_p); - -SCM -scm_read_only_string_p (x) - SCM x; +GUILE_PROC(scm_read_only_string_p, "read-only-string?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_read_only_string_p { if (SCM_IMP (x)) return SCM_BOOL_F; - return SCM_ROSTRINGP (x) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(SCM_ROSTRINGP (x)); } +#undef FUNC_NAME -SCM_PROC(s_list_to_string, "list->string", 1, 0, 0, scm_string); -SCM_PROC(s_string, "string", 0, 0, 1, scm_string); +SCM_REGISTER_PROC(s_list_to_string, "list->string", 1, 0, 0, scm_string); -SCM -scm_string (chrs) - SCM chrs; + +GUILE_PROC(scm_string, "string", 0, 0, 1, + (SCM chrs), +"") +#define FUNC_NAME s_scm_string { SCM res; register unsigned char *data; @@ -88,7 +94,7 @@ scm_string (chrs) if (i < 0) { SCM_ALLOW_INTS; - SCM_ASSERT (0, chrs, SCM_ARG1, s_string); + SCM_ASSERT (0, chrs, SCM_ARG1, FUNC_NAME); } len = 0; { @@ -102,7 +108,7 @@ scm_string (chrs) else { SCM_ALLOW_INTS; - SCM_ASSERT (0, s, SCM_ARG1, s_string); + SCM_ASSERT (0, s, SCM_ARG1, FUNC_NAME); } } res = scm_makstr (len, 0); @@ -127,12 +133,11 @@ scm_string (chrs) SCM_ALLOW_INTS; return res; } +#undef FUNC_NAME SCM -scm_makstr (len, slots) - long len; - int slots; +scm_makstr (long len, int slots) { SCM s; SCM * mem; @@ -140,7 +145,7 @@ scm_makstr (len, slots) --slots; SCM_REDEFER_INTS; mem = (SCM *)scm_must_malloc (sizeof (SCM) * (slots + 1) + len + 1, - s_string); + "scm_makstr"); if (slots >= 0) { int x; @@ -159,9 +164,7 @@ scm_makstr (len, slots) /* If argc < 0, a null terminated scm_array is assumed. */ SCM -scm_makfromstrs (argc, argv) - int argc; - char **argv; +scm_makfromstrs (int argc, char **argv) { int i = argc; SCM lst = SCM_EOL; @@ -203,10 +206,7 @@ scm_take0str (char *s) SCM -scm_makfromstr (src, len, slots) - const char *src; - scm_sizet len; - int slots; +scm_makfromstr (const char *src, scm_sizet len, int slots) { SCM s; register char *dst; @@ -220,8 +220,7 @@ scm_makfromstr (src, len, slots) SCM -scm_makfrom0str (src) - const char *src; +scm_makfrom0str (const char *src) { if (!src) return SCM_BOOL_F; return scm_makfromstr (src, (scm_sizet) strlen (src), 0); @@ -229,8 +228,7 @@ scm_makfrom0str (src) SCM -scm_makfrom0str_opt (src) - const char *src; +scm_makfrom0str_opt (const char *src) { return scm_makfrom0str (src); } @@ -238,21 +236,18 @@ scm_makfrom0str_opt (src) -SCM_PROC(s_make_string, "make-string", 1, 1, 0, scm_make_string); - -SCM -scm_make_string (k, chr) - SCM k; - SCM chr; +GUILE_PROC(scm_make_string, "make-string", 1, 1, 0, + (SCM k, SCM chr), +"") +#define FUNC_NAME s_scm_make_string { SCM res; register long i; - SCM_ASSERT (SCM_INUMP (k) && (k >= 0), k, SCM_ARG1, s_make_string); - i = SCM_INUM (k); + SCM_VALIDATE_INT_MIN_COPY(1,k,0,i); res = scm_makstr (i, 0); if (!SCM_UNBNDP (chr)) { - SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG2, s_make_string); + SCM_VALIDATE_CHAR(2,chr); { unsigned char *dst = SCM_UCHARS (res); char c = SCM_ICHR (chr); @@ -262,96 +257,79 @@ scm_make_string (k, chr) } return res; } +#undef FUNC_NAME -SCM_PROC(s_string_length, "string-length", 1, 0, 0, scm_string_length); - -SCM -scm_string_length (str) - SCM str; +GUILE_PROC(scm_string_length, "string-length", 1, 0, 0, + (SCM str), +"") +#define FUNC_NAME s_scm_string_length { - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_length); + SCM_VALIDATE_ROSTRING(1,str); return SCM_MAKINUM (SCM_ROLENGTH (str)); } +#undef FUNC_NAME -SCM_PROC(s_string_ref, "string-ref", 1, 1, 0, scm_string_ref); - -SCM -scm_string_ref (str, k) - SCM str; - SCM k; +GUILE_PROC(scm_string_ref, "string-ref", 1, 1, 0, + (SCM str, SCM k), +"") +#define FUNC_NAME s_scm_string_ref { - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_ref); - if (k == SCM_UNDEFINED) - k = SCM_MAKINUM (0); - SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG2, s_string_ref); - SCM_ASSERT (SCM_INUM (k) < SCM_ROLENGTH (str) && SCM_INUM (k) >= 0, k, SCM_OUTOFRANGE, s_string_ref); + SCM_VALIDATE_ROSTRING(1,str); + SCM_VALIDATE_INT_DEF(2,k,0); + SCM_ASSERT (SCM_INUM (k) < SCM_ROLENGTH (str) && SCM_INUM (k) >= 0, k, SCM_OUTOFRANGE, FUNC_NAME); return SCM_MAKICHR (SCM_ROUCHARS (str)[SCM_INUM (k)]); } +#undef FUNC_NAME -SCM_PROC(s_string_set_x, "string-set!", 3, 0, 0, scm_string_set_x); - -SCM -scm_string_set_x (str, k, chr) - SCM str; - SCM k; - SCM chr; +GUILE_PROC(scm_string_set_x, "string-set!", 3, 0, 0, + (SCM str, SCM k, SCM chr), +"") +#define FUNC_NAME s_scm_string_set_x { - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), - str, SCM_ARG1, s_string_set_x); - SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG2, s_string_set_x); - SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG3, s_string_set_x); - if (! SCM_RWSTRINGP (str)) - scm_misc_error (s_string_set_x, "argument is a read-only string", str); - SCM_ASSERT ((SCM_INUM (k) >= 0 - && ((unsigned) SCM_INUM (k)) < SCM_LENGTH (str)), - k, SCM_OUTOFRANGE, s_string_set_x); + SCM_VALIDATE_RWSTRING(1,str); + SCM_VALIDATE_INT_RANGE(2,k,0,SCM_LENGTH(str)); + SCM_VALIDATE_CHAR(3,chr); SCM_UCHARS (str)[SCM_INUM (k)] = SCM_ICHR (chr); return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_substring, "substring", 2, 1, 0, scm_substring); - -SCM -scm_substring (str, start, end) - SCM str; - SCM start; - SCM end; +GUILE_PROC(scm_substring, "substring", 2, 1, 0, + (SCM str, SCM start, SCM end), +"") +#define FUNC_NAME s_scm_substring { long l; - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), - str, SCM_ARG1, s_substring); - SCM_ASSERT (SCM_INUMP (start), start, SCM_ARG2, s_substring); - if (end == SCM_UNDEFINED) - end = SCM_MAKINUM (SCM_ROLENGTH (str)); - SCM_ASSERT (SCM_INUMP (end), end, SCM_ARG3, s_substring); - SCM_ASSERT (SCM_INUM (start) <= SCM_ROLENGTH (str), start, SCM_OUTOFRANGE, s_substring); - SCM_ASSERT (SCM_INUM (end) <= SCM_ROLENGTH (str), end, SCM_OUTOFRANGE, s_substring); + SCM_VALIDATE_ROSTRING(1,str); + SCM_VALIDATE_INT(2,start); + SCM_VALIDATE_INT_DEF(3,end,SCM_ROLENGTH(str)); + SCM_ASSERT (SCM_INUM (start) <= SCM_ROLENGTH (str), start, SCM_OUTOFRANGE, FUNC_NAME); + SCM_ASSERT (SCM_INUM (end) <= SCM_ROLENGTH (str), end, SCM_OUTOFRANGE, FUNC_NAME); l = SCM_INUM (end)-SCM_INUM (start); - SCM_ASSERT (l >= 0, SCM_MAKINUM (l), SCM_OUTOFRANGE, s_substring); + SCM_ASSERT (l >= 0, SCM_MAKINUM (l), SCM_OUTOFRANGE, FUNC_NAME); return scm_makfromstr (&SCM_ROCHARS (str)[SCM_INUM (start)], (scm_sizet)l, 0); } +#undef FUNC_NAME -SCM_PROC(s_string_append, "string-append", 0, 0, 1, scm_string_append); - -SCM -scm_string_append (args) - SCM args; +GUILE_PROC(scm_string_append, "string-append", 0, 0, 1, + (SCM args), +"") +#define FUNC_NAME s_scm_string_append { SCM res; register long i = 0; register SCM l, s; register unsigned char *data; for (l = args;SCM_NIMP (l);) { - SCM_ASSERT (SCM_CONSP (l), l, SCM_ARGn, s_string_append); + SCM_ASSERT (SCM_CONSP (l), l, SCM_ARGn, FUNC_NAME); s = SCM_CAR (l); - SCM_ASSERT (SCM_NIMP (s) && SCM_ROSTRINGP (s), - s, SCM_ARGn, s_string_append); + SCM_VALIDATE_ROSTRING(SCM_ARGn,s); i += SCM_ROLENGTH (s); l = SCM_CDR (l); } - SCM_ASSERT (SCM_NULLP (l), args, SCM_ARGn, s_string_append); + 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)) { @@ -360,37 +338,25 @@ scm_string_append (args) } return res; } +#undef FUNC_NAME -SCM_PROC(s_make_shared_substring, "make-shared-substring", 1, 2, 0, scm_make_shared_substring); - -SCM -scm_make_shared_substring (str, frm, to) - SCM str; - SCM frm; - SCM to; +GUILE_PROC(scm_make_shared_substring, "make-shared-substring", 1, 2, 0, + (SCM str, SCM frm, SCM to), +"") +#define FUNC_NAME s_scm_make_shared_substring { long f; long t; SCM answer; SCM len_str; - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_make_shared_substring); - - if (frm == SCM_UNDEFINED) - frm = SCM_MAKINUM (0); - else - SCM_ASSERT (SCM_INUMP (frm), frm, SCM_ARG2, s_make_shared_substring); - - if (to == SCM_UNDEFINED) - to = SCM_MAKINUM (SCM_ROLENGTH (str)); - else - SCM_ASSERT (SCM_INUMP (to), to, SCM_ARG3, s_make_shared_substring); + SCM_VALIDATE_ROSTRING(1,str); + SCM_VALIDATE_INT_DEF_COPY(2,frm,0,f); + SCM_VALIDATE_INT_DEF_COPY(3,to,0,t); - f = SCM_INUM (frm); - t = SCM_INUM (to); - SCM_ASSERT ((f >= 0), frm, SCM_OUTOFRANGE, s_make_shared_substring); + SCM_ASSERT ((f >= 0), frm, SCM_OUTOFRANGE, FUNC_NAME); SCM_ASSERT ((f <= t) && (t <= SCM_ROLENGTH (str)), to, SCM_OUTOFRANGE, - s_make_shared_substring); + FUNC_NAME); SCM_NEWCELL (answer); SCM_NEWCELL (len_str); @@ -417,7 +383,7 @@ scm_make_shared_substring (str, frm, to) SCM_ALLOW_INTS; return answer; } - +#undef FUNC_NAME void scm_init_strings () diff --git a/libguile/strop.c b/libguile/strop.c index 4bee02154..2aa335f2a 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -17,12 +17,17 @@ along with this software; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA */ +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + + #include #include "_scm.h" #include "chars.h" +#include "scm_validate.h" #include "strop.h" #include "read.h" /*For SCM_CASE_INSENSITIVE_P*/ @@ -32,7 +37,6 @@ Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA static int scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start, SCM sub_end, const char *why) - { unsigned char * p; int x; @@ -82,10 +86,10 @@ scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start, return -1; } -SCM_PROC(s_string_index, "string-index", 2, 2, 0, scm_string_index); - -SCM -scm_string_index (SCM str, SCM chr, SCM frm, SCM to) +GUILE_PROC(scm_string_index, "string-index", 2, 2, 0, + (SCM str, SCM chr, SCM frm, SCM to), +"") +#define FUNC_NAME s_scm_string_index { int pos; @@ -93,16 +97,17 @@ scm_string_index (SCM str, SCM chr, SCM frm, SCM to) frm = SCM_BOOL_F; if (to == SCM_UNDEFINED) to = SCM_BOOL_F; - pos = scm_i_index (&str, chr, 1, frm, to, s_string_index); + pos = scm_i_index (&str, chr, 1, frm, to, FUNC_NAME); return (pos < 0 ? SCM_BOOL_F : SCM_MAKINUM (pos)); } +#undef FUNC_NAME -SCM_PROC(s_string_rindex, "string-rindex", 2, 2, 0, scm_string_rindex); - -SCM -scm_string_rindex (SCM str, SCM chr, SCM frm, SCM to) +GUILE_PROC(scm_string_rindex, "string-rindex", 2, 2, 0, + (SCM str, SCM chr, SCM frm, SCM to), +"") +#define FUNC_NAME s_scm_string_rindex { int pos; @@ -110,43 +115,36 @@ scm_string_rindex (SCM str, SCM chr, SCM frm, SCM to) frm = SCM_BOOL_F; if (to == SCM_UNDEFINED) to = SCM_BOOL_F; - pos = scm_i_index (&str, chr, -1, frm, to, s_string_rindex); + pos = scm_i_index (&str, chr, -1, frm, to, FUNC_NAME); return (pos < 0 ? SCM_BOOL_F : SCM_MAKINUM (pos)); } +#undef FUNC_NAME + +SCM_REGISTER_PROC(s_substring_move_left_x, "substring-move-left!", 5, 0, 0, scm_substring_move_x); +SCM_REGISTER_PROC(s_substring_move_right_x, "substring-move-right!", 5, 0, 0, scm_substring_move_x); -SCM_PROC(s_substring_move_left_x, "substring-move-left!", 5, 0, 0, scm_substring_move_x); -SCM_PROC(s_substring_move_right_x, "substring-move-right!", 5, 0, 0, scm_substring_move_x); -SCM_PROC(s_substring_move_x, "substring-move!", 5, 0, 0, scm_substring_move_x); -SCM -scm_substring_move_x (SCM str1, SCM start1, SCM end1, - SCM str2, SCM start2) - +GUILE_PROC(scm_substring_move_x, "substring-move!", 5, 0, 0, + (SCM str1, SCM start1, SCM end1, SCM str2, SCM start2), + "") +#define FUNC_NAME s_scm_substring_move_x { long s1, s2, e, len; - SCM_ASSERT (SCM_NIMP (str1) && SCM_STRINGP (str1), str1, - SCM_ARG1, s_substring_move_x); - SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_substring_move_x); - SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_substring_move_x); - SCM_ASSERT (SCM_NIMP (str2) && SCM_STRINGP (str2), str2, - SCM_ARG4, s_substring_move_x); - SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_substring_move_x); - - s1 = SCM_INUM (start1), s2 = SCM_INUM (start2), e = SCM_INUM (end1); + SCM_VALIDATE_STRING(1,str1); + SCM_VALIDATE_INT_COPY(2,start1,s1); + SCM_VALIDATE_INT_COPY(3,end1,e); + SCM_VALIDATE_STRING(4,str2); + SCM_VALIDATE_INT_COPY(5,start2,s2); len = e - s1; - SCM_ASSERT (len >= 0, end1, SCM_OUTOFRANGE, s_substring_move_x); - SCM_ASSERT (s1 <= SCM_LENGTH (str1) && s1 >= 0, start1, - SCM_OUTOFRANGE, s_substring_move_x); - SCM_ASSERT (s2 <= SCM_LENGTH (str2) && s2 >= 0, start2, - SCM_OUTOFRANGE, s_substring_move_x); - SCM_ASSERT (e <= SCM_LENGTH (str1) && e >= 0, end1, - SCM_OUTOFRANGE, s_substring_move_x); - SCM_ASSERT (len+s2 <= SCM_LENGTH (str2), start2, - SCM_OUTOFRANGE, s_substring_move_x); + SCM_ASSERT_RANGE (3,end1,len >= 0); + SCM_ASSERT_RANGE (2,start1,s1 <= SCM_LENGTH (str1) && s1 >= 0); + SCM_ASSERT_RANGE (5,start2,s2 <= SCM_LENGTH (str2) && s2 >= 0); + SCM_ASSERT_RANGE (3,end1,e <= SCM_LENGTH (str1) && e >= 0); + SCM_ASSERT_RANGE (5,start2,len+s2 <= SCM_LENGTH (str2)); SCM_SYSCALL(memmove((void *)(&(SCM_CHARS(str2)[s2])), (void *)(&(SCM_CHARS(str1)[s1])), @@ -154,94 +152,85 @@ scm_substring_move_x (SCM str1, SCM start1, SCM end1, return scm_return_first(SCM_UNSPECIFIED, str1, str2); } +#undef FUNC_NAME -SCM_PROC(s_substring_fill_x, "substring-fill!", 4, 0, 0, scm_substring_fill_x); - -SCM -scm_substring_fill_x (SCM str, SCM start, SCM end, SCM fill) - +GUILE_PROC(scm_substring_fill_x, "substring-fill!", 4, 0, 0, + (SCM str, SCM start, SCM end, SCM fill), + "") +#define FUNC_NAME s_scm_substring_fill_x { long i, e; char c; - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_substring_fill_x); - SCM_ASSERT (SCM_INUMP (start), start, SCM_ARG2, s_substring_fill_x); - SCM_ASSERT (SCM_INUMP (end), end, SCM_ARG3, s_substring_fill_x); - SCM_ASSERT (SCM_ICHRP (fill), fill, SCM_ARG4, s_substring_fill_x); - i = SCM_INUM (start), e = SCM_INUM (end);c = SCM_ICHR (fill); - SCM_ASSERT (i <= SCM_LENGTH (str) && i >= 0, start, - SCM_OUTOFRANGE, s_substring_fill_x); - SCM_ASSERT (e <= SCM_LENGTH (str) && e >= 0, end, - SCM_OUTOFRANGE, s_substring_fill_x); + SCM_VALIDATE_STRING(1,str); + SCM_VALIDATE_INT_COPY(2,start,i); + SCM_VALIDATE_INT_COPY(3,end,e); + SCM_VALIDATE_CHAR_COPY(4,fill,c); + SCM_ASSERT_RANGE (2,start,i <= SCM_LENGTH (str) && i >= 0); + SCM_ASSERT_RANGE (3,end,e <= SCM_LENGTH (str) && e >= 0); while (ilist", 1, 0, 0, scm_string_to_list); - -SCM -scm_string_to_list (str) - SCM str; +GUILE_PROC(scm_string_to_list, "string->list", 1, 0, 0, + (SCM str), +"") +#define FUNC_NAME s_scm_string_to_list { long i; SCM res = SCM_EOL; unsigned char *src; - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_to_list); + SCM_VALIDATE_ROSTRING(1,str); src = SCM_ROUCHARS (str); for (i = SCM_ROLENGTH (str)-1;i >= 0;i--) res = scm_cons ((SCM)SCM_MAKICHR (src[i]), res); return res; } +#undef FUNC_NAME -SCM_PROC(s_string_copy, "string-copy", 1, 0, 0, scm_string_copy); - -SCM -scm_string_copy (str) - SCM str; +GUILE_PROC(scm_string_copy, "string-copy", 1, 0, 0, + (SCM str), +"") +#define FUNC_NAME s_scm_string_copy { - SCM_ASSERT (SCM_NIMP (str) && (SCM_STRINGP (str) || SCM_SUBSTRP (str)), - str, SCM_ARG1, s_string_copy); + SCM_VALIDATE_STRINGORSUBSTR(1,str); return scm_makfromstr (SCM_ROCHARS (str), (scm_sizet)SCM_ROLENGTH (str), 0); } +#undef FUNC_NAME -SCM_PROC(s_string_fill_x, "string-fill!", 2, 0, 0, scm_string_fill_x); - -SCM -scm_string_fill_x (str, chr) - SCM str; - SCM chr; +GUILE_PROC(scm_string_fill_x, "string-fill!", 2, 0, 0, + (SCM str, SCM chr), +"") +#define FUNC_NAME s_scm_string_fill_x { register char *dst, c; register long k; - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_string_fill_x); - SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG2, s_string_fill_x); - c = SCM_ICHR (chr); - dst = SCM_CHARS (str); + SCM_VALIDATE_STRING_COPY(1,str,dst); + SCM_VALIDATE_CHAR_COPY(2,chr,c); for (k = SCM_LENGTH (str)-1;k >= 0;k--) dst[k] = c; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_string_upcase_x, "string-upcase!", 1, 0, 0, scm_string_upcase_x); - -SCM -scm_string_upcase_x (v) - SCM v; +GUILE_PROC(scm_string_upcase_x, "string-upcase!", 1, 0, 0, + (SCM v), +"") +#define FUNC_NAME s_scm_string_upcase_x { register long k; register unsigned char *cs; @@ -256,24 +245,25 @@ scm_string_upcase_x (v) cs[k] = scm_upcase(cs[k]); break; default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_upcase_x); + badarg1:SCM_WTA (1,v); } return v; } +#undef FUNC_NAME -SCM_PROC(s_string_upcase, "string-upcase", 1, 0, 0, scm_string_upcase); - -SCM -scm_string_upcase(SCM str) +GUILE_PROC(scm_string_upcase, "string-upcase", 1, 0, 0, + (SCM str), +"") +#define FUNC_NAME s_scm_string_upcase { return scm_string_upcase_x(scm_string_copy(str)); } +#undef FUNC_NAME -SCM_PROC(s_string_downcase_x, "string-downcase!", 1, 0, 0, scm_string_downcase_x); - -SCM -scm_string_downcase_x (v) - SCM v; +GUILE_PROC(scm_string_downcase_x, "string-downcase!", 1, 0, 0, + (SCM v), +"") +#define FUNC_NAME s_scm_string_downcase_x { register long k; register unsigned char *cs; @@ -287,28 +277,30 @@ scm_string_downcase_x (v) cs[k] = scm_downcase(cs[k]); break; default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_downcase_x); + badarg1:SCM_WTA (1,v); } return v; } +#undef FUNC_NAME -SCM_PROC(s_string_downcase, "string-downcase", 1, 0, 0, scm_string_downcase); - -SCM -scm_string_downcase(SCM str) +GUILE_PROC(scm_string_downcase, "string-downcase", 1, 0, 0, + (SCM str), +"") +#define FUNC_NAME s_scm_string_downcase { - SCM_ASSERT(SCM_NIMP(str) && SCM_STRINGP(str), str, SCM_ARG1, s_string_downcase); + SCM_VALIDATE_STRING(1,str); return scm_string_downcase_x(scm_string_copy(str)); } +#undef FUNC_NAME -SCM_PROC(s_string_capitalize_x, "string-capitalize!", 1, 0, 0, scm_string_capitalize_x); - -SCM -scm_string_capitalize_x (SCM s) +GUILE_PROC(scm_string_capitalize_x, "string-capitalize!", 1, 0, 0, + (SCM s), +"") +#define FUNC_NAME s_scm_string_capitalize_x { char *str; int i, len, in_word=0; - SCM_ASSERT(SCM_NIMP(s) && SCM_STRINGP(s), s, SCM_ARG1, s_string_capitalize_x); + SCM_VALIDATE_STRING(1,s); len = SCM_LENGTH(s); str = SCM_CHARS(s); for(i=0; isymbol", 1, 0, 0, scm_string_ci_to_symbol); - -SCM -scm_string_ci_to_symbol(SCM str) +GUILE_PROC(scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0, + (SCM str), +"") +#define FUNC_NAME s_scm_string_ci_to_symbol { return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P ? scm_string_downcase(str) : str); } +#undef FUNC_NAME void scm_init_strop () { #include "strop.x" } - diff --git a/libguile/strports.c b/libguile/strports.c index 9d52b11bd..13b7ef8c6 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include "_scm.h" @@ -247,11 +251,7 @@ st_truncate (SCM port, off_t length) } SCM -scm_mkstrport (pos, str, modes, caller) - SCM pos; - SCM str; - long modes; - const char * caller; +scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) { SCM z; scm_port *pt; @@ -295,22 +295,22 @@ SCM scm_strport_to_string (SCM port) return scm_makfromstr (pt->read_buf, pt->read_buf_size, 0); } -SCM_PROC(s_call_with_output_string, "call-with-output-string", 1, 0, 0, scm_call_with_output_string); - -SCM -scm_call_with_output_string (proc) - SCM proc; +GUILE_PROC(scm_call_with_output_string, "call-with-output-string", 1, 0, 0, + (SCM proc), +"") +#define FUNC_NAME s_scm_call_with_output_string { SCM p; p = scm_mkstrport (SCM_INUM0, scm_make_string (SCM_INUM0, SCM_UNDEFINED), SCM_OPN | SCM_WRTNG, - s_call_with_output_string); + FUNC_NAME); scm_apply (proc, p, scm_listofnull); return scm_strport_to_string (p); } +#undef FUNC_NAME @@ -319,8 +319,7 @@ scm_call_with_output_string (proc) SCM -scm_strprint_obj (obj) - SCM obj; +scm_strprint_obj (SCM obj) { SCM str; SCM port; @@ -336,24 +335,22 @@ scm_strprint_obj (obj) -SCM_PROC(s_call_with_input_string, "call-with-input-string", 2, 0, 0, scm_call_with_input_string); - -SCM -scm_call_with_input_string (str, proc) - SCM str; - SCM proc; +GUILE_PROC(scm_call_with_input_string, "call-with-input-string", 2, 0, 0, + (SCM str, SCM proc), +"") +#define FUNC_NAME s_scm_call_with_input_string { - SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, s_call_with_input_string); + SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, FUNC_NAME); return scm_apply (proc, p, scm_listofnull); } +#undef FUNC_NAME /* Given a null-terminated string EXPR containing a Scheme expression read it, and return it as an SCM value. */ SCM -scm_read_0str (expr) - char *expr; +scm_read_0str (char *expr) { SCM port = scm_mkstrport (SCM_INUM0, scm_makfrom0str (expr), @@ -377,11 +374,10 @@ scm_eval_0str (const char *expr) } -SCM_PROC (s_eval_string, "eval-string", 1, 0, 0, scm_eval_string); - -SCM -scm_eval_string (string) - SCM string; +GUILE_PROC (scm_eval_string, "eval-string", 1, 0, 0, + (SCM string), +"") +#define FUNC_NAME s_scm_eval_string { SCM port = scm_mkstrport (SCM_INUM0, string, SCM_OPN | SCM_RDNG, "scm_eval_0str"); @@ -399,6 +395,7 @@ scm_eval_string (string) return ans; } +#undef FUNC_NAME void scm_make_stptob (void); /* Called from ports.c */ diff --git a/libguile/struct.c b/libguile/struct.c index b9136449a..289c83ec1 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -49,6 +53,7 @@ #include "weaks.h" #include "hashtab.h" +#include "scm_validate.h" #include "struct.h" #ifdef HAVE_STRING_H @@ -61,24 +66,21 @@ static SCM required_vtable_fields = SCM_BOOL_F; SCM scm_struct_table; -SCM_PROC (s_struct_make_layout, "make-struct-layout", 1, 0, 0, scm_make_struct_layout); - -SCM -scm_make_struct_layout (fields) - SCM fields; +GUILE_PROC (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, + (SCM fields), +"") +#define FUNC_NAME s_scm_make_struct_layout { SCM new_sym; - SCM_ASSERT (SCM_NIMP (fields) && SCM_ROSTRINGP (fields), - fields, SCM_ARG1, s_struct_make_layout); - - { + SCM_VALIDATE_ROSTRING(1,fields); + { /* scope */ char * field_desc; int len; int x; len = SCM_ROLENGTH (fields); field_desc = SCM_ROCHARS (fields); - SCM_ASSERT (!(len & 1), fields, "odd length field specification", s_struct_make_layout); + SCM_ASSERT (!(len & 1), fields, "odd length field specification", FUNC_NAME); for (x = 0; x < len; x += 2) { @@ -93,14 +95,14 @@ scm_make_struct_layout (fields) case 's': break; default: - SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized field type", s_struct_make_layout); + SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized field type", FUNC_NAME); } switch (field_desc[x + 1]) { case 'w': SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]), - "self fields not writable", s_struct_make_layout); + "self fields not writable", FUNC_NAME); case 'r': case 'o': @@ -110,18 +112,18 @@ scm_make_struct_layout (fields) case 'O': SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]), "self fields not allowed in tail array", - s_struct_make_layout); + FUNC_NAME); SCM_ASSERT (x == len - 2, SCM_MAKICHR (field_desc[x + 1]), "tail array field must be last field in layout", - s_struct_make_layout); + FUNC_NAME); break; default: - SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", s_struct_make_layout); + SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", FUNC_NAME); } #if 0 if (field_desc[x] == 'd') { - SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", s_struct_make_layout); + SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", FUNC_NAME); x += 2; goto recheck_ref; } @@ -131,16 +133,14 @@ scm_make_struct_layout (fields) } return scm_return_first (new_sym, fields); } +#undef FUNC_NAME void -scm_struct_init (handle, tail_elts, inits) - SCM handle; - int tail_elts; - SCM inits; +scm_struct_init (SCM handle, int tail_elts, SCM inits) { SCM layout; SCM * data; @@ -231,22 +231,19 @@ scm_struct_init (handle, tail_elts, inits) } -SCM_PROC (s_struct_p, "struct?", 1, 0, 0, scm_struct_p); - -SCM -scm_struct_p (x) - SCM x; +GUILE_PROC (scm_struct_p, "struct?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_struct_p { - return ((SCM_NIMP (x) && SCM_STRUCTP (x)) - ? SCM_BOOL_T - : SCM_BOOL_F); + return SCM_BOOL(SCM_NIMP (x) && SCM_STRUCTP (x)); } +#undef FUNC_NAME -SCM_PROC (s_struct_vtable_p, "struct-vtable?", 1, 0, 0, scm_struct_vtable_p); - -SCM -scm_struct_vtable_p (x) - SCM x; +GUILE_PROC (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_struct_vtable_p { SCM layout; SCM * mem; @@ -274,10 +271,9 @@ scm_struct_vtable_p (x) if (SCM_IMP (mem[0])) return SCM_BOOL_F; - return (SCM_SYMBOLP (mem[0]) - ? SCM_BOOL_T - : SCM_BOOL_F); + return SCM_BOOL(SCM_SYMBOLP (mem[0])); } +#undef FUNC_NAME /* All struct data must be allocated at an address whose bottom three @@ -362,13 +358,10 @@ scm_struct_free_entity (SCM *vtable, SCM *data) return n; } -SCM_PROC (s_make_struct, "make-struct", 2, 0, 1, scm_make_struct); - -SCM -scm_make_struct (vtable, tail_array_size, init) - SCM vtable; - SCM tail_array_size; - SCM init; +GUILE_PROC (scm_make_struct, "make-struct", 2, 0, 1, + (SCM vtable, SCM tail_array_size, SCM init), + "") +#define FUNC_NAME s_scm_make_struct { SCM layout; int basic_size; @@ -376,10 +369,8 @@ scm_make_struct (vtable, tail_array_size, init) SCM * data; SCM handle; - SCM_ASSERT ((SCM_BOOL_F != scm_struct_vtable_p (vtable)), - vtable, SCM_ARG1, s_make_struct); - SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2, - s_make_struct); + SCM_VALIDATE_VTABLE(1,vtable); + SCM_VALIDATE_INT(2,tail_array_size); layout = SCM_STRUCT_DATA (vtable)[scm_vtable_index_layout]; basic_size = SCM_LENGTH (layout) / 2; @@ -404,16 +395,14 @@ scm_make_struct (vtable, tail_array_size, init) SCM_ALLOW_INTS; return handle; } +#undef FUNC_NAME -SCM_PROC (s_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, scm_make_vtable_vtable); - -SCM -scm_make_vtable_vtable (extra_fields, tail_array_size, init) - SCM extra_fields; - SCM tail_array_size; - SCM init; +GUILE_PROC (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, + (SCM extra_fields, SCM tail_array_size, SCM init), +"") +#define FUNC_NAME s_scm_make_vtable_vtable { SCM fields; SCM layout; @@ -422,10 +411,8 @@ scm_make_vtable_vtable (extra_fields, tail_array_size, init) SCM * data; SCM handle; - SCM_ASSERT (SCM_NIMP (extra_fields) && SCM_ROSTRINGP (extra_fields), - extra_fields, SCM_ARG1, s_make_vtable_vtable); - SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2, - s_make_vtable_vtable); + SCM_VALIDATE_ROSTRING(1,extra_fields); + SCM_VALIDATE_INT(2,tail_array_size); fields = scm_string_append (scm_listify (required_vtable_fields, extra_fields, @@ -445,16 +432,15 @@ scm_make_vtable_vtable (extra_fields, tail_array_size, init) SCM_ALLOW_INTS; return handle; } +#undef FUNC_NAME -SCM_PROC (s_struct_ref, "struct-ref", 2, 0, 0, scm_struct_ref); - -SCM -scm_struct_ref (handle, pos) - SCM handle; - SCM pos; +GUILE_PROC (scm_struct_ref, "struct-ref", 2, 0, 0, + (SCM handle, SCM pos), +"") +#define FUNC_NAME s_scm_struct_ref { SCM answer = SCM_UNDEFINED; SCM * data; @@ -465,9 +451,8 @@ scm_struct_ref (handle, pos) unsigned char field_type = 0; - SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle, - SCM_ARG1, s_struct_ref); - SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref); + SCM_VALIDATE_STRUCT(1,handle); + SCM_VALIDATE_INT(2,pos); layout = SCM_STRUCT_LAYOUT (handle); data = SCM_STRUCT_DATA (handle); @@ -476,7 +461,7 @@ scm_struct_ref (handle, pos) fields_desc = (unsigned char *) SCM_CHARS (layout); n_fields = data[scm_struct_i_n_words]; - SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_ref); + SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, FUNC_NAME); if (p * 2 < SCM_LENGTH (layout)) { @@ -488,14 +473,14 @@ scm_struct_ref (handle, pos) if ((ref == 'R') || (ref == 'W')) field_type = 'u'; else - SCM_ASSERT (0, pos, "ref denied", s_struct_ref); + SCM_ASSERT (0, pos, "ref denied", FUNC_NAME); } } else if (fields_desc[SCM_LENGTH (layout) - 1] != 'O') field_type = fields_desc[SCM_LENGTH (layout) - 2]; else { - SCM_ASSERT (0, pos, "ref denied", s_struct_ref); + SCM_ASSERT (0, pos, "ref denied", FUNC_NAME); abort (); } @@ -522,21 +507,19 @@ scm_struct_ref (handle, pos) default: - SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_ref); + SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", FUNC_NAME); break; } return answer; } +#undef FUNC_NAME -SCM_PROC (s_struct_set_x, "struct-set!", 3, 0, 0, scm_struct_set_x); - -SCM -scm_struct_set_x (handle, pos, val) - SCM handle; - SCM pos; - SCM val; +GUILE_PROC (scm_struct_set_x, "struct-set!", 3, 0, 0, + (SCM handle, SCM pos, SCM val), +"") +#define FUNC_NAME s_scm_struct_set_x { SCM * data; SCM layout; @@ -544,12 +527,9 @@ scm_struct_set_x (handle, pos, val) int n_fields; unsigned char * fields_desc; unsigned char field_type = 0; - - - SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle, - SCM_ARG1, s_struct_ref); - SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref); + SCM_VALIDATE_STRUCT(1,handle); + SCM_VALIDATE_INT(2,pos); layout = SCM_STRUCT_LAYOUT (handle); data = SCM_STRUCT_DATA (handle); @@ -558,7 +538,7 @@ scm_struct_set_x (handle, pos, val) fields_desc = (unsigned char *)SCM_CHARS (layout); n_fields = data[scm_struct_i_n_words]; - SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x); + SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, FUNC_NAME); if (p * 2 < SCM_LENGTH (layout)) { @@ -566,25 +546,25 @@ scm_struct_set_x (handle, pos, val) field_type = fields_desc[p * 2]; set_x = fields_desc [p * 2 + 1]; if (set_x != 'w') - SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x); + SCM_ASSERT (0, pos, "set_x denied", FUNC_NAME); } else if (fields_desc[SCM_LENGTH (layout) - 1] == 'W') field_type = fields_desc[SCM_LENGTH (layout) - 2]; else { - SCM_ASSERT (0, pos, "set_x denied", s_struct_ref); + SCM_ASSERT (0, pos, "set_x denied", FUNC_NAME); abort (); } switch (field_type) { case 'u': - data[p] = (SCM)scm_num2ulong (val, (char *)SCM_ARG3, s_struct_set_x); + data[p] = SCM_NUM2ULONG (3,val); break; #if 0 case 'i': - data[p] = scm_num2long (val, (char *)SCM_ARG3, s_struct_set_x); + data[p] = SCM_NUM2LONG (3,val); break; case 'd': @@ -597,40 +577,39 @@ scm_struct_set_x (handle, pos, val) break; case 's': - SCM_ASSERT (0, SCM_MAKICHR (field_type), "self fields immutable", s_struct_set_x); + SCM_ASSERT (0, SCM_MAKICHR (field_type), "self fields immutable", FUNC_NAME); break; default: - SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_set_x); + SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", FUNC_NAME); break; } return val; } +#undef FUNC_NAME -SCM_PROC (s_struct_vtable, "struct-vtable", 1, 0, 0, scm_struct_vtable); - -SCM -scm_struct_vtable (handle) - SCM handle; +GUILE_PROC (scm_struct_vtable, "struct-vtable", 1, 0, 0, + (SCM handle), +"") +#define FUNC_NAME s_scm_struct_vtable { - SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle, - SCM_ARG1, s_struct_vtable); + SCM_VALIDATE_STRUCT(1,handle); return SCM_STRUCT_VTABLE (handle); } +#undef FUNC_NAME -SCM_PROC (s_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, scm_struct_vtable_tag); - -SCM -scm_struct_vtable_tag (handle) - SCM handle; +GUILE_PROC (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, + (SCM handle), +"") +#define FUNC_NAME s_scm_struct_vtable_tag { - SCM_ASSERT (SCM_NFALSEP (scm_struct_vtable_p (handle)), - handle, SCM_ARG1, s_struct_vtable_tag); + SCM_VALIDATE_VTABLE(1,handle); return scm_long2num ((long) SCM_STRUCT_DATA (handle) >> 3); } +#undef FUNC_NAME /* {Associating names and classes with vtables} * @@ -661,39 +640,34 @@ scm_struct_create_handle (SCM obj) return handle; } -SCM_PROC (s_struct_vtable_name, "struct-vtable-name", 1, 0, 0, scm_struct_vtable_name); - -SCM -scm_struct_vtable_name (SCM vtable) +GUILE_PROC (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0, + (SCM vtable), + "") +#define FUNC_NAME s_scm_struct_vtable_name { - SCM_ASSERT (SCM_NFALSEP (scm_struct_vtable_p (vtable)), - vtable, SCM_ARG1, s_struct_vtable_name); - + SCM_VALIDATE_VTABLE(1,vtable); return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable))); } +#undef FUNC_NAME -SCM_PROC (s_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0, scm_set_struct_vtable_name_x); - -SCM -scm_set_struct_vtable_name_x (SCM vtable, SCM name) +GUILE_PROC (scm_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0, + (SCM vtable, SCM name), + "") +#define FUNC_NAME s_scm_set_struct_vtable_name_x { - SCM_ASSERT (SCM_NIMP (vtable) && SCM_NFALSEP (scm_struct_vtable_p (vtable)), - vtable, SCM_ARG1, s_set_struct_vtable_name_x); - SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name), - name, SCM_ARG2, s_set_struct_vtable_name_x); + SCM_VALIDATE_VTABLE(1,vtable); + SCM_VALIDATE_SYMBOL(2,name); SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)), name); return SCM_UNSPECIFIED; } +#undef FUNC_NAME void -scm_print_struct (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) { if (SCM_NFALSEP (scm_procedure_p (SCM_STRUCT_PRINTER (exp)))) scm_printer_apply (SCM_STRUCT_PRINTER (exp), exp, port, pstate); diff --git a/libguile/symbols.c b/libguile/symbols.c index 3ec6843a5..21e28ca89 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -48,6 +52,7 @@ #include "alist.h" #include "weaks.h" +#include "scm_validate.h" #include "symbols.h" #ifdef HAVE_STRING_H @@ -69,10 +74,7 @@ unsigned long -scm_strhash (str, len, n) - unsigned char *str; - scm_sizet len; - unsigned long n; +scm_strhash (unsigned char *str,scm_sizet len,unsigned long n) { if (len > 5) { @@ -100,10 +102,7 @@ int scm_symhash_dim = NUM_HASH_BUCKETS; */ SCM -scm_sym2vcell (sym, thunk, definep) - SCM sym; - SCM thunk; - SCM definep; +scm_sym2vcell (SCM sym,SCM thunk,SCM definep) { if (SCM_NIMP(thunk)) { @@ -165,9 +164,7 @@ scm_sym2vcell (sym, thunk, definep) */ SCM -scm_sym2ovcell_soft (sym, obarray) - SCM sym; - SCM obarray; +scm_sym2ovcell_soft (SCM sym, SCM obarray) { SCM lsym, z; scm_sizet scm_hash; @@ -193,9 +190,7 @@ scm_sym2ovcell_soft (sym, obarray) SCM -scm_sym2ovcell (sym, obarray) - SCM sym; - SCM obarray; +scm_sym2ovcell (SCM sym, SCM obarray) { SCM answer; answer = scm_sym2ovcell_soft (sym, obarray); @@ -229,11 +224,7 @@ scm_sym2ovcell (sym, obarray) SCM -scm_intern_obarray_soft (name, len, obarray, softness) - const char *name; - scm_sizet len; - SCM obarray; - int softness; +scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,int softness) { SCM lsym; SCM z; @@ -329,27 +320,21 @@ scm_intern_obarray_soft (name, len, obarray, softness) SCM -scm_intern_obarray (name, len, obarray) - const char *name; - scm_sizet len; - SCM obarray; +scm_intern_obarray (const char *name,scm_sizet len,SCM obarray) { return scm_intern_obarray_soft (name, len, obarray, 0); } SCM -scm_intern (name, len) - const char *name; - scm_sizet len; +scm_intern (const char *name,scm_sizet len) { return scm_intern_obarray (name, len, scm_symhash); } SCM -scm_intern0 (name) - const char * name; +scm_intern0 (const char * name) { return scm_intern (name, strlen (name)); } @@ -357,8 +342,7 @@ scm_intern0 (name) /* Intern the symbol named NAME in scm_symhash, NAME is null-terminated. */ SCM -scm_sysintern0_no_module_lookup (name) - const char *name; +scm_sysintern0_no_module_lookup (const char *name) { SCM easy_answer; SCM_DEFER_INTS; @@ -394,9 +378,7 @@ int scm_can_use_top_level_lookup_closure_var; closure to give NAME its value. */ SCM -scm_sysintern (name, val) - const char *name; - SCM val; +scm_sysintern (const char *name, SCM val) { SCM vcell = scm_sysintern0 (name); SCM_SETCDR (vcell, val); @@ -404,8 +386,7 @@ scm_sysintern (name, val) } SCM -scm_sysintern0 (name) - const char *name; +scm_sysintern0 (const char *name) { SCM lookup_proc; if (scm_can_use_top_level_lookup_closure_var && @@ -424,8 +405,7 @@ scm_sysintern0 (name) /* Lookup the value of the symbol named by the nul-terminated string NAME in the current module. */ SCM -scm_symbol_value0 (name) - const char *name; +scm_symbol_value0 (const char *name) { /* This looks silly - we look up the symbol twice. But it is in fact necessary given the current module system because the module @@ -439,63 +419,57 @@ scm_symbol_value0 (name) return SCM_CDR (vcell); } -SCM_PROC(s_symbol_p, "symbol?", 1, 0, 0, scm_symbol_p); - -SCM -scm_symbol_p(x) - SCM x; +GUILE_PROC(scm_symbol_p, "symbol?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_symbol_p { if SCM_IMP(x) return SCM_BOOL_F; - return SCM_SYMBOLP(x) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(SCM_SYMBOLP(x)); } +#undef FUNC_NAME -SCM_PROC(s_symbol_to_string, "symbol->string", 1, 0, 0, scm_symbol_to_string); - -SCM -scm_symbol_to_string(s) - SCM s; +GUILE_PROC(scm_symbol_to_string, "symbol->string", 1, 0, 0, + (SCM s), +"") +#define FUNC_NAME s_scm_symbol_to_string { - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_to_string); + SCM_VALIDATE_SYMBOL(1,s); return scm_makfromstr(SCM_CHARS(s), (scm_sizet)SCM_LENGTH(s), 0); } +#undef FUNC_NAME -SCM_PROC(s_string_to_symbol, "string->symbol", 1, 0, 0, scm_string_to_symbol); - -SCM -scm_string_to_symbol(s) - SCM s; +GUILE_PROC(scm_string_to_symbol, "string->symbol", 1, 0, 0, + (SCM s), +"") +#define FUNC_NAME s_scm_string_to_symbol { SCM vcell; SCM answer; - SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG1, s_string_to_symbol); + SCM_VALIDATE_ROSTRING(1,s); vcell = scm_intern(SCM_ROCHARS(s), (scm_sizet)SCM_LENGTH(s)); answer = SCM_CAR (vcell); return answer; } +#undef FUNC_NAME -SCM_PROC(s_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, scm_string_to_obarray_symbol); - -SCM -scm_string_to_obarray_symbol(o, s, softp) - SCM o; - SCM s; - SCM softp; +GUILE_PROC(scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, + (SCM o, SCM s, SCM softp), +"") +#define FUNC_NAME s_scm_string_to_obarray_symbol { SCM vcell; SCM answer; int softness; - SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG2, - s_string_to_obarray_symbol); + SCM_VALIDATE_ROSTRING(2,s); SCM_ASSERT((o == SCM_BOOL_F) || (o == SCM_BOOL_T) || (SCM_NIMP(o) && SCM_VECTORP(o)), - o, - SCM_ARG1, - s_string_to_obarray_symbol); + o, SCM_ARG1, FUNC_NAME); softness = ((softp != SCM_UNDEFINED) && (softp != SCM_BOOL_F)); /* iron out some screwy calling conventions */ @@ -513,19 +487,18 @@ scm_string_to_obarray_symbol(o, s, softp) answer = SCM_CAR (vcell); return answer; } +#undef FUNC_NAME -SCM_PROC(s_intern_symbol, "intern-symbol", 2, 0, 0, scm_intern_symbol); - -SCM -scm_intern_symbol(o, s) - SCM o; - SCM s; +GUILE_PROC(scm_intern_symbol, "intern-symbol", 2, 0, 0, + (SCM o, SCM s), +"") +#define FUNC_NAME s_scm_intern_symbol { scm_sizet hval; - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_intern_symbol); + SCM_VALIDATE_SYMBOL(2,s); if (o == SCM_BOOL_F) o = scm_symhash; - SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_intern_symbol); + SCM_VALIDATE_VECTOR(1,o); hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o)); /* If the symbol is already interned, simply return. */ SCM_REDEFER_INTS; @@ -549,19 +522,18 @@ scm_intern_symbol(o, s) SCM_REALLOW_INTS; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_unintern_symbol, "unintern-symbol", 2, 0, 0, scm_unintern_symbol); - -SCM -scm_unintern_symbol(o, s) - SCM o; - SCM s; +GUILE_PROC(scm_unintern_symbol, "unintern-symbol", 2, 0, 0, + (SCM o, SCM s), +"") +#define FUNC_NAME s_scm_unintern_symbol { scm_sizet hval; - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_unintern_symbol); + SCM_VALIDATE_SYMBOL(2,s); if (o == SCM_BOOL_F) o = scm_symhash; - SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_unintern_symbol); + SCM_VALIDATE_VECTOR(1,o); hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o)); SCM_DEFER_INTS; { @@ -588,36 +560,34 @@ scm_unintern_symbol(o, s) SCM_ALLOW_INTS; return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC(s_symbol_binding, "symbol-binding", 2, 0, 0, scm_symbol_binding); - -SCM -scm_symbol_binding (o, s) - SCM o; - SCM s; +GUILE_PROC(scm_symbol_binding, "symbol-binding", 2, 0, 0, + (SCM o, SCM s), +"") +#define FUNC_NAME s_scm_symbol_binding { SCM vcell; - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_binding); + SCM_VALIDATE_SYMBOL(2,s); if (o == SCM_BOOL_F) o = scm_symhash; - SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_binding); + SCM_VALIDATE_VECTOR(1,o); vcell = scm_sym2ovcell (s, o); return SCM_CDR(vcell); } +#undef FUNC_NAME -SCM_PROC(s_symbol_interned_p, "symbol-interned?", 2, 0, 0, scm_symbol_interned_p); - -SCM -scm_symbol_interned_p (o, s) - SCM o; - SCM s; +GUILE_PROC(scm_symbol_interned_p, "symbol-interned?", 2, 0, 0, + (SCM o, SCM s), +"") +#define FUNC_NAME s_scm_symbol_interned_p { SCM vcell; - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_interned_p); + SCM_VALIDATE_SYMBOL(2,s); if (o == SCM_BOOL_F) o = scm_symhash; - SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_interned_p); + SCM_VALIDATE_VECTOR(1,o); vcell = scm_sym2ovcell_soft (s, o); if (SCM_IMP(vcell) && (o == scm_symhash)) vcell = scm_sym2ovcell_soft (s, scm_weak_symhash); @@ -625,49 +595,46 @@ scm_symbol_interned_p (o, s) ? SCM_BOOL_T : SCM_BOOL_F); } +#undef FUNC_NAME -SCM_PROC(s_symbol_bound_p, "symbol-bound?", 2, 0, 0, scm_symbol_bound_p); - -SCM -scm_symbol_bound_p (o, s) - SCM o; - SCM s; +GUILE_PROC(scm_symbol_bound_p, "symbol-bound?", 2, 0, 0, + (SCM o, SCM s), +"") +#define FUNC_NAME s_scm_symbol_bound_p { SCM vcell; - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_bound_p); + SCM_VALIDATE_SYMBOL(2,s); if (o == SCM_BOOL_F) o = scm_symhash; - SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_bound_p); + SCM_VALIDATE_VECTOR(1,o); vcell = scm_sym2ovcell_soft (s, o); return (( SCM_NIMP(vcell) && (SCM_CDR(vcell) != SCM_UNDEFINED)) ? SCM_BOOL_T : SCM_BOOL_F); } +#undef FUNC_NAME -SCM_PROC(s_symbol_set_x, "symbol-set!", 3, 0, 0, scm_symbol_set_x); - -SCM -scm_symbol_set_x (o, s, v) - SCM o; - SCM s; - SCM v; +GUILE_PROC(scm_symbol_set_x, "symbol-set!", 3, 0, 0, + (SCM o, SCM s, SCM v), +"") +#define FUNC_NAME s_scm_symbol_set_x { SCM vcell; - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_set_x); + SCM_VALIDATE_SYMBOL(2,s); if (o == SCM_BOOL_F) o = scm_symhash; - SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_set_x); + SCM_VALIDATE_VECTOR(1,o); vcell = scm_sym2ovcell (s, o); SCM_SETCDR (vcell, v); return SCM_UNSPECIFIED; } +#undef FUNC_NAME static void -msymbolize (s) - SCM s; +msymbolize (SCM s) { SCM string; string = scm_makfromstr (SCM_CHARS (s), SCM_LENGTH (s), SCM_SYMBOL_SLOTS); @@ -683,44 +650,42 @@ msymbolize (s) } -SCM_PROC(s_symbol_fref, "symbol-fref", 1, 0, 0, scm_symbol_fref); - -SCM -scm_symbol_fref (s) - SCM s; +GUILE_PROC(scm_symbol_fref, "symbol-fref", 1, 0, 0, + (SCM s), +"") +#define FUNC_NAME s_scm_symbol_fref { - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_fref); + SCM_VALIDATE_SYMBOL(1,s); SCM_DEFER_INTS; if (SCM_TYP7(s) == scm_tc7_ssymbol) msymbolize (s); SCM_ALLOW_INTS; return SCM_SYMBOL_FUNC (s); } +#undef FUNC_NAME -SCM_PROC(s_symbol_pref, "symbol-pref", 1, 0, 0, scm_symbol_pref); - -SCM -scm_symbol_pref (s) - SCM s; +GUILE_PROC(scm_symbol_pref, "symbol-pref", 1, 0, 0, + (SCM s), +"") +#define FUNC_NAME s_scm_symbol_pref { - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_pref); + SCM_VALIDATE_SYMBOL(1,s); SCM_DEFER_INTS; if (SCM_TYP7(s) == scm_tc7_ssymbol) msymbolize (s); SCM_ALLOW_INTS; return SCM_SYMBOL_PROPS (s); } +#undef FUNC_NAME -SCM_PROC(s_symbol_fset_x, "symbol-fset!", 2, 0, 0, scm_symbol_fset_x); - -SCM -scm_symbol_fset_x (s, val) - SCM s; - SCM val; +GUILE_PROC(scm_symbol_fset_x, "symbol-fset!", 2, 0, 0, + (SCM s, SCM val), + "") +#define FUNC_NAME s_scm_symbol_fset_x { - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_fset_x); + SCM_VALIDATE_SYMBOL(1,s); SCM_DEFER_INTS; if (SCM_TYP7(s) == scm_tc7_ssymbol) msymbolize (s); @@ -728,16 +693,15 @@ scm_symbol_fset_x (s, val) SCM_SYMBOL_FUNC (s) = val; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_symbol_pset_x, "symbol-pset!", 2, 0, 0, scm_symbol_pset_x); - -SCM -scm_symbol_pset_x (s, val) - SCM s; - SCM val; +GUILE_PROC(scm_symbol_pset_x, "symbol-pset!", 2, 0, 0, + (SCM s, SCM val), +"") +#define FUNC_NAME s_scm_symbol_pset_x { - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_pset_x); + SCM_VALIDATE_SYMBOL(1,s); SCM_DEFER_INTS; if (SCM_TYP7(s) == scm_tc7_ssymbol) msymbolize (s); @@ -745,27 +709,24 @@ scm_symbol_pset_x (s, val) SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_symbol_hash, "symbol-hash", 1, 0, 0, scm_symbol_hash); - -SCM -scm_symbol_hash (s) - SCM s; +GUILE_PROC(scm_symbol_hash, "symbol-hash", 1, 0, 0, + (SCM s), +"") +#define FUNC_NAME s_scm_symbol_hash { - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_hash); + SCM_VALIDATE_SYMBOL(1,s); if (SCM_TYP7(s) == scm_tc7_ssymbol) msymbolize (s); return SCM_MAKINUM ((unsigned long)s ^ SCM_SYMBOL_HASH (s)); } +#undef FUNC_NAME -static void copy_and_prune_obarray SCM_P ((SCM from, SCM to)); - static void -copy_and_prune_obarray (from, to) - SCM from; - SCM to; +copy_and_prune_obarray (SCM from, SCM to) { int i; int length = SCM_LENGTH (from); @@ -789,46 +750,46 @@ copy_and_prune_obarray (from, to) } -SCM_PROC(s_builtin_bindings, "builtin-bindings", 0, 0, 0, scm_builtin_bindings); - -SCM -scm_builtin_bindings () +GUILE_PROC(scm_builtin_bindings, "builtin-bindings", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_builtin_bindings { int length = SCM_LENGTH (scm_symhash); SCM obarray = scm_make_vector (SCM_MAKINUM (length), SCM_EOL); copy_and_prune_obarray (scm_symhash, obarray); return obarray; } +#undef FUNC_NAME -SCM_PROC(s_builtin_weak_bindings, "builtin-weak-bindings", 0, 0, 0, scm_builtin_weak_bindings); - -SCM -scm_builtin_weak_bindings () +GUILE_PROC(scm_builtin_weak_bindings, "builtin-weak-bindings", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_builtin_weak_bindings { int length = SCM_LENGTH (scm_weak_symhash); SCM obarray = scm_make_doubly_weak_hash_table (SCM_MAKINUM (length)); copy_and_prune_obarray (scm_weak_symhash, obarray); return obarray; } +#undef FUNC_NAME static int gensym_counter; static SCM gensym_prefix; -/*fixme* Optimize */ -SCM_PROC (s_gensym, "gensym", 0, 2, 0, scm_gensym); - -SCM -scm_gensym (name, obarray) - SCM name; - SCM obarray; +/* :FIXME:OPTIMIZE */ +GUILE_PROC (scm_gensym, "gensym", 0, 2, 0, + (SCM name, SCM obarray), +"") +#define FUNC_NAME s_scm_gensym { SCM new; if (SCM_UNBNDP (name)) name = gensym_prefix; else - SCM_ASSERT (SCM_NIMP (name) && SCM_ROSTRINGP (name), - name, SCM_ARG1, s_gensym); + SCM_VALIDATE_ROSTRING(1,name); + new = name; if (SCM_UNBNDP (obarray)) { @@ -840,7 +801,7 @@ scm_gensym (name, obarray) && (SCM_VECTORP (obarray) || SCM_WVECTP (obarray)), obarray, SCM_ARG2, - s_gensym); + FUNC_NAME); while (scm_string_to_obarray_symbol (obarray, new, SCM_BOOL_T) != SCM_BOOL_F) skip_test: @@ -851,6 +812,7 @@ scm_gensym (name, obarray) SCM_EOL)); return scm_string_to_obarray_symbol (obarray, new, SCM_BOOL_F); } +#undef FUNC_NAME void scm_init_symbols () diff --git a/libguile/tag.c b/libguile/tag.c index d9ba82d91..7d0e231a0 100644 --- a/libguile/tag.c +++ b/libguile/tag.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include #include "_scm.h" @@ -85,11 +89,10 @@ SCM_CONST_LONG (scm_utag_flag_base, "utag_flag_base", 254); SCM_CONST_LONG (scm_utag_struct_base, "utag_struct_base", 255); -SCM_PROC (s_tag, "tag", 1, 0, 0, scm_tag); - -SCM -scm_tag (x) - SCM x; +GUILE_PROC (scm_tag, "tag", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_tag { switch (SCM_ITAG3 (x)) { @@ -204,6 +207,7 @@ scm_tag (x) } return SCM_MAKINUM (-1); } +#undef FUNC_NAME diff --git a/libguile/tags.h b/libguile/tags.h index 306157888..65fdc4c9a 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -42,6 +42,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + /** This file defines the format of SCM values and cons pairs. @@ -411,6 +415,12 @@ typedef long SCM; #define scm_tc16_bigpos 0x027f #define scm_tc16_bigneg 0x037f +/* Smob type 4: this is allocated, but not initialized cells; + this is required to prevent the gc from hosing your cells if + you have to allocate while creating the cell*/ + +#define scm_tc16_allocated 0x047f + /* {Immediate Values} diff --git a/libguile/threads.c b/libguile/threads.c index c6347546c..d22081765 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + /* This file does some pretty hairy #inclusion. It probably seemed @@ -79,17 +83,17 @@ long scm_tc16_condvar; /* Scheme-visible thread functions. */ #ifdef USE_COOP_THREADS -SCM_PROC(s_single_thread_p, "single-active-thread?", 0, 0, 0, scm_single_thread_p); +SCM_REGISTER_PROC(s_single_thread_p, "single-active-thread?", 0, 0, 0, scm_single_thread_p); #endif -SCM_PROC(s_yield, "yield", 0, 0, 0, scm_yield); -SCM_PROC(s_call_with_new_thread, "call-with-new-thread", 0, 0, 1, scm_call_with_new_thread); -SCM_PROC(s_join_thread, "join-thread", 1, 0, 0, scm_join_thread); -SCM_PROC(s_make_mutex, "make-mutex", 0, 0, 0, scm_make_mutex); -SCM_PROC(s_lock_mutex, "lock-mutex", 1, 0, 0, scm_lock_mutex); -SCM_PROC(s_unlock_mutex, "unlock-mutex", 1, 0, 0, scm_unlock_mutex); -SCM_PROC(s_make_condition_variable, "make-condition-variable", 0, 0, 0, scm_make_condition_variable); -SCM_PROC(s_wait_condition_variable, "wait-condition-variable", 2, 0, 0, scm_wait_condition_variable); -SCM_PROC(s_signal_condition_variable, "signal-condition-variable", 1, 0, 0, scm_signal_condition_variable); +SCM_REGISTER_PROC(s_yield, "yield", 0, 0, 0, scm_yield); +SCM_REGISTER_PROC(s_call_with_new_thread, "call-with-new-thread", 0, 0, 1, scm_call_with_new_thread); +SCM_REGISTER_PROC(s_join_thread, "join-thread", 1, 0, 0, scm_join_thread); +SCM_REGISTER_PROC(s_make_mutex, "make-mutex", 0, 0, 0, scm_make_mutex); +SCM_REGISTER_PROC(s_lock_mutex, "lock-mutex", 1, 0, 0, scm_lock_mutex); +SCM_REGISTER_PROC(s_unlock_mutex, "unlock-mutex", 1, 0, 0, scm_unlock_mutex); +SCM_REGISTER_PROC(s_make_condition_variable, "make-condition-variable", 0, 0, 0, scm_make_condition_variable); +SCM_REGISTER_PROC(s_wait_condition_variable, "wait-condition-variable", 2, 0, 0, scm_wait_condition_variable); +SCM_REGISTER_PROC(s_signal_condition_variable, "signal-condition-variable", 1, 0, 0, scm_signal_condition_variable); diff --git a/libguile/throw.c b/libguile/throw.c index 8d1b4e481..272450251 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -57,6 +61,7 @@ #include "stacks.h" #include "fluids.h" +#include "scm_validate.h" #include "throw.h" @@ -77,23 +82,16 @@ static int scm_tc16_jmpbuffer; #define SCM_SETJBDFRAME(O,X) SCM_SETCAR (SCM_CDR (O), (SCM)(X)) #define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X) -static scm_sizet freejb SCM_P ((SCM jbsmob)); - static scm_sizet -freejb (jbsmob) - SCM jbsmob; +freejb (SCM jbsmob) { scm_must_free ((char *) SCM_CDR (jbsmob)); return sizeof (scm_cell); } #endif -static int printjb SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); static int -printjb (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +printjb (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("# @@ -49,6 +53,7 @@ #include "strop.h" #include "feature.h" +#include "scm_validate.h" #include "unif.h" #include "ramap.h" @@ -147,9 +152,7 @@ scm_makflo (float x) SCM -scm_make_uve (k, prot) - long k; - SCM prot; +scm_make_uve (long k, SCM prot) { SCM v; long i, type; @@ -234,18 +237,17 @@ scm_make_uve (k, prot) return v; } -SCM_PROC(s_uniform_vector_length, "uniform-vector-length", 1, 0, 0, scm_uniform_vector_length); - -SCM -scm_uniform_vector_length (v) - SCM v; +GUILE_PROC(scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, + (SCM v), +"") +#define FUNC_NAME s_scm_uniform_vector_length { SCM_ASRTGO (SCM_NIMP (v), badarg1); switch SCM_TYP7 (v) { default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_length); + badarg1:SCM_WTA(1,v); case scm_tc7_bvect: case scm_tc7_string: case scm_tc7_byvect: @@ -263,13 +265,12 @@ scm_uniform_vector_length (v) return SCM_MAKINUM (SCM_LENGTH (v)); } } +#undef FUNC_NAME -SCM_PROC(s_array_p, "array?", 1, 1, 0, scm_array_p); - -SCM -scm_array_p (v, prot) - SCM v; - SCM prot; +GUILE_PROC(scm_array_p, "array?", 1, 1, 0, + (SCM v, SCM prot), +"") +#define FUNC_NAME s_scm_array_p { int nprot; int enclosed; @@ -290,15 +291,15 @@ loop: v = SCM_ARRAY_V (v); goto loop; case scm_tc7_bvect: - return nprot || SCM_BOOL_T==prot ? SCM_BOOL_T : SCM_BOOL_F; + return nprot || SCM_BOOL(SCM_BOOL_T==prot); case scm_tc7_string: - return nprot || (SCM_ICHRP(prot) && (prot != SCM_MAKICHR('\0'))) ? SCM_BOOL_T : SCM_BOOL_F; + return nprot || SCM_BOOL(SCM_ICHRP(prot) && (prot != SCM_MAKICHR('\0'))); case scm_tc7_byvect: - return nprot || (prot == SCM_MAKICHR('\0')) ? SCM_BOOL_T : SCM_BOOL_F; + return nprot || SCM_BOOL(prot == SCM_MAKICHR('\0')); case scm_tc7_uvect: - return nprot || (SCM_INUMP(prot) && SCM_INUM(prot)>0) ? SCM_BOOL_T : SCM_BOOL_F; + return nprot || SCM_BOOL(SCM_INUMP(prot) && SCM_INUM(prot)>0); case scm_tc7_ivect: - return nprot || (SCM_INUMP(prot) && SCM_INUM(prot)<=0) ? SCM_BOOL_T : SCM_BOOL_F; + return nprot || SCM_BOOL(SCM_INUMP(prot) && SCM_INUM(prot)<=0); case scm_tc7_svect: return ( nprot || (SCM_NIMP (prot) @@ -316,30 +317,30 @@ loop: # ifdef SCM_FLOATS # ifdef SCM_SINGLES case scm_tc7_fvect: - return nprot || (SCM_NIMP(prot) && SCM_SINGP(prot)) ? SCM_BOOL_T : SCM_BOOL_F; + return nprot || SCM_BOOL(SCM_NIMP(prot) && SCM_SINGP(prot)); # endif case scm_tc7_dvect: - return nprot || (SCM_NIMP(prot) && SCM_REALP(prot)) ? SCM_BOOL_T : SCM_BOOL_F; + return nprot || SCM_BOOL(SCM_NIMP(prot) && SCM_REALP(prot)); case scm_tc7_cvect: - return nprot || (SCM_NIMP(prot) && SCM_CPLXP(prot)) ? SCM_BOOL_T : SCM_BOOL_F; + return nprot || SCM_BOOL(SCM_NIMP(prot) && SCM_CPLXP(prot)); # endif case scm_tc7_vector: case scm_tc7_wvect: - return nprot || SCM_NULLP(prot) ? SCM_BOOL_T : SCM_BOOL_F; + return nprot || SCM_BOOL(SCM_NULLP(prot)); default:; } return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC(s_array_rank, "array-rank", 1, 0, 0, scm_array_rank); - -SCM -scm_array_rank (ra) - SCM ra; +GUILE_PROC(scm_array_rank, "array-rank", 1, 0, 0, + (SCM ra), +"") +#define FUNC_NAME s_scm_array_rank { if (SCM_IMP (ra)) - return SCM_INUM0; + return SCM_INUM0; switch (SCM_TYP7 (ra)) { default: @@ -364,19 +365,19 @@ scm_array_rank (ra) return SCM_INUM0; } } +#undef FUNC_NAME -SCM_PROC(s_array_dimensions, "array-dimensions", 1, 0, 0, scm_array_dimensions); - -SCM -scm_array_dimensions (ra) - SCM ra; +GUILE_PROC(scm_array_dimensions, "array-dimensions", 1, 0, 0, + (SCM ra), +"") +#define FUNC_NAME s_scm_array_dimensions { SCM res = SCM_EOL; scm_sizet k; scm_array_dim *s; if (SCM_IMP (ra)) - return SCM_BOOL_F; + return SCM_BOOL_F; switch (SCM_TYP7 (ra)) { default: @@ -408,16 +409,14 @@ scm_array_dimensions (ra) return res; } } +#undef FUNC_NAME static char s_bad_ind[] = "Bad scm_array index"; long -scm_aind (ra, args, what) - SCM ra; - SCM args; - const char *what; +scm_aind (SCM ra, SCM args, const char *what) { SCM ind; register long j; @@ -448,8 +447,7 @@ scm_aind (ra, args, what) SCM -scm_make_ra (ndim) - int ndim; +scm_make_ra (int ndim) { SCM ra; SCM_NEWCELL (ra); @@ -467,9 +465,7 @@ static char s_bad_spec[] = "Bad scm_array dimension"; SCM -scm_shap2ra (args, what) - SCM args; - const char *what; +scm_shap2ra (SCM args, const char *what) { scm_array_dim *s; SCM ra, spec, sp; @@ -506,13 +502,10 @@ scm_shap2ra (args, what) return ra; } -SCM_PROC(s_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 0, scm_dimensions_to_uniform_array); - -SCM -scm_dimensions_to_uniform_array (dims, prot, fill) - SCM dims; - SCM prot; - SCM fill; +GUILE_PROC(scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 0, + (SCM dims, SCM prot, SCM fill), +"") +#define FUNC_NAME s_scm_dimensions_to_uniform_array { scm_sizet k, vlen = 1; long rlen = 1; @@ -536,8 +529,8 @@ scm_dimensions_to_uniform_array (dims, prot, fill) dims = scm_cons (dims, SCM_EOL); } SCM_ASSERT (SCM_NULLP (dims) || (SCM_NIMP (dims) && SCM_CONSP (dims)), - dims, SCM_ARG1, s_dimensions_to_uniform_array); - ra = scm_shap2ra (dims, s_dimensions_to_uniform_array); + dims, SCM_ARG1, FUNC_NAME); + ra = scm_shap2ra (dims, FUNC_NAME); SCM_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS); s = SCM_ARRAY_DIMS (ra); k = SCM_ARRAY_NDIM (ra); @@ -591,11 +584,11 @@ scm_dimensions_to_uniform_array (dims, prot, fill) return SCM_ARRAY_V (ra); return ra; } +#undef FUNC_NAME void -scm_ra_set_contp (ra) - SCM ra; +scm_ra_set_contp (SCM ra) { scm_sizet k = SCM_ARRAY_NDIM (ra); if (k) @@ -616,13 +609,10 @@ scm_ra_set_contp (ra) } -SCM_PROC(s_make_shared_array, "make-shared-array", 2, 0, 1, scm_make_shared_array); - -SCM -scm_make_shared_array (oldra, mapfunc, dims) - SCM oldra; - SCM mapfunc; - SCM dims; +GUILE_PROC(scm_make_shared_array, "make-shared-array", 2, 0, 1, + (SCM oldra, SCM mapfunc, SCM dims), +"") +#define FUNC_NAME s_scm_make_shared_array { SCM ra; SCM inds, indptr; @@ -630,9 +620,9 @@ scm_make_shared_array (oldra, mapfunc, dims) scm_sizet i, k; long old_min, new_min, old_max, new_max; scm_array_dim *s; - SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (mapfunc), mapfunc, SCM_ARG2, s_make_shared_array); - SCM_ASSERT (SCM_NIMP (oldra) && (SCM_BOOL_F != scm_array_p (oldra, SCM_UNDEFINED)), oldra, SCM_ARG1, s_make_shared_array); - ra = scm_shap2ra (dims, s_make_shared_array); + SCM_VALIDATE_ARRAY(1,oldra); + SCM_VALIDATE_PROC(2,mapfunc); + ra = scm_shap2ra (dims, FUNC_NAME); if (SCM_ARRAYP (oldra)) { SCM_ARRAY_V (ra) = SCM_ARRAY_V (oldra); @@ -669,14 +659,14 @@ scm_make_shared_array (oldra, mapfunc, dims) } imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL); if (SCM_ARRAYP (oldra)) - i = (scm_sizet) scm_aind (oldra, imap, s_make_shared_array); + i = (scm_sizet) scm_aind (oldra, imap, FUNC_NAME); else { if (SCM_NINUMP (imap)) { SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)), - imap, s_bad_ind, s_make_shared_array); + imap, s_bad_ind, FUNC_NAME); imap = SCM_CAR (imap); } i = SCM_INUM (imap); @@ -692,14 +682,14 @@ scm_make_shared_array (oldra, mapfunc, dims) imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL); if (SCM_ARRAYP (oldra)) - s[k].inc = scm_aind (oldra, imap, s_make_shared_array) - i; + s[k].inc = scm_aind (oldra, imap, FUNC_NAME) - i; else { if (SCM_NINUMP (imap)) { SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)), - imap, s_bad_ind, s_make_shared_array); + imap, s_bad_ind, FUNC_NAME); imap = SCM_CAR (imap); } s[k].inc = (long) SCM_INUM (imap) - i; @@ -715,7 +705,7 @@ scm_make_shared_array (oldra, mapfunc, dims) indptr = SCM_CDR (indptr); } SCM_ASSERT (old_min <= new_min && old_max >= new_max, SCM_UNDEFINED, - "mapping out of range", s_make_shared_array); + "mapping out of range", FUNC_NAME); if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) { if (1 == s->inc && 0 == s->lbnd @@ -727,27 +717,27 @@ scm_make_shared_array (oldra, mapfunc, dims) scm_ra_set_contp (ra); return ra; } +#undef FUNC_NAME /* args are RA . DIMS */ -SCM_PROC(s_transpose_array, "transpose-array", 0, 0, 1, scm_transpose_array); - -SCM -scm_transpose_array (args) - SCM args; +GUILE_PROC(scm_transpose_array, "transpose-array", 0, 0, 1, + (SCM args), +"") +#define FUNC_NAME s_scm_transpose_array { SCM ra, res, vargs, *ve = &vargs; scm_array_dim *s, *r; int ndim, i, k; - SCM_ASSERT (SCM_NNULLP (args), scm_makfrom0str (s_transpose_array), + SCM_ASSERT (SCM_NNULLP (args), scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); ra = SCM_CAR (args); - SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, s_transpose_array); + SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME); args = SCM_CDR (args); switch (SCM_TYP7 (ra)) { default: - badarg:scm_wta (ra, (char *) SCM_ARG1, s_transpose_array); + badarg:SCM_WTA (1,ra); case scm_tc7_bvect: case scm_tc7_string: case scm_tc7_byvect: @@ -761,26 +751,26 @@ scm_transpose_array (args) case scm_tc7_llvect: #endif SCM_ASSERT (SCM_NIMP (args) && SCM_NULLP (SCM_CDR (args)), - scm_makfrom0str (s_transpose_array), SCM_WNA, NULL); + scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), SCM_CAR (args), SCM_ARG2, - s_transpose_array); + FUNC_NAME); SCM_ASSERT (SCM_INUM0 == SCM_CAR (args), SCM_CAR (args), SCM_OUTOFRANGE, - s_transpose_array); + FUNC_NAME); return ra; case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (ra), badarg); vargs = scm_vector (args); SCM_ASSERT (SCM_LENGTH (vargs) == SCM_ARRAY_NDIM (ra), - scm_makfrom0str (s_transpose_array), SCM_WNA, NULL); + scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); ve = SCM_VELTS (vargs); ndim = 0; for (k = 0; k < SCM_ARRAY_NDIM (ra); k++) { SCM_ASSERT (SCM_INUMP (ve[k]), ve[k], (SCM_ARG2 + k), - s_transpose_array); + FUNC_NAME); i = SCM_INUM (ve[k]); SCM_ASSERT (i >= 0 && i < SCM_ARRAY_NDIM (ra), ve[k], - SCM_OUTOFRANGE, s_transpose_array); + SCM_OUTOFRANGE, FUNC_NAME); if (ndim < i) ndim = i; } @@ -817,28 +807,27 @@ scm_transpose_array (args) r->inc += s->inc; } } - SCM_ASSERT (ndim <= 0, args, "bad argument list", s_transpose_array); + SCM_ASSERT (ndim <= 0, args, "bad argument list", FUNC_NAME); scm_ra_set_contp (res); return res; } } +#undef FUNC_NAME /* args are RA . AXES */ -SCM_PROC(s_enclose_array, "enclose-array", 0, 0, 1, scm_enclose_array); - -SCM -scm_enclose_array (axes) - SCM axes; +GUILE_PROC(scm_enclose_array, "enclose-array", 0, 0, 1, + (SCM axes), +"") +#define FUNC_NAME s_scm_enclose_array { SCM axv, ra, res, ra_inr; scm_array_dim vdim, *s = &vdim; int ndim, j, k, ninr, noutr; - SCM_ASSERT (SCM_NIMP (axes), scm_makfrom0str (s_enclose_array), SCM_WNA, + 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); ra_inr = scm_make_ra (ninr); @@ -847,7 +836,7 @@ scm_enclose_array (axes) (ra) { default: - badarg1:scm_wta (ra, (char *) SCM_ARG1, s_enclose_array); + badarg1:SCM_WTA (1,ra); case scm_tc7_string: case scm_tc7_bvect: case scm_tc7_byvect: @@ -879,14 +868,14 @@ scm_enclose_array (axes) } noutr = ndim - ninr; axv = scm_make_string (SCM_MAKINUM (ndim), SCM_MAKICHR (0)); - SCM_ASSERT (0 <= noutr && 0 <= ninr, scm_makfrom0str (s_enclose_array), + SCM_ASSERT (0 <= noutr && 0 <= ninr, 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; for (k = 0; k < ninr; k++, axes = SCM_CDR (axes)) { - SCM_ASSERT (SCM_INUMP (SCM_CAR (axes)), SCM_CAR (axes), "bad axis", s_enclose_array); + SCM_ASSERT (SCM_INUMP (SCM_CAR (axes)), SCM_CAR (axes), "bad axis", FUNC_NAME); j = SCM_INUM (SCM_CAR (axes)); SCM_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd; SCM_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd; @@ -905,21 +894,21 @@ scm_enclose_array (axes) scm_ra_set_contp (res); return res; } +#undef FUNC_NAME -SCM_PROC(s_array_in_bounds_p, "array-in-bounds?", 0, 0, 1, scm_array_in_bounds_p); - -SCM -scm_array_in_bounds_p (args) - SCM args; +GUILE_PROC(scm_array_in_bounds_p, "array-in-bounds?", 0, 0, 1, + (SCM args), +"") +#define FUNC_NAME s_scm_array_in_bounds_p { SCM v, ind = SCM_EOL; long pos = 0; register scm_sizet k; register long j; scm_array_dim *s; - SCM_ASSERT (SCM_NIMP (args), scm_makfrom0str (s_array_in_bounds_p), + SCM_ASSERT (SCM_NIMP (args), scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); v = SCM_CAR (args); args = SCM_CDR (args); @@ -929,7 +918,7 @@ scm_array_in_bounds_p (args) { ind = SCM_CAR (args); args = SCM_CDR (args); - SCM_ASSERT (SCM_INUMP (ind), ind, SCM_ARG2, s_array_in_bounds_p); + SCM_ASSERT (SCM_INUMP (ind), ind, SCM_ARG2, FUNC_NAME); pos = SCM_INUM (ind); } tail: @@ -937,8 +926,8 @@ tail: (v) { default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_in_bounds_p); - wna: scm_wrong_num_args (scm_makfrom0str (s_array_in_bounds_p)); + badarg1:SCM_WTA (1,v); + wna: scm_wrong_num_args (scm_makfrom0str (FUNC_NAME)); case scm_tc7_smob: k = SCM_ARRAY_NDIM (v); s = SCM_ARRAY_DIMS (v); @@ -963,7 +952,7 @@ tail: ind = SCM_CAR (args); args = SCM_CDR (args); s++; - SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, s_array_in_bounds_p); + SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, FUNC_NAME); } SCM_ASRTGO (0 == k, wna); v = SCM_ARRAY_V (v); @@ -983,18 +972,19 @@ tail: case scm_tc7_vector: case scm_tc7_wvect: SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna); - return pos >= 0 && pos < SCM_LENGTH (v) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(pos >= 0 && pos < SCM_LENGTH (v)); } } +#undef FUNC_NAME -SCM_PROC(s_array_ref, "array-ref", 1, 0, 1, scm_uniform_vector_ref); -SCM_PROC(s_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, scm_uniform_vector_ref); +SCM_REGISTER_PROC(s_array_ref, "array-ref", 1, 0, 1, scm_uniform_vector_ref); -SCM -scm_uniform_vector_ref (v, args) - SCM v; - SCM args; + +GUILE_PROC(scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, + (SCM v, SCM args), +"") +#define FUNC_NAME s_scm_uniform_vector_ref { long pos; @@ -1005,7 +995,7 @@ scm_uniform_vector_ref (v, args) } else if (SCM_ARRAYP (v)) { - pos = scm_aind (v, args, s_uniform_vector_ref); + pos = scm_aind (v, args, FUNC_NAME); v = SCM_ARRAY_V (v); } else @@ -1013,13 +1003,13 @@ scm_uniform_vector_ref (v, args) if (SCM_NIMP (args)) { - SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, s_uniform_vector_ref); + SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, FUNC_NAME); pos = SCM_INUM (SCM_CAR (args)); SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna); } else { - SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG2, s_uniform_vector_ref); + SCM_VALIDATE_INT(2,args); pos = SCM_INUM (args); } SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng); @@ -1031,10 +1021,10 @@ scm_uniform_vector_ref (v, args) if (SCM_NULLP (args)) return v; badarg: - scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_ref); + SCM_WTA (1,v); abort (); - outrng:scm_out_of_range (s_uniform_vector_ref, SCM_MAKINUM (pos)); - wna: scm_wrong_num_args (scm_makfrom0str (s_uniform_vector_ref)); + outrng:scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); + wna: scm_wrong_num_args (SCM_FUNC_NAME); case scm_tc7_smob: { /* enclosed */ int k = SCM_ARRAY_NDIM (v); @@ -1092,6 +1082,7 @@ scm_uniform_vector_ref (v, args) return SCM_VELTS (v)[pos]; } } +#undef FUNC_NAME /* Internal version of scm_uniform_vector_ref for uves that does no error checking and tries to recycle conses. (Make *sure* you want them recycled.) */ @@ -1182,22 +1173,21 @@ scm_cvref (v, pos, last) } } -SCM_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x); -SCM_PROC(s_array_set_x, "array-set!", 2, 0, 1, scm_array_set_x); +SCM_REGISTER_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x); + /* Note that args may be a list or an immediate object, depending which PROC is used (and it's called from C too). */ -SCM -scm_array_set_x (v, obj, args) - SCM v; - SCM obj; - SCM args; +GUILE_PROC(scm_array_set_x, "array-set!", 2, 0, 1, + (SCM v, SCM obj, SCM args), +"") +#define FUNC_NAME s_scm_array_set_x { long pos = 0; SCM_ASRTGO (SCM_NIMP (v), badarg1); if (SCM_ARRAYP (v)) { - pos = scm_aind (v, args, s_array_set_x); + pos = scm_aind (v, args, FUNC_NAME); v = SCM_ARRAY_V (v); } else @@ -1205,24 +1195,23 @@ scm_array_set_x (v, obj, args) if (SCM_NIMP (args)) { SCM_ASSERT (SCM_CONSP(args) && SCM_INUMP (SCM_CAR (args)), args, - SCM_ARG3, s_array_set_x); + SCM_ARG3, FUNC_NAME); SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna); pos = SCM_INUM (SCM_CAR (args)); } else { - SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG3, s_array_set_x); - pos = SCM_INUM (args); + SCM_VALIDATE_INT_COPY(3,args,pos); } SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng); } switch (SCM_TYP7 (v)) { default: badarg1: - scm_wta (v, (char *) SCM_ARG1, s_array_set_x); + SCM_WTA (1,v); abort (); - outrng:scm_out_of_range (s_array_set_x, SCM_MAKINUM (pos)); - wna: scm_wrong_num_args (scm_makfrom0str (s_array_set_x)); + outrng:scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); + wna: scm_wrong_num_args (SCM_FUNC_NAME); case scm_tc7_smob: /* enclosed */ goto badarg1; case scm_tc7_bvect: @@ -1231,7 +1220,7 @@ scm_array_set_x (v, obj, args) else if (SCM_BOOL_T == obj) SCM_VELTS (v)[pos / SCM_LONG_BIT] |= (1L << (pos % SCM_LONG_BIT)); else - badobj:scm_wta (obj, (char *) SCM_ARG2, s_array_set_x); + badobj:SCM_WTA (2,obj); break; case scm_tc7_string: SCM_ASRTGO (SCM_ICHRP (obj), badobj); @@ -1245,24 +1234,23 @@ scm_array_set_x (v, obj, args) break; # ifdef SCM_INUMS_ONLY case scm_tc7_uvect: - SCM_ASRTGO (SCM_INUM (obj) >= 0, badobj); + SCM_ASRTGO (SCM_INUM (obj) >= 0, badobj); + /* fall through */ case scm_tc7_ivect: - SCM_ASRTGO(SCM_INUMP(obj), badobj); SCM_VELTS(v)[pos] = SCM_INUM(obj); break; + SCM_ASRTGO(SCM_INUMP(obj), badobj); SCM_VELTS(v)[pos] = SCM_INUM(obj); break; # else - case scm_tc7_uvect: - SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG2, s_array_set_x); break; - case scm_tc7_ivect: - SCM_VELTS(v)[pos] = scm_num2long(obj, (char *)SCM_ARG2, s_array_set_x); break; + case scm_tc7_uvect: + SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG2, FUNC_NAME); break; + case scm_tc7_ivect: + SCM_VELTS(v)[pos] = scm_num2long(obj, (char *)SCM_ARG2, FUNC_NAME); break; # endif - break; - case scm_tc7_svect: SCM_ASRTGO (SCM_INUMP (obj), badobj); ((short *) SCM_CDR (v))[pos] = SCM_INUM (obj); break; #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: - ((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG2, s_array_set_x); + ((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG2, FUNC_NAME); break; #endif @@ -1270,11 +1258,11 @@ scm_array_set_x (v, obj, args) #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: - ((float *) SCM_CDR (v))[pos] = (float)scm_num2dbl(obj, s_array_set_x); break; + ((float *) SCM_CDR (v))[pos] = (float)scm_num2dbl(obj, FUNC_NAME); break; break; #endif case scm_tc7_dvect: - ((double *) SCM_CDR (v))[pos] = scm_num2dbl(obj, s_array_set_x); break; + ((double *) SCM_CDR (v))[pos] = scm_num2dbl(obj, FUNC_NAME); break; break; case scm_tc7_cvect: SCM_ASRTGO (SCM_NIMP (obj) && SCM_INEXP (obj), badobj); @@ -1289,16 +1277,16 @@ scm_array_set_x (v, obj, args) } return SCM_UNSPECIFIED; } +#undef FUNC_NAME /* attempts to unroll an array into a one-dimensional array. returns the unrolled array or #f if it can't be done. */ -SCM_PROC(s_array_contents, "array-contents", 1, 1, 0, scm_array_contents); - -SCM -scm_array_contents (ra, strict) - SCM ra; - SCM strict; /* if not SCM_UNDEFINED, return #f if returned array + /* if strict is not SCM_UNDEFINED, return #f if returned array wouldn't have contiguous elements. */ +GUILE_PROC(scm_array_contents, "array-contents", 1, 1, 0, + (SCM ra, SCM strict), +"") +#define FUNC_NAME s_scm_array_contents { SCM sra; if (SCM_IMP (ra)) @@ -1353,6 +1341,7 @@ scm_array_contents (ra, strict) } } } +#undef FUNC_NAME SCM @@ -1392,14 +1381,10 @@ scm_ra2contig (ra, copy) -SCM_PROC(s_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, scm_uniform_array_read_x); - -SCM -scm_uniform_array_read_x (ra, port_or_fd, start, end) - SCM ra; - SCM port_or_fd; - SCM start; - SCM end; +GUILE_PROC(scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, + (SCM ra, SCM port_or_fd, SCM start, SCM end), +"") +#define FUNC_NAME s_scm_uniform_array_read_x { SCM cra = SCM_UNDEFINED, v = ra; long sz, vlen, ans; @@ -1413,14 +1398,14 @@ scm_uniform_array_read_x (ra, port_or_fd, start, end) else SCM_ASSERT (SCM_INUMP (port_or_fd) || (SCM_NIMP (port_or_fd) && SCM_OPINPORTP (port_or_fd)), - port_or_fd, SCM_ARG2, s_uniform_array_read_x); + port_or_fd, SCM_ARG2, FUNC_NAME); vlen = SCM_LENGTH (v); loop: switch SCM_TYP7 (v) { default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_read_x); + badarg1:scm_wta (v, (char *) SCM_ARG1, FUNC_NAME); case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (v), badarg1); cra = scm_ra2contig (ra, 0); @@ -1467,18 +1452,18 @@ loop: if (!SCM_UNBNDP (start)) { offset = - scm_num2long (start, (char *) SCM_ARG3, s_uniform_array_read_x); + scm_num2long (start, (char *) SCM_ARG3, FUNC_NAME); if (offset < 0 || offset >= cend) - scm_out_of_range (s_uniform_array_read_x, start); + scm_out_of_range (FUNC_NAME, start); if (!SCM_UNBNDP (end)) { long tend = - scm_num2long (end, (char *) SCM_ARG4, s_uniform_array_read_x); + scm_num2long (end, (char *) SCM_ARG4, FUNC_NAME); if (tend <= offset || tend > cend) - scm_out_of_range (s_uniform_array_read_x, end); + scm_out_of_range (FUNC_NAME, end); cend = tend; } } @@ -1511,7 +1496,7 @@ loop: { if (remaining % sz != 0) { - scm_misc_error (s_uniform_array_read_x, + scm_misc_error (FUNC_NAME, "unexpected EOF", SCM_EOL); } @@ -1530,7 +1515,7 @@ loop: SCM_CHARS (v) + (cstart + offset) * sz, (scm_sizet) (sz * (cend - offset)))); if (ans == -1) - scm_syserror (s_uniform_array_read_x); + SCM_SYSERROR; } if (SCM_TYP7 (v) == scm_tc7_bvect) ans *= SCM_LONG_BIT; @@ -1540,15 +1525,12 @@ loop: return SCM_MAKINUM (ans); } +#undef FUNC_NAME -SCM_PROC(s_uniform_array_write, "uniform-array-write", 1, 3, 0, scm_uniform_array_write); - -SCM -scm_uniform_array_write (v, port_or_fd, start, end) - SCM v; - SCM port_or_fd; - SCM start; - SCM end; +GUILE_PROC(scm_uniform_array_write, "uniform-array-write", 1, 3, 0, + (SCM v, SCM port_or_fd, SCM start, SCM end), +"") +#define FUNC_NAME s_scm_uniform_array_write { long sz, vlen, ans; long offset = 0; @@ -1563,14 +1545,14 @@ scm_uniform_array_write (v, port_or_fd, start, end) else SCM_ASSERT (SCM_INUMP (port_or_fd) || (SCM_NIMP (port_or_fd) && SCM_OPOUTPORTP (port_or_fd)), - port_or_fd, SCM_ARG2, s_uniform_array_write); + port_or_fd, SCM_ARG2, FUNC_NAME); vlen = SCM_LENGTH (v); loop: switch SCM_TYP7 (v) { default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_write); + badarg1:scm_wta (v, (char *) SCM_ARG1, FUNC_NAME); case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (v), badarg1); v = scm_ra2contig (v, 1); @@ -1617,18 +1599,18 @@ loop: if (!SCM_UNBNDP (start)) { offset = - scm_num2long (start, (char *) SCM_ARG3, s_uniform_array_write); + scm_num2long (start, (char *) SCM_ARG3, FUNC_NAME); if (offset < 0 || offset >= cend) - scm_out_of_range (s_uniform_array_write, start); + scm_out_of_range (FUNC_NAME, start); if (!SCM_UNBNDP (end)) { long tend = - scm_num2long (end, (char *) SCM_ARG4, s_uniform_array_write); + scm_num2long (end, (char *) SCM_ARG4, FUNC_NAME); if (tend <= offset || tend > cend) - scm_out_of_range (s_uniform_array_write, end); + scm_out_of_range (FUNC_NAME, end); cend = tend; } } @@ -1646,32 +1628,31 @@ loop: SCM_CHARS (v) + (cstart + offset) * sz, (scm_sizet) (sz * (cend - offset)))); if (ans == -1) - scm_syserror (s_uniform_array_write); + SCM_SYSERROR; } if (SCM_TYP7 (v) == scm_tc7_bvect) ans *= SCM_LONG_BIT; return SCM_MAKINUM (ans); } +#undef FUNC_NAME static char cnt_tab[16] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4}; -SCM_PROC(s_bit_count, "bit-count", 2, 0, 0, scm_bit_count); - -SCM -scm_bit_count (item, seq) - SCM item; - SCM seq; +GUILE_PROC(scm_bit_count, "bit-count", 2, 0, 0, + (SCM item, SCM seq), +"") +#define FUNC_NAME s_scm_bit_count { long i; register unsigned long cnt = 0, w; - SCM_ASSERT (SCM_NIMP (seq), seq, SCM_ARG2, s_bit_count); + SCM_VALIDATE_INT(2,seq); switch SCM_TYP7 (seq) { default: - scm_wta (seq, (char *) SCM_ARG2, s_bit_count); + SCM_WTA (2,seq); case scm_tc7_bvect: if (0 == SCM_LENGTH (seq)) return SCM_INUM0; @@ -1692,28 +1673,26 @@ scm_bit_count (item, seq) } } } +#undef FUNC_NAME -SCM_PROC(s_bit_position, "bit-position", 3, 0, 0, scm_bit_position); - -SCM -scm_bit_position (item, v, k) - SCM item; - SCM v; - SCM k; +GUILE_PROC(scm_bit_position, "bit-position", 3, 0, 0, + (SCM item, SCM v, SCM k), +"") +#define FUNC_NAME s_scm_bit_position { - long i, lenw, xbits, pos = SCM_INUM (k); + long i, lenw, xbits, pos; register unsigned long w; - SCM_ASSERT (SCM_NIMP (v), v, SCM_ARG2, s_bit_position); - SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG3, s_bit_position); + SCM_VALIDATE_NIMP(2,v); + SCM_VALIDATE_INT_COPY(3,k,pos); SCM_ASSERT ((pos <= SCM_LENGTH (v)) && (pos >= 0), - k, SCM_OUTOFRANGE, s_bit_position); + k, SCM_OUTOFRANGE, FUNC_NAME); if (pos == SCM_LENGTH (v)) return SCM_BOOL_F; switch SCM_TYP7 (v) { default: - scm_wta (v, (char *) SCM_ARG2, s_bit_position); + SCM_WTA (2,v); case scm_tc7_bvect: if (0 == SCM_LENGTH (v)) return SCM_MAKINUM (-1L); @@ -1760,15 +1739,13 @@ scm_bit_position (item, v, k) return SCM_BOOL_F; } } +#undef FUNC_NAME -SCM_PROC(s_bit_set_star_x, "bit-set*!", 3, 0, 0, scm_bit_set_star_x); - -SCM -scm_bit_set_star_x (v, kv, obj) - SCM v; - SCM kv; - SCM obj; +GUILE_PROC(scm_bit_set_star_x, "bit-set*!", 3, 0, 0, + (SCM v, SCM kv, SCM obj), +"") +#define FUNC_NAME s_scm_bit_set_star_x { register long i, k, vlen; SCM_ASRTGO (SCM_NIMP (v), badarg1); @@ -1776,30 +1753,30 @@ scm_bit_set_star_x (v, kv, obj) switch SCM_TYP7 (kv) { default: - badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_set_star_x); + badarg2:SCM_WTA (2,kv); case scm_tc7_uvect: switch SCM_TYP7 (v) { default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_set_star_x); + badarg1:SCM_WTA (1,v); case scm_tc7_bvect: vlen = SCM_LENGTH (v); if (SCM_BOOL_F == obj) for (i = SCM_LENGTH (kv); i;) { k = SCM_VELTS (kv)[--i]; - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_set_star_x); + SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); SCM_VELTS (v)[k / SCM_LONG_BIT] &= ~(1L << (k % SCM_LONG_BIT)); } else if (SCM_BOOL_T == obj) for (i = SCM_LENGTH (kv); i;) { k = SCM_VELTS (kv)[--i]; - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_set_star_x); + SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); SCM_VELTS (v)[k / SCM_LONG_BIT] |= (1L << (k % SCM_LONG_BIT)); } else - badarg3:scm_wta (obj, (char *) SCM_ARG3, s_bit_set_star_x); + badarg3:SCM_WTA (3,obj); } break; case scm_tc7_bvect: @@ -1816,15 +1793,13 @@ scm_bit_set_star_x (v, kv, obj) } return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_bit_count_star, "bit-count*", 3, 0, 0, scm_bit_count_star); - -SCM -scm_bit_count_star (v, kv, obj) - SCM v; - SCM kv; - SCM obj; +GUILE_PROC(scm_bit_count_star, "bit-count*", 3, 0, 0, + (SCM v, SCM kv, SCM obj), +"") +#define FUNC_NAME s_scm_bit_count_star { register long i, vlen, count = 0; register unsigned long k; @@ -1833,20 +1808,20 @@ scm_bit_count_star (v, kv, obj) switch SCM_TYP7 (kv) { default: - badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_count_star); + badarg2:SCM_WTA (2,kv); case scm_tc7_uvect: switch SCM_TYP7 (v) { default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_count_star); + badarg1:SCM_WTA (1,v); case scm_tc7_bvect: vlen = SCM_LENGTH (v); if (SCM_BOOL_F == obj) for (i = SCM_LENGTH (kv); i;) { k = SCM_VELTS (kv)[--i]; - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_count_star); + SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); if (!(SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT)))) count++; } @@ -1854,12 +1829,12 @@ scm_bit_count_star (v, kv, obj) for (i = SCM_LENGTH (kv); i;) { k = SCM_VELTS (kv)[--i]; - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_count_star); + SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); if (SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT))) count++; } else - badarg3:scm_wta (obj, (char *) SCM_ARG3, s_bit_count_star); + badarg3:SCM_WTA (3,obj); } break; case scm_tc7_bvect: @@ -1882,13 +1857,13 @@ scm_bit_count_star (v, kv, obj) } return SCM_MAKINUM (count); } +#undef FUNC_NAME -SCM_PROC(s_bit_invert_x, "bit-invert!", 1, 0, 0, scm_bit_invert_x); - -SCM -scm_bit_invert_x (v) - SCM v; +GUILE_PROC(scm_bit_invert_x, "bit-invert!", 1, 0, 0, + (SCM v), +"") +#define FUNC_NAME s_scm_bit_invert_x { register long k; SCM_ASRTGO (SCM_NIMP (v), badarg1); @@ -1901,16 +1876,15 @@ scm_bit_invert_x (v) SCM_VELTS (v)[k] = ~SCM_VELTS (v)[k]; break; default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_invert_x); + badarg1:SCM_WTA (1,v); } return SCM_UNSPECIFIED; } +#undef FUNC_NAME SCM -scm_istr2bve (str, len) - char *str; - long len; +scm_istr2bve (char *str, long len) { SCM v = scm_make_uve (len, SCM_BOOL_T); long *data = (long *) SCM_VELTS (v); @@ -1940,13 +1914,8 @@ scm_istr2bve (str, len) -static SCM ra2l SCM_P ((SCM ra, scm_sizet base, scm_sizet k)); - static SCM -ra2l (ra, base, k) - SCM ra; - scm_sizet base; - scm_sizet k; +ra2l (SCM ra,scm_sizet base,scm_sizet k) { register SCM res = SCM_EOL; register long inc = SCM_ARRAY_DIMS (ra)[k].inc; @@ -1974,11 +1943,10 @@ ra2l (ra, base, k) } -SCM_PROC(s_array_to_list, "array->list", 1, 0, 0, scm_array_to_list); - -SCM -scm_array_to_list (v) - SCM v; +GUILE_PROC(scm_array_to_list, "array->list", 1, 0, 0, + (SCM v), +"") +#define FUNC_NAME s_scm_array_to_list { SCM res = SCM_EOL; register long k; @@ -1987,7 +1955,7 @@ scm_array_to_list (v) (v) { default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_to_list); + badarg1:SCM_WTA (1,v); case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (v), badarg1); return ra2l (v, SCM_ARRAY_BASE (v), 0); @@ -2075,31 +2043,28 @@ scm_array_to_list (v) #endif /*SCM_FLOATS*/ } } +#undef FUNC_NAME static char s_bad_ralst[] = "Bad scm_array contents list"; -static int l2ra SCM_P ((SCM lst, SCM ra, scm_sizet base, scm_sizet k)); - -SCM_PROC(s_list_to_uniform_array, "list->uniform-array", 3, 0, 0, scm_list_to_uniform_array); +static int l2ra(SCM lst, SCM ra, scm_sizet base, scm_sizet k); -SCM -scm_list_to_uniform_array (ndim, prot, lst) - SCM ndim; - SCM prot; - SCM lst; +GUILE_PROC(scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, + (SCM ndim, SCM prot, SCM lst), +"") +#define FUNC_NAME s_scm_list_to_uniform_array { SCM shp = SCM_EOL; SCM row = lst; SCM ra; scm_sizet k; long n; - SCM_ASSERT (SCM_INUMP (ndim), ndim, SCM_ARG1, s_list_to_uniform_array); - k = SCM_INUM (ndim); + SCM_VALIDATE_INT_COPY(1,ndim,k); while (k--) { n = scm_ilength (row); - SCM_ASSERT (n >= 0, lst, SCM_ARG3, s_list_to_uniform_array); + SCM_ASSERT (n >= 0, lst, SCM_ARG3, FUNC_NAME); shp = scm_cons (SCM_MAKINUM (n), shp); if (SCM_NIMP (row)) row = SCM_CAR (row); @@ -2122,16 +2087,13 @@ scm_list_to_uniform_array (ndim, prot, lst) if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0)) return ra; else - badlst:scm_wta (lst, s_bad_ralst, s_list_to_uniform_array); + badlst:scm_wta (lst, s_bad_ralst, FUNC_NAME); return SCM_BOOL_F; } +#undef FUNC_NAME static int -l2ra (lst, ra, base, k) - SCM lst; - SCM ra; - scm_sizet base; - scm_sizet k; +l2ra (SCM lst, SCM ra, scm_sizet base, scm_sizet k) { register long inc = SCM_ARRAY_DIMS (ra)[k].inc; register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd); @@ -2168,15 +2130,8 @@ l2ra (lst, ra, base, k) } -static void rapr1 SCM_P ((SCM ra, scm_sizet j, scm_sizet k, SCM port, scm_print_state *pstate)); - static void -rapr1 (ra, j, k, port, pstate) - SCM ra; - scm_sizet j; - scm_sizet k; - SCM port; - scm_print_state *pstate; +rapr1 (SCM ra,scm_sizet j,scm_sizet k,SCM port,scm_print_state *pstate) { long inc = 1; long n = SCM_LENGTH (ra); @@ -2351,10 +2306,7 @@ tail: int -scm_raprin1 (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate) { SCM v = exp; scm_sizet base = 0; @@ -2450,11 +2402,10 @@ tail: return 1; } -SCM_PROC(s_array_prototype, "array-prototype", 1, 0, 0, scm_array_prototype); - -SCM -scm_array_prototype (ra) - SCM ra; +GUILE_PROC(scm_array_prototype, "array-prototype", 1, 0, 0, + (SCM ra), +"") +#define FUNC_NAME s_scm_array_prototype { int enclosed = 0; SCM_ASRTGO (SCM_NIMP (ra), badarg); @@ -2463,7 +2414,7 @@ loop: (ra) { default: - badarg:scm_wta (ra, (char *) SCM_ARG1, s_array_prototype); + badarg:SCM_WTA (1,ra); case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (ra), badarg); if (enclosed++) @@ -2501,23 +2452,18 @@ loop: #endif } } +#undef FUNC_NAME -static SCM markra SCM_P ((SCM ptr)); - static SCM -markra (ptr) - SCM ptr; +markra (SCM ptr) { return SCM_ARRAY_V (ptr); } -static scm_sizet freera SCM_P ((SCM ptr)); - static scm_sizet -freera (ptr) - SCM ptr; +freera (SCM ptr) { scm_must_free (SCM_CHARS (ptr)); return sizeof (scm_array) + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim); diff --git a/libguile/variable.c b/libguile/variable.c index 6fe9df9cf..2d47ff6a4 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -46,16 +50,12 @@ #include "genio.h" #include "smob.h" +#include "scm_validate.h" #include "variable.h" -static int prin_var SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - static int -prin_var (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +prin_var (SCM exp,SCM port,scm_print_state *pstate) { scm_puts ("# #include "_scm.h" #include "eq.h" +#include "scm_validate.h" #include "vectors.h" #include "unif.h" @@ -53,15 +58,13 @@ * C code can safely call it on arrays known to be used in a single * threaded manner. * - * SCM_PROC(s_vector_set_length_x, "vector-set-length!", 2, 0, 0, scm_vector_set_length_x); + * SCM_REGISTER_PROC(s_vector_set_length_x, "vector-set-length!", 2, 0, 0, scm_vector_set_length_x); */ static char s_vector_set_length_x[] = "vector-set-length!"; SCM -scm_vector_set_length_x (vect, len) - SCM vect; - SCM len; +scm_vector_set_length_x (SCM vect, SCM len) { long l; scm_sizet siz; @@ -119,15 +122,15 @@ scm_vector_set_length_x (vect, len) return vect; } -SCM_PROC(s_vector_p, "vector?", 1, 0, 0, scm_vector_p); - -SCM -scm_vector_p(x) - SCM x; +GUILE_PROC(scm_vector_p, "vector?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_vector_p { if (SCM_IMP(x)) return SCM_BOOL_F; - return SCM_VECTORP(x) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(SCM_VECTORP(x)); } +#undef FUNC_NAME SCM_GPROC(s_vector_length, "vector-length", 1, 0, 0, scm_vector_length, g_vector_length); @@ -140,23 +143,24 @@ scm_vector_length(v) return SCM_MAKINUM(SCM_LENGTH(v)); } -SCM_PROC(s_list_to_vector, "list->vector", 1, 0, 0, scm_vector); -SCM_PROC(s_vector, "vector", 0, 0, 1, scm_vector); +SCM_REGISTER_PROC(s_list_to_vector, "list->vector", 1, 0, 0, scm_vector); -SCM -scm_vector(l) - SCM l; +GUILE_PROC(scm_vector, "vector", 0, 0, 1, + (SCM l), +"") +#define FUNC_NAME s_scm_vector { SCM res; register SCM *data; - long i = scm_ilength(l); - SCM_ASSERT(i >= 0, l, SCM_ARG1, s_vector); + int i; + SCM_VALIDATE_LIST_COPYLEN(1,l,i); res = scm_make_vector (SCM_MAKINUM(i), SCM_UNSPECIFIED); data = SCM_VELTS(res); for(;i && SCM_NIMP(l);--i, l = SCM_CDR(l)) *data++ = SCM_CAR(l); return res; } +#undef FUNC_NAME SCM_GPROC(s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref, g_vector_ref); @@ -193,25 +197,23 @@ scm_vector_set_x(v, k, obj) } -SCM_PROC (s_make_vector, "make-vector", 1, 1, 0, scm_make_vector); - -SCM -scm_make_vector (k, fill) - SCM k; - SCM fill; +GUILE_PROC (scm_make_vector, "make-vector", 1, 1, 0, + (SCM k, SCM fill), +"") +#define FUNC_NAME s_scm_make_vector { SCM v; register long i; register long j; register SCM *velts; - SCM_ASSERT(SCM_INUMP(k) && (0 <= SCM_INUM (k)), k, SCM_ARG1, s_make_vector); + SCM_VALIDATE_INT_MIN(1,k,0); if (SCM_UNBNDP(fill)) fill = SCM_UNSPECIFIED; i = SCM_INUM(k); SCM_NEWCELL(v); SCM_DEFER_INTS; - SCM_SETCHARS(v, scm_must_malloc(i?(long)(i*sizeof(SCM)):1L, s_vector)); + SCM_SETCHARS(v, scm_must_malloc(i?(long)(i*sizeof(SCM)):1L, FUNC_NAME)); SCM_SETLENGTH(v, i, scm_tc7_vector); velts = SCM_VELTS(v); j = 0; @@ -219,46 +221,44 @@ scm_make_vector (k, fill) SCM_ALLOW_INTS; return v; } +#undef FUNC_NAME -SCM_PROC(s_vector_to_list, "vector->list", 1, 0, 0, scm_vector_to_list); - -SCM -scm_vector_to_list(v) - SCM v; +GUILE_PROC(scm_vector_to_list, "vector->list", 1, 0, 0, + (SCM v), +"") +#define FUNC_NAME s_scm_vector_to_list { SCM res = SCM_EOL; long i; SCM *data; - SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_to_list); + SCM_VALIDATE_VECTOR(1,v); data = SCM_VELTS(v); for(i = SCM_LENGTH(v)-1;i >= 0;i--) res = scm_cons(data[i], res); return res; } +#undef FUNC_NAME -SCM_PROC (s_vector_fill_x, "vector-fill!", 2, 0, 0, scm_vector_fill_x); - -SCM -scm_vector_fill_x (v, fill_x) - SCM v; - SCM fill_x; +GUILE_PROC (scm_vector_fill_x, "vector-fill!", 2, 0, 0, + (SCM v, SCM fill_x), +"") +#define FUNC_NAME s_scm_vector_fill_x { register long i; register SCM *data; - SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_fill_x); + SCM_VALIDATE_VECTOR(1,v); data = SCM_VELTS(v); for(i = SCM_LENGTH(v) - 1; i >= 0; i--) data[i] = fill_x; return SCM_UNSPECIFIED; } +#undef FUNC_NAME SCM -scm_vector_equal_p(x, y) - SCM x; - SCM y; +scm_vector_equal_p(SCM x, SCM y) { long i; for(i = SCM_LENGTH(x)-1;i >= 0;i--) @@ -268,73 +268,53 @@ scm_vector_equal_p(x, y) } -SCM_PROC (s_vector_move_left_x, "vector-move-left!", 5, 0, 0, scm_vector_move_left_x); - -SCM -scm_vector_move_left_x (vec1, start1, end1, vec2, start2) - SCM vec1; - SCM start1; - SCM end1; - SCM vec2; - SCM start2; +GUILE_PROC (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0, + (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2), + "") +#define FUNC_NAME s_scm_vector_move_left_x { long i; long j; long e; - SCM_ASSERT (SCM_NIMP (vec1) && SCM_VECTORP (vec1), vec1, SCM_ARG1, s_vector_move_left_x); - SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_vector_move_left_x); - SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_vector_move_left_x); - SCM_ASSERT (SCM_NIMP (vec2) && SCM_VECTORP (vec2), vec2, SCM_ARG4, s_vector_move_left_x); - SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_vector_move_left_x); - i = SCM_INUM (start1); - j = SCM_INUM (start2); - e = SCM_INUM (end1); - SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0, start1, SCM_OUTOFRANGE, s_vector_move_left_x); - SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, s_vector_move_left_x); - SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, s_vector_move_left_x); - SCM_ASSERT (e-i+j <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, s_vector_move_left_x); + SCM_VALIDATE_VECTOR(1,vec1); + SCM_VALIDATE_INT_COPY(2,start1,i); + SCM_VALIDATE_INT_COPY(3,end1,e); + SCM_VALIDATE_VECTOR(4,vec2); + SCM_VALIDATE_INT_COPY(5,start2,j); + SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0, start1, SCM_OUTOFRANGE, FUNC_NAME); + SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, FUNC_NAME); + SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, FUNC_NAME); + SCM_ASSERT (e-i+j <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, FUNC_NAME); while (i= 0, - start1, SCM_OUTOFRANGE, s_vector_move_right_x); - SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, - start2, SCM_OUTOFRANGE, s_vector_move_right_x); - SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, - end1, SCM_OUTOFRANGE, s_vector_move_right_x); + SCM_VALIDATE_VECTOR(1,vec1); + SCM_VALIDATE_INT_COPY(2,start1,i); + SCM_VALIDATE_INT_COPY(3,end1,e); + SCM_VALIDATE_VECTOR(4,vec2); + SCM_VALIDATE_INT_COPY(5,start2,j); + SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0, start1, SCM_OUTOFRANGE, FUNC_NAME); + SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, FUNC_NAME); + SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, FUNC_NAME); j = e - i + j; - SCM_ASSERT (j <= SCM_LENGTH (vec2), - start2, SCM_OUTOFRANGE, s_vector_move_right_x); + SCM_ASSERT (j <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, FUNC_NAME); while (i < e) SCM_VELTS (vec2)[--j] = SCM_VELTS (vec1)[--e]; return SCM_UNSPECIFIED; } +#undef FUNC_NAME diff --git a/libguile/version.c b/libguile/version.c index 74aa556e0..2c453b0c5 100644 --- a/libguile/version.c +++ b/libguile/version.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include "_scm.h" @@ -48,33 +52,36 @@ /* Return a Scheme string containing Guile's major version number. */ -SCM_PROC(s_major_version, "major-version", 0, 0, 0, scm_major_version); - -SCM -scm_major_version () +GUILE_PROC(scm_major_version, "major-version", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_major_version { return scm_makfrom0str (GUILE_MAJOR_VERSION); } +#undef FUNC_NAME /* Return a Scheme string containing Guile's minor version number. */ -SCM_PROC(s_minor_version, "minor-version", 0, 0, 0, scm_minor_version); - -SCM -scm_minor_version () +GUILE_PROC(scm_minor_version, "minor-version", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_minor_version { return scm_makfrom0str (GUILE_MINOR_VERSION); } +#undef FUNC_NAME /* Return a Scheme string containing Guile's complete version. */ -SCM_PROC(s_version, "version", 0, 0, 0, scm_version); - -SCM -scm_version () +GUILE_PROC(scm_version, "version", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_version { return scm_makfrom0str (GUILE_VERSION); } +#undef FUNC_NAME diff --git a/libguile/vports.c b/libguile/vports.c index 8d66194a5..3a3169959 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include @@ -46,6 +50,7 @@ #include "chars.h" #include "fports.h" +#include "scm_validate.h" #include "vports.h" #ifdef HAVE_STRING_H @@ -132,17 +137,15 @@ sf_close (SCM port) -SCM_PROC(s_make_soft_port, "make-soft-port", 2, 0, 0, scm_make_soft_port); - -SCM -scm_make_soft_port (pv, modes) - SCM pv; - SCM modes; +GUILE_PROC(scm_make_soft_port, "make-soft-port", 2, 0, 0, + (SCM pv, SCM modes), +"") +#define FUNC_NAME s_scm_make_soft_port { scm_port *pt; SCM z; - SCM_ASSERT (SCM_NIMP (pv) && SCM_VECTORP (pv) && 5 == SCM_LENGTH (pv), pv, SCM_ARG1, s_make_soft_port); - SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_make_soft_port); + SCM_VALIDATE_VECTOR_LEN(1,pv,5); + SCM_VALIDATE_ROSTRING(2,modes); SCM_COERCE_SUBSTR (modes); SCM_NEWCELL (z); SCM_DEFER_INTS; @@ -158,6 +161,7 @@ scm_make_soft_port (pv, modes) SCM_ALLOW_INTS; return z; } +#undef FUNC_NAME void scm_make_sfptob (void); /* Called from ports.c */ diff --git a/libguile/weaks.c b/libguile/weaks.c index aaf246ded..7d88ae4e6 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -38,10 +38,15 @@ * If you write modifications of your own for this library, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include #include "_scm.h" +#include "scm_validate.h" #include "weaks.h" @@ -50,12 +55,10 @@ */ -SCM_PROC(s_make_weak_vector, "make-weak-vector", 1, 1, 0, scm_make_weak_vector); - -SCM -scm_make_weak_vector (k, fill) - SCM k; - SCM fill; +GUILE_PROC(scm_make_weak_vector, "make-weak-vector", 1, 1, 0, + (SCM k, SCM fill), +"") +#define FUNC_NAME s_scm_make_weak_vector { SCM v; v = scm_make_vector (scm_sum (k, SCM_MAKINUM (2)), fill); @@ -67,21 +70,22 @@ scm_make_weak_vector (k, fill) SCM_ALLOW_INTS; return v; } +#undef FUNC_NAME -SCM_PROC(s_weak_vector, "weak-vector", 0, 0, 1, scm_weak_vector); -SCM_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector); +SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector); -SCM -scm_weak_vector (l) - SCM l; +GUILE_PROC(scm_weak_vector, "weak-vector", 0, 0, 1, + (SCM l), +"") +#define FUNC_NAME s_scm_weak_vector { SCM res; register SCM *data; long i; i = scm_ilength (l); - SCM_ASSERT (i >= 0, l, SCM_ARG1, s_weak_vector); + SCM_ASSERT (i >= 0, l, SCM_ARG1, FUNC_NAME); res = scm_make_weak_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED); data = SCM_VELTS (res); for (; @@ -90,18 +94,17 @@ scm_weak_vector (l) *data++ = SCM_CAR (l); return res; } +#undef FUNC_NAME -SCM_PROC(s_weak_vector_p, "weak-vector?", 1, 0, 0, scm_weak_vector_p); - -SCM -scm_weak_vector_p (x) - SCM x; +GUILE_PROC(scm_weak_vector_p, "weak-vector?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_weak_vector_p { - return ((SCM_NIMP (x) && SCM_WVECTP (x) && !SCM_IS_WHVEC (x)) - ? SCM_BOOL_T - : SCM_BOOL_F); + return SCM_BOOL(SCM_NIMP (x) && SCM_WVECTP (x) && !SCM_IS_WHVEC (x)); } +#undef FUNC_NAME @@ -109,88 +112,82 @@ scm_weak_vector_p (x) -SCM_PROC(s_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0, scm_make_weak_key_hash_table); - -SCM -scm_make_weak_key_hash_table (k) - SCM k; +GUILE_PROC(scm_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0, + (SCM k), +"") +#define FUNC_NAME s_scm_make_weak_key_hash_table { SCM v; - SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_weak_key_hash_table); + SCM_VALIDATE_INT(1,k); v = scm_make_weak_vector (k, SCM_EOL); SCM_ALLOW_INTS; SCM_VELTS (v)[-1] = 1; SCM_ALLOW_INTS; return v; } +#undef FUNC_NAME -SCM_PROC (s_make_weak_value_hash_table, "make-weak-value-hash-table", 1, 0, 0, scm_make_weak_value_hash_table); - -SCM -scm_make_weak_value_hash_table (k) - SCM k; +GUILE_PROC (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 1, 0, 0, + (SCM k), +"") +#define FUNC_NAME s_scm_make_weak_value_hash_table { SCM v; - SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_weak_value_hash_table); + SCM_VALIDATE_INT(1,k); v = scm_make_weak_vector (k, SCM_EOL); SCM_ALLOW_INTS; SCM_VELTS (v)[-1] = 2; SCM_ALLOW_INTS; return v; } +#undef FUNC_NAME -SCM_PROC (s_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0, scm_make_doubly_weak_hash_table); - -SCM -scm_make_doubly_weak_hash_table (k) - SCM k; +GUILE_PROC (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0, + (SCM k), +"") +#define FUNC_NAME s_scm_make_doubly_weak_hash_table { SCM v; - SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_doubly_weak_hash_table); + SCM_VALIDATE_INT(1,k); v = scm_make_weak_vector (k, SCM_EOL); SCM_ALLOW_INTS; SCM_VELTS (v)[-1] = 3; SCM_ALLOW_INTS; return v; } +#undef FUNC_NAME -SCM_PROC(s_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, scm_weak_key_hash_table_p); - -SCM -scm_weak_key_hash_table_p (x) - SCM x; +GUILE_PROC(scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, + (SCM x), + "") +#define FUNC_NAME s_scm_weak_key_hash_table_p { - return ((SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC(x)) - ? SCM_BOOL_T - : SCM_BOOL_F); + return SCM_BOOL(SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC(x)); } +#undef FUNC_NAME -SCM_PROC (s_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, scm_weak_value_hash_table_p); - -SCM -scm_weak_value_hash_table_p (x) - SCM x; +GUILE_PROC (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_weak_value_hash_table_p { - return ((SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC_V(x)) - ? SCM_BOOL_T - : SCM_BOOL_F); + return SCM_BOOL(SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC_V(x)); } +#undef FUNC_NAME -SCM_PROC (s_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, scm_doubly_weak_hash_table_p); - -SCM -scm_doubly_weak_hash_table_p (x) - SCM x; +GUILE_PROC (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_doubly_weak_hash_table_p { - return ((SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC_B (x)) - ? SCM_BOOL_T - : SCM_BOOL_F); + return SCM_BOOL(SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC_B (x)); } +#undef FUNC_NAME -- 2.20.1