diff options
78 files changed, 5262 insertions, 6033 deletions
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 <gjb@cs.washington.edu> + + * 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 <Greg.Harvey@thezone.net> (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 <gjb@cs.washington.edu> * 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 <stdio.h> #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 <stdio.h> @@ -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 ("#<arbiter ", port); if (SCM_CAR (exp) & (1L << 16)) @@ -72,22 +74,21 @@ prinarb (exp, port, pstate) return !0; } -SCM_PROC(s_make_arbiter, "make-arbiter", 1, 0, 0, scm_make_arbiter); - -SCM -scm_make_arbiter (name) - SCM name; +GUILE_PROC(scm_make_arbiter, "make-arbiter", 1, 0, 0, + (SCM name), +"") +#define FUNC_NAME s_scm_make_arbiter { SCM_RETURN_NEWSMOB (scm_tc16_arbiter, name); } +#undef FUNC_NAME -SCM_PROC(s_try_arbiter, "try-arbiter", 1, 0, 0, scm_try_arbiter); - -SCM -scm_try_arbiter (arb) - SCM arb; +GUILE_PROC(scm_try_arbiter, "try-arbiter", 1, 0, 0, + (SCM arb), +"") +#define FUNC_NAME s_scm_try_arbiter { - SCM_ASSERT ((SCM_TYP16 (arb) == scm_tc16_arbiter), arb, SCM_ARG1, s_try_arbiter); + SCM_VALIDATE_SMOB(1,arb,arbiter); SCM_DEFER_INTS; if (SCM_CAR (arb) & (1L << 16)) arb = SCM_BOOL_F; @@ -99,20 +100,21 @@ scm_try_arbiter (arb) SCM_ALLOW_INTS; return arb; } +#undef FUNC_NAME -SCM_PROC(s_release_arbiter, "release-arbiter", 1, 0, 0, scm_release_arbiter); - -SCM -scm_release_arbiter (arb) - SCM arb; +GUILE_PROC(scm_release_arbiter, "release-arbiter", 1, 0, 0, + (SCM arb), +"") +#define FUNC_NAME s_scm_release_arbiter { - SCM_ASSERT ((SCM_TYP16 (arb) == scm_tc16_arbiter), arb, SCM_ARG1, s_release_arbiter); + SCM_VALIDATE_SMOB(1,arb,arbiter); if (!(SCM_CAR (arb) & (1L << 16))) return SCM_BOOL_F; SCM_SETCAR (arb, scm_tc16_arbiter); return SCM_BOOL_T; } +#undef FUNC_NAME diff --git a/libguile/async.c b/libguile/async.c index cd0a0c68b..f53354dd7 100644 --- a/libguile/async.c +++ b/libguile/async.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 <stdio.h> @@ -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 <stdio.h> #include <ctype.h> @@ -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 <stdio.h> #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 <stdio.h> #include <ctype.h> #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_less_p); - -SCM -scm_char_less_p(x, y) - SCM x; - SCM y; +GUILE_PROC1 (scm_char_less_p, "char<?", scm_tc7_rpsubr, + (SCM x, SCM y), +"Return #t iff X is less than Y in the Ascii sequence, else #f.") +#define FUNC_NAME s_scm_char_less_p { - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_less_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_less_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_leq_p, "char<=?", scm_tc7_rpsubr, scm_char_leq_p); - -SCM -scm_char_leq_p(x, y) - SCM x; - SCM y; +GUILE_PROC1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr, + (SCM x, SCM y), +"Return #t iff X is less than or equal to Y in the Ascii sequence, else #f.") +#define FUNC_NAME s_scm_char_leq_p { - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_leq_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_leq_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_gr_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_less_p); - -SCM -scm_char_ci_less_p(x, y) - SCM x; - SCM y; +GUILE_PROC1 (scm_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr, + (SCM x, SCM y), +"Return #t iff X is less than Y in the Ascii sequence ignoring case, else #f.") +#define FUNC_NAME s_scm_char_ci_less_p { - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_less_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_less_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_leq_p, "char-ci<=?", scm_tc7_rpsubr, scm_char_ci_leq_p); - -SCM -scm_char_ci_leq_p(x, y) - SCM x; - SCM y; +GUILE_PROC1 (scm_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr, + (SCM x, SCM y), +"Return #t iff X is less than or equal to Y in the Ascii sequence ignoring case, else #f.") +#define FUNC_NAME s_scm_char_ci_leq_p { - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_leq_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_leq_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_gr_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 <stdio.h> @@ -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 <stdio.h> #include "_scm.h" #include "eval.h" @@ -61,29 +65,29 @@ #include "dynwind.h" #include "modules.h" +#include "scm_validate.h" #include "debug.h" /* {Run time control of the debugging evaluator} */ -SCM_PROC (s_debug_options, "debug-options-interface", 0, 1, 0, scm_debug_options); - -SCM -scm_debug_options (setting) - SCM setting; +GUILE_PROC (scm_debug_options, "debug-options-interface", 0, 1, 0, + (SCM setting), +"") +#define FUNC_NAME s_scm_debug_options { SCM ans; SCM_DEFER_INTS; ans = scm_options (setting, scm_debug_opts, SCM_N_DEBUG_OPTIONS, - s_debug_options); + FUNC_NAME); #ifndef SCM_RECKLESS if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE)) { - scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, s_debug_options); - scm_out_of_range (s_debug_options, setting); + scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME); + scm_out_of_range (FUNC_NAME, setting); } #endif SCM_RESET_DEBUG_MODE; @@ -92,8 +96,7 @@ scm_debug_options (setting) SCM_ALLOW_INTS; return ans; } - -SCM_PROC (s_with_traps, "with-traps", 1, 0, 0, scm_with_traps); +#undef FUNC_NAME static void with_traps_before (void *data) @@ -117,20 +120,20 @@ with_traps_inner (void *data) return scm_apply (thunk, SCM_EOL, SCM_EOL); } -SCM -scm_with_traps (SCM thunk) +GUILE_PROC (scm_with_traps, "with-traps", 1, 0, 0, + (SCM thunk), +"") +#define FUNC_NAME s_scm_with_traps { int trap_flag; - SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)), - thunk, - SCM_ARG1, - s_with_traps); + SCM_VALIDATE_THUNK(1,thunk); return scm_internal_dynamic_wind (with_traps_before, with_traps_inner, with_traps_after, (void *) thunk, &trap_flag); } +#undef FUNC_NAME static SCM scm_sym_source, scm_sym_dots; @@ -142,13 +145,8 @@ static SCM scm_sym_procname; long scm_tc16_memoized; -static int prinmemoized SCM_P ((SCM obj, SCM port, scm_print_state *pstate)); - static int -prinmemoized (obj, port, pstate) - SCM obj; - SCM port; - scm_print_state *pstate; +prinmemoized (SCM obj,SCM port,scm_print_state *pstate) { int writingp = SCM_WRITINGP (pstate); scm_puts ("#<memoized ", port); @@ -163,19 +161,17 @@ prinmemoized (obj, port, pstate) return 1; } -SCM_PROC (s_memoized_p, "memoized?", 1, 0, 0, scm_memoized_p); - -SCM -scm_memoized_p (obj) - SCM obj; +GUILE_PROC (scm_memoized_p, "memoized?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_memoized_p { - return SCM_NIMP (obj) && SCM_MEMOIZEDP (obj) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(SCM_NIMP (obj) && SCM_MEMOIZEDP (obj)); } +#undef FUNC_NAME SCM -scm_make_memoized (exp, env) - SCM exp; - SCM env; +scm_make_memoized (SCM exp, SCM env) { /* *fixme* Check that env is a valid environment. */ register SCM z, ans; @@ -254,77 +250,63 @@ scm_make_memoized (exp, env) #include "variable.h" #include "procs.h" -SCM_PROC (s_make_gloc, "make-gloc", 1, 1, 0, scm_make_gloc); - -SCM -scm_make_gloc (var, env) - SCM var; - SCM env; +GUILE_PROC (scm_make_gloc, "make-gloc", 1, 1, 0, + (SCM var, SCM env), +"") +#define FUNC_NAME s_scm_make_gloc { #if 1 /* Unsafe */ if (SCM_NIMP (var) && SCM_CONSP (var)) var = scm_cons (SCM_BOOL_F, var); else #endif - SCM_ASSERT (SCM_NIMP (var) && SCM_VARIABLEP (var), - var, - SCM_ARG1, - s_make_gloc); + SCM_VALIDATE_VARIABLE(1,var); if (SCM_UNBNDP (env)) env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var)); else - SCM_ASSERT (SCM_NULLP (env) || (SCM_NIMP (env) && SCM_CONSP (env)), - env, - SCM_ARG2, - s_make_gloc); + SCM_VALIDATE_NULLORCONS(2,env); return scm_make_memoized (SCM_VARVCELL (var) + 1, env); } +#undef FUNC_NAME -SCM_PROC (s_gloc_p, "gloc?", 1, 0, 0, scm_gloc_p); - -SCM -scm_gloc_p (obj) - SCM obj; +GUILE_PROC (scm_gloc_p, "gloc?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_gloc_p { - return ((SCM_NIMP (obj) - && SCM_MEMOIZEDP (obj) - && (SCM_MEMOIZED_EXP (obj) & 7) == 1) - ? SCM_BOOL_T - : SCM_BOOL_F); + return SCM_BOOL((SCM_NIMP (obj) + && SCM_MEMOIZEDP (obj) + && (SCM_MEMOIZED_EXP (obj) & 7) == 1)); } +#undef FUNC_NAME -SCM_PROC (s_make_iloc, "make-iloc", 3, 0, 0, scm_make_iloc); - -SCM -scm_make_iloc (frame, binding, cdrp) - SCM frame; - SCM binding; - SCM cdrp; +GUILE_PROC (scm_make_iloc, "make-iloc", 3, 0, 0, + (SCM frame, SCM binding, SCM cdrp), +"") +#define FUNC_NAME s_scm_make_iloc { - SCM_ASSERT (SCM_INUMP (frame), frame, SCM_ARG1, s_make_iloc); - SCM_ASSERT (SCM_INUMP (binding), binding, SCM_ARG2, s_make_iloc); + SCM_VALIDATE_INT(1,frame); + SCM_VALIDATE_INT(2,binding) return (SCM_ILOC00 + SCM_IFRINC * SCM_INUM (frame) + (SCM_NFALSEP (cdrp) ? SCM_ICDR : 0) + SCM_IDINC * SCM_INUM (binding)); } +#undef FUNC_NAME -SCM_PROC (s_iloc_p, "iloc?", 1, 0, 0, scm_iloc_p); - -SCM -scm_iloc_p (obj) - SCM obj; +GUILE_PROC (scm_iloc_p, "iloc?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_iGUILE_p { - return SCM_ILOCP (obj) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(SCM_ILOCP (obj)); } +#undef FUNC_NAME -SCM_PROC (s_memcons, "memcons", 2, 1, 0, scm_memcons); - -SCM -scm_memcons (car, cdr, env) - SCM car; - SCM cdr; - SCM env; +GUILE_PROC (scm_memcons, "memcons", 2, 1, 0, + (SCM car, SCM cdr, SCM env), +"") +#define FUNC_NAME s_scm_memcons { if (SCM_NIMP (car) && SCM_MEMOIZEDP (car)) { @@ -356,18 +338,15 @@ scm_memcons (car, cdr, env) s_make_iloc); return scm_make_memoized (scm_cons (car, cdr), env); } +#undef FUNC_NAME -SCM_PROC (s_mem_to_proc, "mem->proc", 1, 0, 0, scm_mem_to_proc); - -SCM -scm_mem_to_proc (obj) - SCM obj; +GUILE_PROC (scm_mem_to_proc, "mem->proc", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_mem_to_proc { SCM env; - SCM_ASSERT (SCM_NIMP (obj) && SCM_MEMOIZEDP (obj), - obj, - SCM_ARG1, - s_mem_to_proc); + SCM_VALIDATE_MEMOIZED(1,obj); env = SCM_MEMOIZED_ENV (obj); obj = SCM_MEMOIZED_EXP (obj); if (!(SCM_NIMP (obj) && SCM_CAR (obj) == SCM_IM_LAMBDA)) @@ -376,53 +355,47 @@ scm_mem_to_proc (obj) scm_cons (obj, SCM_EOL)); return scm_closure (SCM_CDR (obj), env); } +#undef FUNC_NAME -SCM_PROC (s_proc_to_mem, "proc->mem", 1, 0, 0, scm_proc_to_mem); - -SCM -scm_proc_to_mem (obj) - SCM obj; +GUILE_PROC (scm_proc_to_mem, "proc->mem", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_proc_to_mem { - SCM_ASSERT (SCM_NIMP (obj) && SCM_CLOSUREP (obj), - obj, - SCM_ARG1, - s_proc_to_mem); + SCM_VALIDATE_CLOSURE(1,obj) return scm_make_memoized (scm_cons (SCM_IM_LAMBDA, SCM_CODE (obj)), SCM_ENV (obj)); } +#undef FUNC_NAME #endif /* GUILE_DEBUG */ -SCM_PROC (s_unmemoize, "unmemoize", 1, 0, 0, scm_unmemoize); - -SCM -scm_unmemoize (m) - SCM m; +GUILE_PROC (scm_unmemoize, "unmemoize", 1, 0, 0, + (SCM m), +"") +#define FUNC_NAME s_scm_unmemoize { - SCM_ASSERT (SCM_NIMP (m) && SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize); + SCM_VALIDATE_MEMOIZED(1,m); return scm_unmemocopy (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m)); } +#undef FUNC_NAME -SCM_PROC (s_memoized_environment, "memoized-environment", 1, 0, 0, scm_memoized_environment); - -SCM -scm_memoized_environment (m) - SCM m; +GUILE_PROC (scm_memoized_environment, "memoized-environment", 1, 0, 0, + (SCM m), +"") +#define FUNC_NAME s_scm_memoized_environment { - SCM_ASSERT (SCM_NIMP (m) && SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize); + SCM_VALIDATE_MEMOIZED(1,m); return SCM_MEMOIZED_ENV (m); } +#undef FUNC_NAME -SCM_PROC (s_procedure_name, "procedure-name", 1, 0, 0, scm_procedure_name); - -SCM -scm_procedure_name (proc) - SCM proc; +GUILE_PROC (scm_procedure_name, "procedure-name", 1, 0, 0, + (SCM proc), +"") +#define FUNC_NAME s_scm_procedure_name { - SCM_ASSERT(scm_procedure_p (proc) == SCM_BOOL_T, - proc, - SCM_ARG1, - s_procedure_name); + SCM_VALIDATE_PROC(1,proc); switch (SCM_TYP7 (proc)) { case scm_tcs_subrs: return SCM_SNAME (proc); @@ -441,14 +414,14 @@ scm_procedure_name (proc) } } } +#undef FUNC_NAME -SCM_PROC (s_procedure_source, "procedure-source", 1, 0, 0, scm_procedure_source); - -SCM -scm_procedure_source (proc) - SCM proc; +GUILE_PROC (scm_procedure_source, "procedure-source", 1, 0, 0, + (SCM proc), +"") +#define FUNC_NAME s_scm_procedure_source { - SCM_ASSERT(SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_source); + SCM_VALIDATE_NIMP(1,proc); switch (SCM_TYP7 (proc)) { case scm_tcs_closures: { @@ -472,18 +445,18 @@ scm_procedure_source (proc) built in procedures! */ return scm_procedure_property (proc, scm_sym_source); default: - scm_wta (proc, (char *) SCM_ARG1, s_procedure_source); + SCM_WTA(1,proc); return 0; } } +#undef FUNC_NAME -SCM_PROC (s_procedure_environment, "procedure-environment", 1, 0, 0, scm_procedure_environment); - -SCM -scm_procedure_environment (proc) - SCM proc; +GUILE_PROC (scm_procedure_environment, "procedure-environment", 1, 0, 0, + (SCM proc), +"") +#define FUNC_NAME s_scm_procedure_environment { - SCM_ASSERT (SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_environment); + SCM_VALIDATE_NIMP(1,proc); switch (SCM_TYP7 (proc)) { case scm_tcs_closures: return SCM_ENV (proc); @@ -494,10 +467,11 @@ scm_procedure_environment (proc) #endif return SCM_EOL; default: - scm_wta (proc, (char *) SCM_ARG1, s_procedure_environment); + SCM_WTA(1,proc); return 0; } } +#undef FUNC_NAME @@ -507,23 +481,22 @@ scm_procedure_environment (proc) * the code before evaluating. One solution would be to have eval.c * generate yet another evaluator. They are not very big actually. */ -SCM_PROC (s_local_eval, "local-eval", 1, 1, 0, scm_local_eval); - -SCM -scm_local_eval (exp, env) - SCM exp; - SCM env; +GUILE_PROC (scm_local_eval, "local-eval", 1, 1, 0, + (SCM exp, SCM env), +"") +#define FUNC_NAME s_scm_local_eval { if (SCM_UNBNDP (env)) { - SCM_ASSERT (SCM_NIMP (exp) && SCM_MEMOIZEDP (exp), exp, SCM_ARG1, s_local_eval); + SCM_VALIDATE_MEMOIZED(1,exp); return scm_eval_3 (SCM_MEMOIZED_EXP (exp), 0, SCM_MEMOIZED_ENV (exp)); } return scm_eval_3 (exp, 1, env); } +#undef FUNC_NAME #if 0 -SCM_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup); +SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup); #endif SCM @@ -593,13 +566,8 @@ scm_m_start_stack (exp, env) long scm_tc16_debugobj; -static int prindebugobj SCM_P ((SCM obj, SCM port, scm_print_state *pstate)); - static int -prindebugobj (obj, port, pstate) - SCM obj; - SCM port; - scm_print_state *pstate; +prindebugobj (SCM obj,SCM port,scm_print_state *pstate) { scm_puts ("#<debug-object ", port); scm_intprint (SCM_DEBUGOBJ_FRAME (obj), 16, port); @@ -607,19 +575,18 @@ prindebugobj (obj, port, pstate) return 1; } -SCM_PROC (s_debug_object_p, "debug-object?", 1, 0, 0, scm_debug_object_p); - -SCM -scm_debug_object_p (obj) - SCM obj; +GUILE_PROC (scm_debug_object_p, "debug-object?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_debug_object_p { - return SCM_NIMP (obj) && SCM_DEBUGOBJP (obj) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(SCM_NIMP (obj) && SCM_DEBUGOBJP (obj)); } +#undef FUNC_NAME SCM -scm_make_debugobj (frame) - scm_debug_frame *frame; +scm_make_debugobj (scm_debug_frame *frame) { register SCM z; SCM_NEWCELL (z); @@ -634,16 +601,16 @@ scm_make_debugobj (frame) /* Undocumented debugging procedure */ #ifdef GUILE_DEBUG -SCM_PROC (s_debug_hang, "debug-hang", 0, 1, 0, scm_debug_hang); - -SCM -scm_debug_hang (obj) - SCM obj; +GUILE_PROC (scm_debug_hang, "debug-hang", 0, 1, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_debug_hang { int go = 0; while (!go) ; return SCM_UNSPECIFIED; } +#undef FUNC_NAME #endif diff --git a/libguile/dynl-dl.c b/libguile/dynl-dl.c index cbefefe10..e69de29bb 100644 --- a/libguile/dynl-dl.c +++ b/libguile/dynl-dl.c @@ -1,122 +0,0 @@ -/* dynl-dl.c - dynamic linking for dlopen/dlsym - * - * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 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 - * 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 <dlfcn.h> - -#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 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 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 <stdio.h> -#include <string.h> - -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; i<status; ++i) { - if (strcmp(symb, sym[i].name) == 0) return sym[i].value; - } - - SCM_ALLOW_INTS; - scm_misc_error (subr, "undefined function", - scm_cons (scm_makfrom0str (symb), SCM_EOL)); -} - -static void -sysdep_dynl_init () -{ -} diff --git a/libguile/dynl.c b/libguile/dynl.c index 79345de8e..55a95dec4 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -41,6 +41,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 */ + + /* "dynl.c" dynamically link&load object files. Author: Aubrey Jaffer Modified for libguile by Marius Vollmer */ @@ -75,15 +79,8 @@ maybe_drag_in_eprintf () This code probably belongs into strings.c */ -static char **scm_make_argv_from_stringlist SCM_P ((SCM args, int *argcp, - const char *subr, int argn)); - static char ** -scm_make_argv_from_stringlist (args, argcp, subr, argn) - SCM args; - int *argcp; - const char *subr; - int argn; +scm_make_argv_from_stringlist (SCM args,int *argcp,const char *subr,int argn) { char **argv; int argc, i; @@ -110,11 +107,8 @@ scm_make_argv_from_stringlist (args, argcp, subr, argn) return argv; } -static void scm_must_free_argv SCM_P ((char **argv)); - static void -scm_must_free_argv(argv) - char **argv; +scm_must_free_argv(char **argv) { char **av = argv; while (*av) @@ -125,13 +119,8 @@ scm_must_free_argv(argv) /* Coerce an arbitrary readonly-string into a zero-terminated string. */ -static SCM scm_coerce_rostring SCM_P ((SCM rostr, const char *subr, int argn)); - static SCM -scm_coerce_rostring (rostr, subr, argn) - SCM rostr; - const char *subr; - int argn; +scm_coerce_rostring (SCM rostr,const char *subr,int argn) { SCM_ASSERT (SCM_NIMP (rostr) && SCM_ROSTRINGP (rostr), rostr, argn, subr); if (SCM_SUBSTRP (rostr)) @@ -184,10 +173,10 @@ scm_register_module_xxx (module_name, init_func) registered_mods = md; } -SCM_PROC (s_registered_modules, "c-registered-modules", 0, 0, 0, scm_registered_modules); - -SCM -scm_registered_modules () +GUILE_PROC (scm_registered_modules, "c-registered-modules", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_registered_modules { SCM res; struct moddata *md; @@ -199,11 +188,12 @@ scm_registered_modules () res); return res; } +#undef FUNC_NAME -SCM_PROC (s_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0, scm_clear_registered_modules); - -SCM -scm_clear_registered_modules () +GUILE_PROC (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_clear_registered_modules { struct moddata *md1, *md2; @@ -218,6 +208,7 @@ scm_clear_registered_modules () SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } +#undef FUNC_NAME /* Dispatch to the system dependent files * @@ -231,13 +222,6 @@ scm_clear_registered_modules () #define DYNL_GLOBAL 0x0001 -static void sysdep_dynl_init SCM_P ((void)); -static void *sysdep_dynl_link SCM_P ((const char *filename, int flags, - const char *subr)); -static void sysdep_dynl_unlink SCM_P ((void *handle, const char *subr)); -static void *sysdep_dynl_func SCM_P ((const char *symbol, void *handle, - const char *subr)); - #ifdef HAVE_DLOPEN #include "dynl-dl.c" #else @@ -251,7 +235,7 @@ static void *sysdep_dynl_func SCM_P ((const char *symbol, void *handle, /* no dynamic linking available, throw errors. */ static void -sysdep_dynl_init () +sysdep_dynl_init (void) { } @@ -298,30 +282,22 @@ struct dynl_obj { void *handle; }; -static SCM mark_dynl_obj SCM_P ((SCM ptr)); static SCM -mark_dynl_obj (ptr) - SCM ptr; +mark_dynl_obj (SCM ptr) { struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (ptr); return d->filename; } -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 ("#<dynamic-object ", port); @@ -335,19 +311,17 @@ print_dynl_obj (exp, port, pstate) static SCM kw_global; SCM_SYMBOL (sym_global, "-global"); -SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 1, scm_dynamic_link); - -SCM -scm_dynamic_link (fname, rest) - SCM fname; - SCM rest; +GUILE_PROC (scm_dynamic_link, "dynamic-link", 1, 0, 1, + (SCM fname, SCM rest), +"") +#define FUNC_NAME s_scm_dynamic_link { SCM z; void *handle; struct dynl_obj *d; int flags = DYNL_GLOBAL; - fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1); + fname = scm_coerce_rostring (fname, FUNC_NAME, SCM_ARG1); /* collect flags */ while (SCM_NIMP (rest) && SCM_CONSP (rest)) @@ -358,7 +332,7 @@ scm_dynamic_link (fname, rest) rest = SCM_CDR (rest); if (!(SCM_NIMP (rest) && SCM_CONSP (rest))) - scm_misc_error (s_dynamic_link, "keyword without value", SCM_EOL); + scm_misc_error (FUNC_NAME, "keyword without value", SCM_EOL); val = SCM_CAR (rest); rest = SCM_CDR (rest); @@ -369,15 +343,15 @@ scm_dynamic_link (fname, rest) flags &= ~DYNL_GLOBAL; } else - scm_misc_error (s_dynamic_link, "unknown keyword argument: %s", + scm_misc_error (FUNC_NAME, "unknown keyword argument: %s", scm_cons (kw, SCM_EOL)); } SCM_DEFER_INTS; - handle = sysdep_dynl_link (SCM_CHARS (fname), flags, s_dynamic_link); + handle = sysdep_dynl_link (SCM_CHARS (fname), flags, FUNC_NAME); d = (struct dynl_obj *)scm_must_malloc (sizeof (struct dynl_obj), - s_dynamic_link); + FUNC_NAME); d->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 <stdio.h> @@ -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 <stdio.h> #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 <stdio.h> @@ -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 ("#<promise ", port); @@ -3799,14 +3778,12 @@ prinprom (exp, port, pstate) } -SCM_PROC(s_force, "force", 1, 0, 0, scm_force); - -SCM -scm_force (x) - SCM x; +GUILE_PROC(scm_force, "force", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_force { - SCM_ASSERT (SCM_NIMP(x) && SCM_TYP16 (x) == scm_tc16_promise, - x, SCM_ARG1, s_force); + SCM_VALIDATE_SMOB(1,x,promise); if (!((1L << 16) & SCM_CAR (x))) { SCM ans = scm_apply (SCM_CDR (x), SCM_EOL, SCM_EOL); @@ -3820,22 +3797,21 @@ scm_force (x) } return SCM_CDR (x); } +#undef FUNC_NAME -SCM_PROC (s_promise_p, "promise?", 1, 0, 0, scm_promise_p); - -SCM -scm_promise_p (x) - SCM x; +GUILE_PROC (scm_promise_p, "promise?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_promise_p { - return ((SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_promise)) - ? SCM_BOOL_T - : SCM_BOOL_F); + return SCM_BOOL(SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_promise)); } +#undef FUNC_NAME -SCM_PROC (s_cons_source, "cons-source", 3, 0, 0, scm_cons_source); - -SCM -scm_cons_source (SCM xorig, SCM x, SCM y) +GUILE_PROC (scm_cons_source, "cons-source", 3, 0, 0, + (SCM xorig, SCM x, SCM y), +"") +#define FUNC_NAME s_scm_cons_source { SCM p, z; SCM_NEWCELL (z); @@ -3847,12 +3823,12 @@ scm_cons_source (SCM xorig, SCM x, SCM y) scm_whash_insert (scm_source_whash, z, p); return z; } +#undef FUNC_NAME -SCM_PROC (s_copy_tree, "copy-tree", 1, 0, 0, scm_copy_tree); - -SCM -scm_copy_tree (obj) - SCM obj; +GUILE_PROC (scm_copy_tree, "copy-tree", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_copy_tree { SCM ans, tl; if (SCM_IMP (obj)) @@ -3880,13 +3856,11 @@ scm_copy_tree (obj) SCM_SETCDR (tl, obj); return ans; } +#undef FUNC_NAME SCM -scm_eval_3 (obj, copyp, env) - SCM obj; - int copyp; - SCM env; +scm_eval_3 (SCM obj, int copyp, SCM env) { if (SCM_NIMP (SCM_CDR (scm_system_transformer))) obj = scm_apply (SCM_CDR (scm_system_transformer), obj, scm_listofnull); @@ -3895,33 +3869,33 @@ scm_eval_3 (obj, copyp, env) return SCM_XEVAL (obj, env); } -SCM_PROC(s_eval2, "eval2", 2, 0, 0, scm_eval2); - -SCM -scm_eval2 (obj, env_thunk) - SCM obj; - SCM env_thunk; +GUILE_PROC(scm_eval2, "eval2", 2, 0, 0, + (SCM obj, SCM env_thunk), +"") +#define FUNC_NAME s_scm_eval2 { return scm_eval_3 (obj, 1, scm_top_level_env (env_thunk)); } +#undef FUNC_NAME -SCM_PROC(s_eval, "eval", 1, 0, 0, scm_eval); - -SCM -scm_eval (obj) - SCM obj; +GUILE_PROC(scm_eval, "eval", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_eval { return scm_eval_3 (obj, 1, scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var))); } +#undef FUNC_NAME -/* SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x); */ +/* +SCM_REGISTER_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x); +*/ SCM -scm_eval_x (obj) - SCM obj; +scm_eval_x (SCM obj) { return scm_eval_3 (obj, 0, diff --git a/libguile/evalext.c b/libguile/evalext.c index f53c9b24e..0831c6516 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.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 "macros.h" #include "modules.h" +#include "scm_validate.h" #include "evalext.h" SCM_SYMBOL (scm_sym_setter, "setter"); @@ -62,14 +67,14 @@ scm_m_generalized_set_x (SCM xorig, SCM env) return scm_wta (xorig, scm_s_variable, scm_s_set_x); } -SCM_PROC (s_definedp, "defined?", 1, 1, 0, scm_definedp); - -SCM -scm_definedp (SCM sym, SCM env) +GUILE_PROC (scm_definedp, "defined?", 1, 1, 0, + (SCM sym, SCM env), +"") +#define FUNC_NAME s_scm_definedp { SCM vcell; - SCM_ASSERT (SCM_NIMP (sym) && SCM_SYMBOLP (sym), sym, SCM_ARG1, s_definedp); + SCM_VALIDATE_SYMBOL(1,sym); if (SCM_UNBNDP (env)) vcell = scm_sym2vcell(sym, @@ -81,12 +86,12 @@ scm_definedp (SCM sym, SCM env) register SCM b; for (; SCM_NIMP (frames); frames = SCM_CDR (frames)) { - SCM_ASSERT (SCM_CONSP (frames), env, SCM_ARG2, s_definedp); + SCM_ASSERT (SCM_CONSP (frames), env, SCM_ARG2, FUNC_NAME); b = SCM_CAR (frames); if (SCM_NFALSEP (scm_procedure_p (b))) break; SCM_ASSERT (SCM_NIMP (b) && SCM_CONSP (b), - env, SCM_ARG2, s_definedp); + env, SCM_ARG2, FUNC_NAME); for (b = SCM_CAR (b); SCM_NIMP (b); b = SCM_CDR (b)) { if (SCM_NCONSP (b)) @@ -109,6 +114,7 @@ scm_definedp (SCM sym, SCM env) ? SCM_BOOL_F : SCM_BOOL_T); } +#undef FUNC_NAME SCM_SYNTAX (s_undefine, "undefine", scm_makacro, scm_m_undefine); @@ -145,9 +151,9 @@ scm_m_undefine (x, env) } /* This name is obsolete. Will be removed in 1.5. */ -SCM_PROC (s_serial_map, "serial-map", 2, 0, 1, scm_map); +SCM_REGISTER_PROC (s_serial_map, "serial-map", 2, 0, 1, scm_map); -SCM_PROC (s_map_in_order, "map-in-order", 2, 0, 1, scm_map); +SCM_REGISTER_PROC (s_map_in_order, "map-in-order", 2, 0, 1, scm_map); void scm_init_evalext () diff --git a/libguile/feature.c b/libguile/feature.c index a0ccc511e..588ffff0d 100644 --- a/libguile/feature.c +++ b/libguile/feature.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 <stdio.h> @@ -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 <stdio.h> #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 ("#<fluid ", port); scm_intprint (SCM_FLUID_NUM (exp), 10, port); @@ -121,10 +119,10 @@ int next_fluid_num () return n; } -SCM_PROC (s_make_fluid, "make-fluid", 0, 0, 0, scm_make_fluid); - -SCM -scm_make_fluid () +GUILE_PROC (scm_make_fluid, "make-fluid", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_make_fluid { int n; @@ -132,25 +130,25 @@ scm_make_fluid () n = next_fluid_num (); SCM_RETURN_NEWSMOB (scm_tc16_fluid, n); } +#undef FUNC_NAME -SCM_PROC (s_fluid_p, "fluid?", 1, 0, 0, scm_fluid_p); - -SCM -scm_fluid_p (fl) - SCM fl; +GUILE_PROC (scm_fluid_p, "fluid?", 1, 0, 0, + (SCM fl), +"") +#define FUNC_NAME s_scm_fluid_p { - return (SCM_NIMP (fl) && SCM_FLUIDP (fl))? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(SCM_NIMP (fl) && SCM_FLUIDP (fl)); } +#undef FUNC_NAME -SCM_PROC (s_fluid_ref, "fluid-ref", 1, 0, 0, scm_fluid_ref); - -SCM -scm_fluid_ref (fl) - SCM fl; +GUILE_PROC (scm_fluid_ref, "fluid-ref", 1, 0, 0, + (SCM fl), +"") +#define FUNC_NAME s_scm_fluid_ref { int n; - SCM_ASSERT (SCM_NIMP (fl) && SCM_FLUIDP (fl), fl, SCM_ARG1, s_fluid_ref); + SCM_VALIDATE_FLUID(1,fl); n = SCM_FLUID_NUM (fl); @@ -158,18 +156,16 @@ scm_fluid_ref (fl) grow_fluids (scm_root, n+1); return SCM_VELTS(scm_root->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 <stdio.h> #include <fcntl.h> #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 <stdio.h> #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 <stdio.h> @@ -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 <stdio.h> @@ -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 <stdio.h> #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 <stdio.h> @@ -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 <fcntl.h> @@ -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 <stdio.h> @@ -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 <stdio.h> #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 <stdio.h> @@ -50,6 +54,7 @@ #include "alist.h" #include "dynwind.h" +#include "scm_validate.h" #include "load.h" #include <sys/types.h> @@ -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 <stdio.h> @@ -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("#<malloc ", port); scm_intprint(SCM_CDR(exp), 16, port); diff --git a/libguile/net_db.c b/libguile/net_db.c index 96253a957..4afc6d21c 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -40,6 +40,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 1994 by Aubrey Jaffer. * Thanks to Hallvard.Tretteberg@si.sintef.no for inspiration and discussion. * Rewritten by Gary Houston to be a closer interface to the C socket library. @@ -51,6 +55,7 @@ #include "_scm.h" #include "feature.h" +#include "scm_validate.h" #include "net_db.h" #ifdef HAVE_STRING_H @@ -77,81 +82,80 @@ int close (); extern int inet_aton (); -SCM_PROC (s_inet_aton, "inet-aton", 1, 0, 0, scm_inet_aton); - -SCM -scm_inet_aton (address) - SCM address; +GUILE_PROC (scm_inet_aton, "inet-aton", 1, 0, 0, + (SCM address), +"") +#define FUNC_NAME s_scm_inet_aton { struct in_addr soka; - SCM_ASSERT (SCM_NIMP (address) && SCM_ROSTRINGP (address), address, SCM_ARG1, s_inet_aton); + SCM_VALIDATE_ROSTRING(1,address); if (SCM_SUBSTRP (address)) address = scm_makfromstr (SCM_ROCHARS (address), SCM_ROLENGTH (address), 0); if (inet_aton (SCM_ROCHARS (address), &soka) == 0) - scm_misc_error (s_inet_aton, "bad address", SCM_EOL); + SCM_MISC_ERROR ("bad address", SCM_EOL); return scm_ulong2num (ntohl (soka.s_addr)); } +#undef FUNC_NAME -SCM_PROC (s_inet_ntoa, "inet-ntoa", 1, 0, 0, scm_inet_ntoa); - -SCM -scm_inet_ntoa (inetid) - SCM inetid; +GUILE_PROC (scm_inet_ntoa, "inet-ntoa", 1, 0, 0, + (SCM inetid), +"") +#define FUNC_NAME s_scm_inet_ntoa { struct in_addr addr; char *s; SCM answer; - addr.s_addr = htonl (scm_num2ulong (inetid, (char *) SCM_ARG1, s_inet_ntoa)); + addr.s_addr = htonl (SCM_NUM2ULONG (1,inetid)); s = inet_ntoa (addr); answer = scm_makfromstr (s, strlen (s), 0); return answer; } +#undef FUNC_NAME #ifdef HAVE_INET_NETOF -SCM_PROC (s_inet_netof, "inet-netof", 1, 0, 0, scm_inet_netof); - -SCM -scm_inet_netof (address) - SCM address; +GUILE_PROC (scm_inet_netof, "inet-netof", 1, 0, 0, + (SCM address), +"") +#define FUNC_NAME s_scm_inet_netof { struct in_addr addr; - addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_inet_netof)); + addr.s_addr = htonl (SCM_NUM2ULONG (1,address)); return scm_ulong2num ((unsigned long) inet_netof (addr)); } +#undef FUNC_NAME #endif #ifdef HAVE_INET_LNAOF -SCM_PROC (s_lnaof, "inet-lnaof", 1, 0, 0, scm_lnaof); - -SCM -scm_lnaof (address) - SCM address; +GUILE_PROC (scm_lnaof, "inet-lnaof", 1, 0, 0, + (SCM address), +"") +#define FUNC_NAME s_scm_lnaof { struct in_addr addr; - addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_lnaof)); + addr.s_addr = htonl (SCM_NUM2ULONG (1,address)); return scm_ulong2num ((unsigned long) inet_lnaof (addr)); } +#undef FUNC_NAME #endif #ifdef HAVE_INET_MAKEADDR -SCM_PROC (s_inet_makeaddr, "inet-makeaddr", 2, 0, 0, scm_inet_makeaddr); - -SCM -scm_inet_makeaddr (net, lna) - SCM net; - SCM lna; +GUILE_PROC (scm_inet_makeaddr, "inet-makeaddr", 2, 0, 0, + (SCM net, SCM lna), +"") +#define FUNC_NAME s_scm_inet_makeaddr { struct in_addr addr; unsigned long netnum; unsigned long lnanum; - netnum = scm_num2ulong (net, (char *) SCM_ARG1, s_inet_makeaddr); - lnanum = scm_num2ulong (lna, (char *) SCM_ARG2, s_inet_makeaddr); + SCM_VALIDATE_INT_COPY(1,net,netnum); + SCM_VALIDATE_INT_COPY(2,lna,lnanum); addr = inet_makeaddr (netnum, lnanum); return scm_ulong2num (ntohl (addr.s_addr)); } +#undef FUNC_NAME #endif SCM_SYMBOL (scm_host_not_found_key, "host-not-found"); @@ -205,11 +209,10 @@ static void scm_resolv_error (const char *subr, SCM bad_value) Should use reentrant facilities if available. */ -SCM_PROC (s_gethost, "gethost", 0, 1, 0, scm_gethost); - -SCM -scm_gethost (name) - SCM name; +GUILE_PROC (scm_gethost, "gethost", 0, 1, 0, + (SCM name), +"") +#define FUNC_NAME s_scm_gethost { SCM ans = scm_make_vector (SCM_MAKINUM (5), SCM_UNSPECIFIED); SCM *ve = SCM_VELTS (ans); @@ -243,11 +246,11 @@ scm_gethost (name) } else { - inad.s_addr = htonl (scm_num2ulong (name, (char *) SCM_ARG1, s_gethost)); + inad.s_addr = htonl (scm_num2ulong (name, (char *) SCM_ARG1, FUNC_NAME)); entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET); } if (!entry) - scm_resolv_error (s_gethost, name); + scm_resolv_error (FUNC_NAME, name); ve[0] = scm_makfromstr (entry->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 <stdio.h> @@ -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 <stdio.h> @@ -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 <stdio.h> #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 <stdio.h> @@ -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 <stdio.h> @@ -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 ("#<unknown-", port); scm_puts (hdr, port); @@ -794,12 +780,7 @@ scm_ipruk (hdr, ptr, port) void -scm_iprlist (hdr, exp, tlr, port, pstate) - char *hdr; - SCM exp; - int tlr; - SCM port; - scm_print_state *pstate; +scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) { register SCM hare, tortoise; int floor = pstate->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 <stdio.h> @@ -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 <stdio.h> @@ -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 <djurfeldt@nada.kth.se> */ #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 <stdio.h> @@ -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 <stdio.h> @@ -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 ("#<root ", port); scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> 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 <stdio.h> @@ -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 <stdio.h> #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 <stdio.h> @@ -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 <stdio.h> @@ -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 <orre@nada.kth.se> * 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 <stdio.h> @@ -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 ("#<srcprops ", port); @@ -124,12 +118,7 @@ prinsrcprops (obj, port, pstate) SCM -scm_make_srcprops (line, col, filename, copy, plist) - int line; - int col; - SCM filename; - SCM copy; - SCM plist; +scm_make_srcprops (int line, int col, SCM filename, SCM copy, SCM plist) { register scm_srcprops *ptr; SCM_DEFER_INTS; @@ -161,8 +150,7 @@ scm_make_srcprops (line, col, filename, copy, plist) SCM -scm_srcprops_to_plist (obj) - SCM obj; +scm_srcprops_to_plist (SCM obj) { SCM plist = SRCPROPPLIST (obj); if (!SCM_UNBNDP (SRCPROPCOPY (obj))) @@ -175,62 +163,59 @@ scm_srcprops_to_plist (obj) return plist; } -SCM_PROC (s_source_properties, "source-properties", 1, 0, 0, scm_source_properties); - -SCM -scm_source_properties (obj) - SCM obj; +GUILE_PROC (scm_source_properties, "source-properties", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_source_properties { SCM p; - SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_source_properties); + SCM_VALIDATE_NIMP(1,obj); if (SCM_MEMOIZEDP (obj)) obj = SCM_MEMOIZED_EXP (obj); #ifndef SCM_RECKLESS else if (SCM_NCONSP (obj)) - scm_wrong_type_arg (s_source_properties, 1, obj); + SCM_WRONG_TYPE_ARG (1, obj); #endif p = scm_hashq_ref (scm_source_whash, obj, (SCM) NULL); if (p != (SCM) NULL && SRCPROPSP (p)) return scm_srcprops_to_plist (p); return SCM_EOL; } +#undef FUNC_NAME /* Perhaps this procedure should look through an alist and try to make a srcprops-object...? */ -SCM_PROC (s_set_source_properties_x, "set-source-properties!", 2, 0, 0, scm_set_source_properties_x); - -SCM -scm_set_source_properties_x (obj, plist) - SCM obj; - SCM plist; +GUILE_PROC (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0, + (SCM obj, SCM plist), +"") +#define FUNC_NAME s_scm_set_source_properties_x { SCM handle; - SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_set_source_properties_x); + SCM_VALIDATE_NIMP(1,obj); if (SCM_MEMOIZEDP (obj)) obj = SCM_MEMOIZED_EXP (obj); #ifndef SCM_RECKLESS else if (SCM_NCONSP (obj)) - scm_wrong_type_arg (s_set_source_properties_x, 1, obj); + SCM_WRONG_TYPE_ARG(1, obj); #endif handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist); SCM_SETCDR (handle, plist); return plist; } +#undef FUNC_NAME -SCM_PROC (s_source_property, "source-property", 2, 0, 0, scm_source_property); - -SCM -scm_source_property (obj, key) - SCM obj; - SCM key; +GUILE_PROC (scm_source_property, "source-property", 2, 0, 0, + (SCM obj, SCM key), +"") +#define FUNC_NAME s_scm_source_property { SCM p; - SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_source_property); + SCM_VALIDATE_NIMP(1,obj); if (SCM_MEMOIZEDP (obj)) obj = SCM_MEMOIZED_EXP (obj); #ifndef SCM_RECKLESS else if (SCM_NECONSP (obj)) - scm_wrong_type_arg (s_source_property, 1, obj); + SCM_WRONG_TYPE_ARG (1, obj); #endif p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); if (SCM_IMP (p) || !SRCPROPSP (p)) @@ -249,23 +234,21 @@ scm_source_property (obj, key) } return SCM_UNBNDP (p) ? SCM_BOOL_F : p; } +#undef FUNC_NAME -SCM_PROC (s_set_source_property_x, "set-source-property!", 3, 0, 0, scm_set_source_property_x); - -SCM -scm_set_source_property_x (obj, key, datum) - SCM obj; - SCM key; - SCM datum; +GUILE_PROC (scm_set_source_property_x, "set-source-property!", 3, 0, 0, + (SCM obj, SCM key, SCM datum), +"") +#define FUNC_NAME s_scm_set_source_property_x { scm_whash_handle h; SCM p; - SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_set_source_property_x); + SCM_VALIDATE_NIMP(1,obj); if (SCM_MEMOIZEDP (obj)) obj = SCM_MEMOIZED_EXP (obj); #ifndef SCM_RECKLESS else if (SCM_NCONSP (obj)) - scm_wrong_type_arg (s_set_source_property_x, 1, obj); + SCM_WRONG_TYPE_ARG (1, obj); #endif h = scm_whash_get_handle (scm_source_whash, obj); if (SCM_WHASHFOUNDP (h)) @@ -298,8 +281,7 @@ scm_set_source_property_x (obj, key, datum) } else if (scm_sym_line == key) { - SCM_ASSERT (SCM_INUMP (datum), - datum, SCM_ARG3, s_set_source_property_x); + SCM_VALIDATE_INT(3,datum); if (SCM_NIMP (p) && SRCPROPSP (p)) SETSRCPROPLINE (p, SCM_INUM (datum)); else @@ -309,8 +291,7 @@ scm_set_source_property_x (obj, key, datum) } else if (scm_sym_column == key) { - SCM_ASSERT (SCM_INUMP (datum), - datum, SCM_ARG3, s_set_source_property_x); + SCM_VALIDATE_INT(3,datum); if (SCM_NIMP (p) && SRCPROPSP (p)) SETSRCPROPCOL (p, SCM_INUM (datum)); else @@ -336,6 +317,7 @@ scm_set_source_property_x (obj, key, datum) SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p)); return SCM_UNSPECIFIED; } +#undef FUNC_NAME void diff --git a/libguile/stacks.c b/libguile/stacks.c index 51d89c9ac..6b6de12a8 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -42,6 +42,10 @@ * * The author can be reached at djurfeldt@nada.kth.se * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include <stdio.h> @@ -54,6 +58,7 @@ #include "procprop.h" #include "modules.h" +#include "scm_validate.h" #include "stacks.h" @@ -146,13 +151,8 @@ * DFRAME. OFFSET is used for relocation of pointers when the stack * is read from a continuation. */ -static int stack_depth SCM_P ((scm_debug_frame *dframe, long offset, SCM *id, int *maxp)); static int -stack_depth (dframe, offset, id, maxp) - scm_debug_frame *dframe; - long offset; - SCM *id; - int *maxp; +stack_depth (scm_debug_frame *dframe,long offset,SCM *id,int *maxp) { int n, size; int max_depth = SCM_BACKTRACE_MAXDEPTH; @@ -185,12 +185,8 @@ stack_depth (dframe, offset, id, maxp) /* Read debug info from DFRAME into IFRAME. */ -static void read_frame SCM_P ((scm_debug_frame *dframe, long offset, scm_info_frame *iframe)); static void -read_frame (dframe, offset, iframe) - scm_debug_frame *dframe; - long offset; - scm_info_frame *iframe; +read_frame (scm_debug_frame *dframe,long offset,scm_info_frame *iframe) { SCM flags = SCM_INUM0; int size; @@ -259,13 +255,8 @@ get_applybody () * DFRAME. */ -static int read_frames SCM_P ((scm_debug_frame *dframe, long offset, int nframes, scm_info_frame *iframes)); static int -read_frames (dframe, offset, n, iframes) - scm_debug_frame *dframe; - long offset; - int n; - scm_info_frame *iframes; +read_frames (scm_debug_frame *dframe,long offset,int n,scm_info_frame *iframes) { int size; scm_info_frame *iframe = iframes; @@ -338,8 +329,6 @@ read_frames (dframe, offset, n, iframes) return iframe - iframes; /* Number of frames actually read */ } -static void narrow_stack SCM_P ((SCM stack, int inner, SCM inner_key, int outer, SCM outer_key)); - /* Narrow STACK by cutting away stackframes (mutatingly). * * Inner frames (most recent) are cut by advancing the frames pointer. @@ -362,12 +351,7 @@ static void narrow_stack SCM_P ((SCM stack, int inner, SCM inner_key, int outer, */ static void -narrow_stack (stack, inner, inner_key, outer, outer_key) - SCM stack; - int inner; - SCM inner_key; - int outer; - SCM outer_key; +narrow_stack (SCM stack,int inner,SCM inner_key,int outer,SCM outer_key) { scm_stack *s = SCM_STACK (stack); int i; @@ -426,18 +410,19 @@ narrow_stack (stack, inner, inner_key, outer, outer_key) SCM scm_stack_type; -SCM_PROC (s_stack_p, "stack?", 1, 0, 0, scm_stack_p); -SCM -scm_stack_p (obj) - SCM obj; +GUILE_PROC (scm_stack_p, "stack?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_stack_p { - return SCM_NIMP (obj) && SCM_STACKP (obj) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(SCM_NIMP (obj) && SCM_STACKP (obj)); } +#undef FUNC_NAME -SCM_PROC (s_make_stack, "make-stack", 0, 0, 1, scm_make_stack); -SCM -scm_make_stack (args) - SCM args; +GUILE_PROC (scm_make_stack, "make-stack", 0, 0, 1, + (SCM args), +"") +#define FUNC_NAME s_scm_make_stack { int n, maxp, size; scm_debug_frame *dframe = scm_last_debug_frame; @@ -447,9 +432,7 @@ scm_make_stack (args) SCM obj, inner_cut, outer_cut; SCM_ASSERT (SCM_NIMP (args) && SCM_CONSP (args), - scm_makfrom0str (s_make_stack), - SCM_WNA, - NULL); + SCM_FUNC_NAME, SCM_WNA, NULL); obj = SCM_CAR (args); args = SCM_CDR (args); @@ -459,7 +442,7 @@ scm_make_stack (args) (from initialization of dframe, above) if obj is #t */ if (obj != SCM_BOOL_T) { - SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_make_stack); + SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, FUNC_NAME); if (SCM_DEBUGOBJP (obj)) dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj); else if (scm_tc7_contin == SCM_TYP7 (obj)) @@ -473,7 +456,7 @@ scm_make_stack (args) } else { - scm_wta (obj, (char *) SCM_ARG1, s_make_stack); + scm_wta (obj, (char *) SCM_ARG1, FUNC_NAME); abort (); } } @@ -527,11 +510,12 @@ scm_make_stack (args) else return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_stack_id, "stack-id", 1, 0, 0, scm_stack_id); -SCM -scm_stack_id (stack) - SCM stack; +GUILE_PROC (scm_stack_id, "stack-id", 1, 0, 0, + (SCM stack), +"") +#define FUNC_NAME s_scm_stack_id { scm_debug_frame *dframe; long offset = 0; @@ -539,7 +523,7 @@ scm_stack_id (stack) dframe = scm_last_debug_frame; else { - SCM_ASSERT (SCM_NIMP (stack), stack, SCM_ARG1, s_make_stack); + SCM_VALIDATE_NIMP(1,stack); if (SCM_DEBUGOBJP (stack)) dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (stack); else if (scm_tc7_contin == SCM_TYP7 (stack)) @@ -554,7 +538,7 @@ scm_stack_id (stack) else if (SCM_STACKP (stack)) return SCM_STACK (stack) -> id; else - scm_wrong_type_arg (s_stack_id, SCM_ARG1, stack); + SCM_WRONG_TYPE_ARG (1, stack); } while (dframe && !SCM_VOIDFRAMEP (*dframe)) dframe = RELOC_FRAME (dframe->prev, offset); @@ -562,61 +546,54 @@ scm_stack_id (stack) return dframe->vect[0].id; return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_stack_ref, "stack-ref", 2, 0, 0, scm_stack_ref); -SCM -scm_stack_ref (stack, i) - SCM stack; - SCM i; +GUILE_PROC (scm_stack_ref, "stack-ref", 2, 0, 0, + (SCM stack, SCM i), +"") +#define FUNC_NAME s_scm_stack_ref { - SCM_ASSERT (SCM_NIMP (stack) - && SCM_STACKP (stack), - stack, - SCM_ARG1, - s_stack_ref); - SCM_ASSERT (SCM_INUMP (i), i, SCM_ARG2, s_stack_ref); - SCM_ASSERT (SCM_INUM (i) >= 0 - && SCM_INUM (i) < SCM_STACK_LENGTH (stack), - i, - SCM_OUTOFRANGE, - s_stack_ref); + SCM_VALIDATE_STACK(1,stack); + SCM_VALIDATE_INT(2,i); + SCM_ASSERT_RANGE (1,i, + SCM_INUM (i) >= 0 && + SCM_INUM (i) < SCM_STACK_LENGTH (stack)); return scm_cons (stack, i); } +#undef FUNC_NAME -SCM_PROC(s_stack_length, "stack-length", 1, 0, 0, scm_stack_length); -SCM -scm_stack_length (stack) - SCM stack; +GUILE_PROC(scm_stack_length, "stack-length", 1, 0, 0, + (SCM stack), +"") +#define FUNC_NAME s_scm_stack_length { - SCM_ASSERT (SCM_NIMP (stack) - && SCM_STACKP (stack), - stack, - SCM_ARG1, - s_stack_length); + SCM_VALIDATE_STACK(1,stack); return SCM_MAKINUM (SCM_STACK_LENGTH (stack)); } +#undef FUNC_NAME /* Frames */ -SCM_PROC (s_frame_p, "frame?", 1, 0, 0, scm_frame_p); -SCM -scm_frame_p (obj) - SCM obj; +GUILE_PROC (scm_frame_p, "frame?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_frame_p { - return SCM_NIMP (obj) && SCM_FRAMEP (obj); + return SCM_BOOL(SCM_NIMP (obj) && SCM_FRAMEP (obj)); } +#undef FUNC_NAME -SCM_PROC(s_last_stack_frame, "last-stack-frame", 1, 0, 0, scm_last_stack_frame); -SCM -scm_last_stack_frame (obj) - SCM obj; +GUILE_PROC(scm_last_stack_frame, "last-stack-frame", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_last_stack_frame { scm_debug_frame *dframe; long offset = 0; SCM stack; - SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_last_stack_frame); + SCM_VALIDATE_NIMP(1,obj); if (SCM_DEBUGOBJP (obj)) dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj); else if (scm_tc7_contin == SCM_TYP7 (obj)) @@ -630,7 +607,7 @@ scm_last_stack_frame (obj) } else { - scm_wta (obj, (char *) SCM_ARG1, s_last_stack_frame); + SCM_WTA (1,obj); abort (); } @@ -646,138 +623,119 @@ scm_last_stack_frame (obj) return scm_cons (stack, SCM_INUM0);; } +#undef FUNC_NAME -SCM_PROC(s_frame_number, "frame-number", 1, 0, 0, scm_frame_number); -SCM -scm_frame_number (frame) - SCM frame; +GUILE_PROC(scm_frame_number, "frame-number", 1, 0, 0, + (SCM frame), +"") +#define FUNC_NAME s_scm_frame_number { - SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), - frame, - SCM_ARG1, - s_frame_number); + SCM_VALIDATE_FRAME(1,frame); return SCM_MAKINUM (SCM_FRAME_NUMBER (frame)); } +#undef FUNC_NAME -SCM_PROC(s_frame_source, "frame-source", 1, 0, 0, scm_frame_source); -SCM -scm_frame_source (frame) - SCM frame; +GUILE_PROC(scm_frame_source, "frame-source", 1, 0, 0, + (SCM frame), +"") +#define FUNC_NAME s_scm_frame_source { - SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), - frame, - SCM_ARG1, - s_frame_source); + SCM_VALIDATE_FRAME(1,frame); return SCM_FRAME_SOURCE (frame); } +#undef FUNC_NAME -SCM_PROC(s_frame_procedure, "frame-procedure", 1, 0, 0, scm_frame_procedure); -SCM -scm_frame_procedure (frame) - SCM frame; +GUILE_PROC(scm_frame_procedure, "frame-procedure", 1, 0, 0, + (SCM frame), +"") +#define FUNC_NAME s_scm_frame_procedure { - SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), - frame, - SCM_ARG1, - s_frame_procedure); + SCM_VALIDATE_FRAME(1,frame); return (SCM_FRAME_PROC_P (frame) ? SCM_FRAME_PROC (frame) : SCM_BOOL_F); } +#undef FUNC_NAME -SCM_PROC(s_frame_arguments, "frame-arguments", 1, 0, 0, scm_frame_arguments); -SCM -scm_frame_arguments (frame) - SCM frame; +GUILE_PROC(scm_frame_arguments, "frame-arguments", 1, 0, 0, + (SCM frame), +"") +#define FUNC_NAME s_scm_frame_arguments { - SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), - frame, - SCM_ARG1, - s_frame_arguments); + SCM_VALIDATE_FRAME(1,frame); return SCM_FRAME_ARGS (frame); } +#undef FUNC_NAME -SCM_PROC(s_frame_previous, "frame-previous", 1, 0, 0, scm_frame_previous); -SCM -scm_frame_previous (frame) - SCM frame; +GUILE_PROC(scm_frame_previous, "frame-previous", 1, 0, 0, + (SCM frame), +"") +#define FUNC_NAME s_scm_frame_previous { int n; - SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), - frame, - SCM_ARG1, - s_frame_previous); + SCM_VALIDATE_FRAME(1,frame); n = SCM_INUM (SCM_CDR (frame)) + 1; if (n >= SCM_STACK_LENGTH (SCM_CAR (frame))) return SCM_BOOL_F; else return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n)); } +#undef FUNC_NAME -SCM_PROC(s_frame_next, "frame-next", 1, 0, 0, scm_frame_next); -SCM -scm_frame_next (frame) - SCM frame; +GUILE_PROC(scm_frame_next, "frame-next", 1, 0, 0, + (SCM frame), +"") +#define FUNC_NAME s_scm_frame_next { int n; - SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), - frame, - SCM_ARG1, - s_frame_next); + SCM_VALIDATE_FRAME(1,frame); n = SCM_INUM (SCM_CDR (frame)) - 1; if (n < 0) return SCM_BOOL_F; else return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n)); } +#undef FUNC_NAME -SCM_PROC(s_frame_real_p, "frame-real?", 1, 0, 0, scm_frame_real_p); -SCM -scm_frame_real_p (frame) - SCM frame; +GUILE_PROC(scm_frame_real_p, "frame-real?", 1, 0, 0, + (SCM frame), +"") +#define FUNC_NAME s_scm_frame_real_p { - SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), - frame, - SCM_ARG1, - s_frame_real_p); - return SCM_FRAME_REAL_P (frame) ? SCM_BOOL_T : SCM_BOOL_F; + SCM_VALIDATE_FRAME(1,frame); + return SCM_BOOL(SCM_FRAME_REAL_P (frame)); } +#undef FUNC_NAME -SCM_PROC(s_frame_procedure_p, "frame-procedure?", 1, 0, 0, scm_frame_procedure_p); -SCM -scm_frame_procedure_p (frame) - SCM frame; +GUILE_PROC(scm_frame_procedure_p, "frame-procedure?", 1, 0, 0, + (SCM frame), +"") +#define FUNC_NAME s_scm_frame_procedure_p { - SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), - frame, - SCM_ARG1, - s_frame_procedure_p); - return SCM_FRAME_PROC_P (frame) ? SCM_BOOL_T : SCM_BOOL_F; + SCM_VALIDATE_FRAME(1,frame); + return SCM_BOOL(SCM_FRAME_PROC_P (frame)); } +#undef FUNC_NAME -SCM_PROC(s_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0, scm_frame_evaluating_args_p); -SCM -scm_frame_evaluating_args_p (frame) - SCM frame; +GUILE_PROC(scm_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0, + (SCM frame), +"") +#define FUNC_NAME s_scm_frame_evaluating_args_p { - SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), - frame, - SCM_ARG1, - s_frame_evaluating_args_p); - return SCM_FRAME_EVAL_ARGS_P (frame) ? SCM_BOOL_T : SCM_BOOL_F; + SCM_VALIDATE_FRAME(1,frame); + return SCM_BOOL(SCM_FRAME_EVAL_ARGS_P (frame)); } +#undef FUNC_NAME -SCM_PROC(s_frame_overflow_p, "frame-overflow?", 1, 0, 0, scm_frame_overflow_p); -SCM -scm_frame_overflow_p (frame) - SCM frame; +GUILE_PROC(scm_frame_overflow_p, "frame-overflow?", 1, 0, 0, + (SCM frame), +"") +#define FUNC_NAME s_scm_frame_overflow_p { - SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), - frame, - SCM_ARG1, - s_frame_overflow_p); + SCM_VALIDATE_FRAME(1,frame); return SCM_FRAME_OVERFLOW_P (frame) ? SCM_BOOL_T : SCM_BOOL_F; } +#undef FUNC_NAME 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 <stdio.h> #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 <stdio.h> @@ -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 <stdio.h> #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 (i<e) SCM_CHARS (str)[i++] = c; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_string_null_p, "string-null?", 1, 0, 0, scm_string_null_p); - -SCM -scm_string_null_p (str) - SCM str; +GUILE_PROC(scm_string_null_p, "string-null?", 1, 0, 0, + (SCM str), +"") +#define FUNC_NAME s_scm_string_null_p { - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_null_p); - return (SCM_ROLENGTH (str) - ? SCM_BOOL_F - : SCM_BOOL_T); + SCM_VALIDATE_ROSTRING(1,str); + return SCM_NEGATE_BOOL(SCM_ROLENGTH (str)); } +#undef FUNC_NAME -SCM_PROC(s_string_to_list, "string->list", 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; i<len; i++) { @@ -324,29 +316,31 @@ scm_string_capitalize_x (SCM s) } return s; } +#undef FUNC_NAME -SCM_PROC(s_string_capitalize, "string-capitalize", 1, 0, 0, scm_string_capitalize); - -SCM -scm_string_capitalize(SCM s) +GUILE_PROC(scm_string_capitalize, "string-capitalize", 1, 0, 0, + (SCM s), +"") +#define FUNC_NAME s_scm_string_capitalize { - SCM_ASSERT((SCM_NIMP(s)) && (SCM_STRINGP(s)), s, SCM_ARG1, s_string_capitalize); + SCM_VALIDATE_STRING(1,s); return scm_string_capitalize_x(scm_string_copy(s)); } +#undef FUNC_NAME -SCM_PROC(s_string_ci_to_symbol, "string-ci->symbol", 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 <stdio.h> @@ -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 <stdio.h> @@ -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 <stdio.h> #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 <stdio.h> @@ -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 ("#<jmpbuffer ", port); scm_puts (JBACTIVE(exp) ? "(active) " : "(inactive) ", port); @@ -103,9 +101,8 @@ printjb (exp, port, pstate) } -static SCM make_jmpbuf SCM_P ((void)); static SCM -make_jmpbuf () +make_jmpbuf (void) { SCM answer; SCM_REDEFER_INTS; @@ -557,19 +554,15 @@ scm_handle_by_throw (handler_data, tag, args) /* the Scheme-visible CATCH and LAZY-CATCH functions */ -SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch); -SCM -scm_catch (tag, thunk, handler) - SCM tag; - SCM thunk; - SCM handler; +GUILE_PROC(scm_catch, "catch", 3, 0, 0, + (SCM tag, SCM thunk, SCM handler), +"") +#define FUNC_NAME s_scm_catch { struct scm_body_thunk_data c; SCM_ASSERT ((SCM_NIMP(tag) && SCM_SYMBOLP(tag)) || tag == SCM_BOOL_T, - tag, - SCM_ARG1, - s_catch); + tag, SCM_ARG1, FUNC_NAME); c.tag = tag; c.body_proc = thunk; @@ -583,20 +576,19 @@ scm_catch (tag, thunk, handler) scm_body_thunk, &c, scm_handle_by_proc, &handler); } +#undef FUNC_NAME -SCM_PROC(s_lazy_catch, "lazy-catch", 3, 0, 0, scm_lazy_catch); -SCM -scm_lazy_catch (tag, thunk, handler) - SCM tag; - SCM thunk; - SCM handler; +GUILE_PROC(scm_lazy_catch, "lazy-catch", 3, 0, 0, + (SCM tag, SCM thunk, SCM handler), +"") +#define FUNC_NAME s_scm_lazy_catch { struct scm_body_thunk_data c; SCM_ASSERT ((SCM_NIMP(tag) && SCM_SYMBOLP(tag)) || (tag == SCM_BOOL_T), - tag, SCM_ARG1, s_lazy_catch); + tag, SCM_ARG1, FUNC_NAME); c.tag = tag; c.body_proc = thunk; @@ -611,28 +603,26 @@ scm_lazy_catch (tag, thunk, handler) scm_body_thunk, &c, scm_handle_by_proc, &handler); } +#undef FUNC_NAME /* throwing */ -SCM_PROC(s_throw, "throw", 1, 0, 1, scm_throw); -SCM -scm_throw (key, args) - SCM key; - SCM args; +GUILE_PROC(scm_throw, "throw", 1, 0, 1, + (SCM key, SCM args), +"") +#define FUNC_NAME s_scm_throw { - SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1, s_throw); + SCM_VALIDATE_SYMBOL(1,key); /* May return if handled by lazy catch. */ return scm_ithrow (key, args, 1); } +#undef FUNC_NAME SCM -scm_ithrow (key, args, noreturn) - SCM key; - SCM args; - int noreturn; +scm_ithrow (SCM key, SCM args, int noreturn) { SCM jmpbuf = SCM_UNDEFINED; SCM wind_goal; diff --git a/libguile/unif.c b/libguile/unif.c index 0384099d1..c3d649480 100644 --- a/libguile/unif.c +++ b/libguile/unif.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 <stdio.h> @@ -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 <stdio.h> @@ -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 ("#<variable ", port); scm_intprint(exp, 16, port); @@ -75,21 +75,14 @@ prin_var (exp, port, pstate) } -static SCM scm_markvar SCM_P ((SCM ptr)); - static SCM -scm_markvar (ptr) - SCM ptr; +scm_markvar (SCM ptr) { return SCM_CDR (ptr); } -static SCM var_equal SCM_P ((SCM var1, SCM var2)); - static SCM -var_equal (var1, var2) - SCM var1; - SCM var2; +var_equal (SCM var1, SCM var2) { return scm_equal_p (SCM_CDR (var1), SCM_CDR (var2)); } @@ -100,21 +93,16 @@ int scm_tc16_variable; static SCM anonymous_variable_sym; -static SCM make_vcell_variable SCM_P ((SCM vcell)); - static SCM -make_vcell_variable (vcell) - SCM vcell; +make_vcell_variable (SCM vcell) { SCM_RETURN_NEWSMOB (scm_tc16_variable, vcell); } -SCM_PROC(s_make_variable, "make-variable", 1, 1, 0, scm_make_variable); - -SCM -scm_make_variable (init, name_hint) - SCM init; - SCM name_hint; +GUILE_PROC(scm_make_variable, "make-variable", 1, 1, 0, + (SCM init, SCM name_hint), + "") +#define FUNC_NAME s_scm_make_variable { SCM val_cell; @@ -128,13 +116,13 @@ scm_make_variable (init, name_hint) SCM_ALLOW_INTS; return make_vcell_variable (val_cell); } +#undef FUNC_NAME -SCM_PROC(s_make_undefined_variable, "make-undefined-variable", 0, 1, 0, scm_make_undefined_variable); - -SCM -scm_make_undefined_variable (name_hint) - SCM name_hint; +GUILE_PROC(scm_make_undefined_variable, "make-undefined-variable", 0, 1, 0, + (SCM name_hint), + "") +#define FUNC_NAME s_scm_make_undefined_variable { SCM vcell; @@ -148,55 +136,52 @@ scm_make_undefined_variable (name_hint) SCM_ALLOW_INTS; return make_vcell_variable (vcell); } +#undef FUNC_NAME -SCM_PROC(s_variable_p, "variable?", 1, 0, 0, scm_variable_p); - -SCM -scm_variable_p (obj) - SCM obj; +GUILE_PROC(scm_variable_p, "variable?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_variable_p { - return ( (SCM_NIMP(obj) && SCM_VARIABLEP (obj)) - ? SCM_BOOL_T - : SCM_BOOL_F); + return SCM_BOOL(SCM_NIMP(obj) && SCM_VARIABLEP (obj)); } +#undef FUNC_NAME -SCM_PROC(s_variable_ref, "variable-ref", 1, 0, 0, scm_variable_ref); - -SCM -scm_variable_ref (var) - SCM var; +GUILE_PROC(scm_variable_ref, "variable-ref", 1, 0, 0, + (SCM var), +"") +#define FUNC_NAME s_scm_variable_ref { - SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP(var), var, SCM_ARG1, s_variable_ref); + SCM_VALIDATE_VARIABLE(1,var); return SCM_CDR (SCM_CDR (var)); } +#undef FUNC_NAME -SCM_PROC(s_variable_set_x, "variable-set!", 2, 0, 0, scm_variable_set_x); - -SCM -scm_variable_set_x (var, val) - SCM var; - SCM val; +GUILE_PROC(scm_variable_set_x, "variable-set!", 2, 0, 0, + (SCM var, SCM val), +"") +#define FUNC_NAME s_scm_variable_set_x { - SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP (var), var, SCM_ARG1, s_variable_set_x); + SCM_VALIDATE_VARIABLE(1,var); SCM_SETCDR (SCM_CDR (var), val); return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_builtin_variable, "builtin-variable", 1, 0, 0, scm_builtin_variable); - -SCM -scm_builtin_variable (name) - SCM name; +GUILE_PROC(scm_builtin_variable, "builtin-variable", 1, 0, 0, + (SCM name), +"") +#define FUNC_NAME s_scm_builtin_variable { SCM vcell; SCM var_slot; - SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name), name, SCM_ARG1, s_builtin_variable); + SCM_VALIDATE_SYMBOL(1,name); vcell = scm_sym2vcell (name, SCM_BOOL_F, SCM_BOOL_T); if (vcell == SCM_BOOL_F) return SCM_BOOL_F; @@ -212,19 +197,18 @@ scm_builtin_variable (name) return SCM_CDR (var_slot); } +#undef FUNC_NAME -SCM_PROC(s_variable_bound_p, "variable-bound?", 1, 0, 0, scm_variable_bound_p); - -SCM -scm_variable_bound_p (var) - SCM var; +GUILE_PROC(scm_variable_bound_p, "variable-bound?", 1, 0, 0, + (SCM var), +"") +#define FUNC_NAME s_scm_variable_bound_p { - SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP (var), var, SCM_ARG1, s_variable_bound_p); - return (SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (var))) - ? SCM_BOOL_F - : SCM_BOOL_T); + SCM_VALIDATE_VARIABLE(1,var); + return SCM_NEGATE_BOOL(SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (var)))); } +#undef FUNC_NAME diff --git a/libguile/vectors.c b/libguile/vectors.c index 52af1cf11..61a547cce 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.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 <stdio.h> #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<e) SCM_VELTS (vec2)[j++] = SCM_VELTS (vec1)[i++]; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC (s_vector_move_right_x, "vector-move-right!", 5, 0, 0, scm_vector_move_right_x); - -SCM -scm_vector_move_right_x (vec1, start1, end1, vec2, start2) - SCM vec1; - SCM start1; - SCM end1; - SCM vec2; - SCM start2; +GUILE_PROC (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0, + (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2), + "") +#define FUNC_NAME s_scm_vector_move_right_x { long i; long j; long e; - SCM_ASSERT (SCM_NIMP (vec1) && SCM_VECTORP (vec1), - vec1, SCM_ARG1, s_vector_move_right_x); - SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_vector_move_right_x); - SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_vector_move_right_x); - SCM_ASSERT (SCM_NIMP (vec2) && SCM_VECTORP (vec2), - vec2, SCM_ARG4, s_vector_move_right_x); - SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_vector_move_right_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_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 <stdio.h> @@ -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 <stdio.h> #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 |