summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/ChangeLog41
-rw-r--r--libguile/Makefile.am2
-rw-r--r--libguile/alist.c219
-rw-r--r--libguile/arbiters.c44
-rw-r--r--libguile/async.c136
-rw-r--r--libguile/backtrace.c112
-rw-r--r--libguile/boolean.c31
-rw-r--r--libguile/chars.c332
-rw-r--r--libguile/continuations.c9
-rw-r--r--libguile/debug.c281
-rw-r--r--libguile/dynl-dl.c122
-rw-r--r--libguile/dynl-dld.c132
-rw-r--r--libguile/dynl-shl.c108
-rw-r--r--libguile/dynl.c156
-rw-r--r--libguile/dynwind.c27
-rw-r--r--libguile/eq.c42
-rw-r--r--libguile/error.c93
-rw-r--r--libguile/eval.c170
-rw-r--r--libguile/evalext.c24
-rw-r--r--libguile/feature.c131
-rw-r--r--libguile/filesys.c495
-rw-r--r--libguile/fluids.c107
-rw-r--r--libguile/fports.c54
-rw-r--r--libguile/gc.c82
-rw-r--r--libguile/gdbint.c14
-rw-r--r--libguile/gsubr.c29
-rw-r--r--libguile/guardians.c16
-rw-r--r--libguile/hash.c61
-rw-r--r--libguile/hashtab.c324
-rw-r--r--libguile/init.c53
-rw-r--r--libguile/ioext.c221
-rw-r--r--libguile/keywords.c54
-rw-r--r--libguile/lang.c60
-rw-r--r--libguile/list.c456
-rw-r--r--libguile/load.c115
-rw-r--r--libguile/macros.c105
-rw-r--r--libguile/mallocs.c21
-rw-r--r--libguile/net_db.c182
-rw-r--r--libguile/numbers.c667
-rw-r--r--libguile/objects.c96
-rw-r--r--libguile/objprop.c48
-rw-r--r--libguile/pairs.c62
-rw-r--r--libguile/pairs.h5
-rw-r--r--libguile/ports.c446
-rw-r--r--libguile/posix.c588
-rw-r--r--libguile/print.c142
-rw-r--r--libguile/procprop.c68
-rw-r--r--libguile/procs.c127
-rw-r--r--libguile/ramap.c302
-rw-r--r--libguile/random.c141
-rw-r--r--libguile/read.c66
-rw-r--r--libguile/regex-posix.c71
-rw-r--r--libguile/root.c49
-rw-r--r--libguile/scm_validate.h267
-rw-r--r--libguile/scmsigs.c110
-rw-r--r--libguile/simpos.c49
-rw-r--r--libguile/smob.c6
-rw-r--r--libguile/snarf.h34
-rw-r--r--libguile/socket.c422
-rw-r--r--libguile/sort.c208
-rw-r--r--libguile/srcprop.c98
-rw-r--r--libguile/stacks.c286
-rw-r--r--libguile/stime.c169
-rw-r--r--libguile/strings.c214
-rw-r--r--libguile/strop.c230
-rw-r--r--libguile/strports.c51
-rw-r--r--libguile/struct.c220
-rw-r--r--libguile/symbols.c308
-rw-r--r--libguile/tag.c14
-rw-r--r--libguile/tags.h10
-rw-r--r--libguile/threads.c24
-rw-r--r--libguile/throw.c64
-rw-r--r--libguile/unif.c526
-rw-r--r--libguile/variable.c116
-rw-r--r--libguile/vectors.c158
-rw-r--r--libguile/version.c31
-rw-r--r--libguile/vports.c20
-rw-r--r--libguile/weaks.c121
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, &copy);
}
+#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, &lt, SCM_ARG1, s_mktime);
+ bdtime2c (sbd_time, &lt, SCM_ARG1, FUNC_NAME);
SCM_DEFER_INTS;
- oldenv = setzone (zone, SCM_ARG2, s_mktime);
+ oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
itime = mktime (&lt);
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