summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>1999-08-26 04:24:42 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>1999-08-26 04:24:42 +0000
commit9de33deb2ea07bf6c93651bbd693e7484dd29b33 (patch)
treece3f42882590ee80cfb30221518a120920104a31
parent52235e71737b47b648b5511396073f023d08a78e (diff)
downloadguile-9de33deb2ea07bf6c93651bbd693e7484dd29b33.tar.gz
* procs.c, procs.h (scm_subr_entry): New type: Stores data
associated with subrs. (SCM_SUBRNUM, SCM_SUBR_ENTRY, SCM_SUBR_GENERIC, SCM_SUBR_PROPS, SCM_SUBR_DOC): New macros. (scm_subr_table): New variable. (scm_mark_subr_table): New function. * init.c (scm_boot_guile_1): Call scm_init_subr_table. * gc.c (scm_gc_mark): Don't mark subr names here. (scm_igc): Call scm_mark_subr_table. * snarf.h (SCM_GPROC, SCM_GPROC1): New macros. * procs.c, procs.h (scm_subr_p): New function (used internally). * gsubr.c, gsubr.h (scm_make_gsubr_with_generic): New function. * objects.c, objects.h (scm_primitive_generic): New class. * objects.h (SCM_CMETHOD_CODE, SCM_CMETHOD_ENV): New macros. * print.c (scm_iprin1): Print primitive-generics. * __scm.h (SCM_WTA_DISPATCH_1, SCM_GASSERT1, SCM_WTA_DISPATCH_2, SCM_GASSERT2): New macros. * eval.c (SCM_CEVAL, SCM_APPLY): Replace scm_wta --> SCM_WTA_DISPATCH_1 for scm_cxr's (unary floating point primitives). NOTE: This means that it is now *required* to use SCM_GPROC1 when creating float scm_cxr's (float scm_cxr's is an obscured representation that will be removed in the future anyway, so backward compatibility is no problem here). * numbers.c: Converted most numeric primitives (all but bit comparison operations and bit operations) to dispatch on generic if args don't match. * eval.c, eval.h (scm_eval_body): New function. * objects.c (scm_call_generic_0, scm_call_generic_1, scm_call_generic_2, scm_call_generic_3, scm_apply_generic): New functions. * eval.c (SCM_CEVAL): Apply the cmethod directly after having called scm_memoize_method instead of doing a second lookup. * objects.h (scm_memoize_method): Now returns the memoized cmethod. * procs.c (scm_make_subr_opt): Use scm_sysintern0 instead of scm_sysintern so that the binding connected with the subr name isn't cleared when we give set = 0.
-rw-r--r--libguile/ChangeLog78
-rw-r--r--libguile/__scm.h22
-rw-r--r--libguile/eval.c48
-rw-r--r--libguile/eval.h1
-rw-r--r--libguile/gc.c8
-rw-r--r--libguile/gsubr.c34
-rw-r--r--libguile/gsubr.h6
-rw-r--r--libguile/init.c1
-rw-r--r--libguile/numbers.c220
-rw-r--r--libguile/objects.c151
-rw-r--r--libguile/objects.h18
-rw-r--r--libguile/print.c5
-rw-r--r--libguile/procs.c103
-rw-r--r--libguile/procs.h33
-rw-r--r--libguile/snarf.h14
15 files changed, 614 insertions, 128 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index 7a66475ee..034516cf1 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,5 +1,83 @@
+1999-08-26 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ This change extends the representation of primitive procedures
+ with more data fields, e.g. a place for documentation and true
+ procedure properties.
+
+ * procs.c, procs.h (scm_subr_entry): New type: Stores data
+ associated with subrs.
+ (SCM_SUBRNUM, SCM_SUBR_ENTRY, SCM_SUBR_GENERIC, SCM_SUBR_PROPS,
+ SCM_SUBR_DOC): New macros.
+ (scm_subr_table): New variable.
+ (scm_mark_subr_table): New function.
+
+ * init.c (scm_boot_guile_1): Call scm_init_subr_table.
+
+ * gc.c (scm_gc_mark): Don't mark subr names here.
+ (scm_igc): Call scm_mark_subr_table.
+
+
+ This change implements a scheme for letting a generic work as a
+ shadow for a primitive procedure. If the primitive procedure
+ can't dispatch on its arguments, control is left over to the
+ generic. Normal wrong type arg errors will be generated until the
+ user has hung the first method on the primitive.
+
+ * snarf.h (SCM_GPROC, SCM_GPROC1): New macros.
+
+ * procs.c, procs.h (scm_subr_p): New function (used internally).
+
+ * gsubr.c, gsubr.h (scm_make_gsubr_with_generic): New function.
+
+ * objects.c, objects.h (scm_primitive_generic): New class.
+
+ * objects.h (SCM_CMETHOD_CODE, SCM_CMETHOD_ENV): New macros.
+
+ * print.c (scm_iprin1): Print primitive-generics.
+
+ * __scm.h (SCM_WTA_DISPATCH_1, SCM_GASSERT1,
+ SCM_WTA_DISPATCH_2, SCM_GASSERT2): New macros.
+
+ * eval.c (SCM_CEVAL, SCM_APPLY): Replace scm_wta -->
+ SCM_WTA_DISPATCH_1 for scm_cxr's (unary floating point
+ primitives). NOTE: This means that it is now *required* to use
+ SCM_GPROC1 when creating float scm_cxr's (float scm_cxr's is an
+ obscured representation that will be removed in the future anyway,
+ so backward compatibility is no problem here).
+
+ * numbers.c: Converted most numeric primitives (all but bit
+ comparison operations and bit operations) to dispatch on generic
+ if args don't match.
+
+
+ Better support for applying generic functions.
+
+ * eval.c, eval.h (scm_eval_body): New function.
+
+ * objects.c (scm_call_generic_0, scm_call_generic_1,
+ scm_call_generic_2, scm_call_generic_3, scm_apply_generic): New
+ functions.
+
+
+ Optimization of the generic function dispatch mechanism.
+
+ * eval.c (SCM_CEVAL): Apply the cmethod directly after having
+ called scm_memoize_method instead of doing a second lookup.
+
+ * objects.h (scm_memoize_method): Now returns the memoized cmethod.
+
+
+ Bugfix
+
+ * procs.c (scm_make_subr_opt): Use scm_sysintern0 instead of
+ scm_sysintern so that the binding connected with the subr name
+ isn't cleared when we give set = 0.
+
+
1999-08-24 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+ More transparent handling of ports with print states.
+
* print.h (SCM_PORT_WITH_PS_P, SCM_PORT_WITH_PS_PORT,
SCM_PORT_WITH_PS_PS): Represent ports with print states as a smob
instead of a pair of a port and a print state. We'll need to cons
diff --git a/libguile/__scm.h b/libguile/__scm.h
index 0f6d24d6c..888ba18e2 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -415,6 +415,28 @@ extern unsigned int scm_async_clock;
goto _label
#endif
+/*
+ * SCM_WTA_DISPATCH
+ */
+
+extern SCM scm_call_generic_1 (SCM gf, SCM a1);
+
+#define SCM_WTA_DISPATCH_1(gf, a1, pos, subr) \
+ return ((gf) \
+ ? scm_call_generic_1 ((gf), (a1)) \
+ : scm_wta ((a1), (char *) (pos), (subr)))
+#define SCM_GASSERT1(cond, gf, a1, pos, subr) \
+ if (!(cond)) SCM_WTA_DISPATCH_1((gf), (a1), (pos), (subr))
+
+extern SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2);
+
+#define SCM_WTA_DISPATCH_2(gf, a1, a2, pos, subr) \
+ return ((gf) \
+ ? scm_call_generic_2 ((gf), (a1), (a2)) \
+ : scm_wta ((pos) == SCM_ARG1 ? (a1) : (a2), (char *) (pos), (subr)))
+#define SCM_GASSERT2(cond, gf, a1, a2, pos, subr) \
+ if (!(cond)) SCM_WTA_DISPATCH_2((gf), (a1), (a2), (pos), (subr))
+
#define SCM_ARGn 0
#define SCM_ARG1 1
#define SCM_ARG2 2
diff --git a/libguile/eval.c b/libguile/eval.c
index c035280f0..81849a47f 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -94,7 +94,7 @@ char *alloca ();
#include "eval.h"
-void (*scm_memoize_method) (SCM, SCM);
+SCM (*scm_memoize_method) (SCM, SCM);
@@ -1618,6 +1618,29 @@ scm_eval_args (l, env, proc)
return results;
}
+SCM
+scm_eval_body (SCM code, SCM env)
+{
+ SCM next;
+ again:
+ next = code;
+ while (SCM_NNULLP (next = SCM_CDR (next)))
+ {
+ if (SCM_IMP (SCM_CAR (code)))
+ {
+ if (SCM_ISYMP (SCM_CAR (code)))
+ {
+ code = scm_m_expand_body (code, env);
+ goto again;
+ }
+ }
+ else
+ SCM_XEVAL (SCM_CAR (code), env);
+ code = next;
+ }
+ return SCM_XEVALCAR (code, env);
+}
+
#endif /* !DEVAL */
@@ -2375,32 +2398,33 @@ dispatch:
do
{
int j = n;
- SCM entry = SCM_VELTS (proc)[i];
+ z = SCM_VELTS (proc)[i];
t.arg1 = arg2; /* list of arguments */
do
{
/* More arguments than specifiers => CLASS != ENV */
- if (scm_class_of (SCM_CAR (t.arg1)) != SCM_CAR (entry))
+ if (scm_class_of (SCM_CAR (t.arg1)) != SCM_CAR (z))
goto next_method;
t.arg1 = SCM_CDR (t.arg1);
- entry = SCM_CDR (entry);
+ z = SCM_CDR (z);
}
while (--j && SCM_NIMP (t.arg1));
/* Fewer arguments than specifiers => CAR != ENV */
- if (!SCM_CONSP (SCM_CAR (entry)))
+ if (!SCM_CONSP (SCM_CAR (z)))
goto next_method;
+ apply_cmethod:
/* Copy the environment frame so that the dispatch form can
be used also in normal code. */
- env = EXTEND_ENV (SCM_CADR (entry), arg2, SCM_CAR (entry));
- x = SCM_CDR (entry);
+ env = EXTEND_ENV (SCM_CADR (z), arg2, SCM_CAR (z));
+ x = SCM_CDR (z);
goto cdrxbegin;
next_method:
i = (i + 1) & mask;
} while (i != end);
/* No match - call external function and try again */
- scm_memoize_method (x, arg2);
- goto type_dispatch;
+ z = scm_memoize_method (x, arg2);
+ goto apply_cmethod;
}
case (SCM_ISYMNUM (SCM_IM_SLOT_REF)):
@@ -2817,7 +2841,8 @@ evapply:
}
#endif
floerr:
- scm_wta (t.arg1, (char *) SCM_ARG1, SCM_CHARS (SCM_SNAME (proc)));
+ SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), t.arg1,
+ SCM_ARG1, SCM_CHARS (SCM_SNAME (proc)));
}
#endif
proc = (SCM) SCM_SNAME (proc);
@@ -3468,7 +3493,8 @@ tail:
RETURN (scm_makdbl (SCM_DSUBRF (proc) (scm_big2dbl (arg1)), 0.0))
#endif
floerr:
- scm_wta (arg1, (char *) SCM_ARG1, SCM_CHARS (SCM_SNAME (proc)));
+ SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
+ SCM_ARG1, SCM_CHARS (SCM_SNAME (proc)));
}
#endif
proc = (SCM) SCM_SNAME (proc);
diff --git a/libguile/eval.h b/libguile/eval.h
index f6af5a436..84eeaca99 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -170,6 +170,7 @@ extern SCM * scm_lookupcar SCM_P ((SCM vloc, SCM genv, int check));
extern SCM scm_unmemocar SCM_P ((SCM form, SCM env));
extern SCM scm_unmemocopy SCM_P ((SCM form, SCM env));
extern SCM scm_eval_car SCM_P ((SCM pair, SCM env));
+extern SCM scm_eval_body (SCM code, SCM env);
extern SCM scm_eval_args SCM_P ((SCM i, SCM env, SCM proc));
extern SCM scm_deval_args SCM_P ((SCM l, SCM env, SCM proc, SCM *lloc));
extern SCM scm_m_quote SCM_P ((SCM xorig, SCM env));
diff --git a/libguile/gc.c b/libguile/gc.c
index c8ac03193..0c4a0f931 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -563,6 +563,11 @@ scm_igc (what)
while (j--)
scm_gc_mark (scm_sys_protects[j]);
+ /* FIXME: we should have a means to register C functions to be run
+ * in different phases of GC
+ */
+ scm_mark_subr_table ();
+
#ifndef USE_THREADS
scm_gc_mark (scm_root->handle);
#endif
@@ -830,8 +835,7 @@ gc_mark_nimp:
SCM_SETGC8MARK (ptr);
break;
case scm_tcs_subrs:
- ptr = (SCM)(scm_heap_org + (((unsigned long)SCM_CAR (ptr)) >> 8));
- goto gc_mark_loop;
+ break;
case scm_tc7_port:
i = SCM_PTOBNUM (ptr);
if (!(i < scm_numptob))
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 40fdb5b0e..45bfe3db9 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -101,6 +101,40 @@ scm_make_gsubr(name, req, opt, rst, fcn)
}
}
+SCM
+scm_make_gsubr_with_generic (const char *name,
+ int req,
+ int opt,
+ int rst,
+ SCM (*fcn)(),
+ SCM *gf)
+{
+ switch SCM_GSUBR_MAKTYPE(req, opt, rst) {
+ case SCM_GSUBR_MAKTYPE(0, 0, 0):
+ return scm_make_subr_with_generic(name, scm_tc7_subr_0, fcn, gf);
+ case SCM_GSUBR_MAKTYPE(1, 0, 0):
+ return scm_make_subr_with_generic(name, scm_tc7_subr_1, fcn, gf);
+ case SCM_GSUBR_MAKTYPE(0, 1, 0):
+ return scm_make_subr_with_generic(name, scm_tc7_subr_1o, fcn, gf);
+ case SCM_GSUBR_MAKTYPE(1, 1, 0):
+ return scm_make_subr_with_generic(name, scm_tc7_subr_2o, fcn, gf);
+ case SCM_GSUBR_MAKTYPE(2, 0, 0):
+ return scm_make_subr_with_generic(name, scm_tc7_subr_2, fcn, gf);
+ case SCM_GSUBR_MAKTYPE(3, 0, 0):
+ return scm_make_subr_with_generic(name, scm_tc7_subr_3, fcn, gf);
+ case SCM_GSUBR_MAKTYPE(0, 0, 1):
+ return scm_make_subr_with_generic(name, scm_tc7_lsubr, fcn, gf);
+ case SCM_GSUBR_MAKTYPE(2, 0, 1):
+ return scm_make_subr_with_generic(name, scm_tc7_lsubr_2, fcn, gf);
+ default:
+ ;
+ }
+ scm_misc_error ("scm_make_gsubr_with_generic",
+ "can't make primitive-generic with this arity",
+ SCM_EOL);
+ return 0; /* never reached */
+}
+
SCM_PROC(s_gsubr_apply, "gsubr-apply", 0, 0, 1, scm_gsubr_apply);
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index 09c3cd99b..1aa0209fa 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -61,6 +61,12 @@ extern SCM scm_f_gsubr_apply;
extern SCM scm_make_gsubr SCM_P ((const char *name, int req, int opt, int rst,
SCM (*fcn)()));
+extern SCM scm_make_gsubr_with_generic SCM_P ((const char *name,
+ int req,
+ int opt,
+ int rst,
+ SCM (*fcn)(),
+ SCM *gf));
extern SCM scm_gsubr_apply SCM_P ((SCM args));
extern void scm_init_gsubr SCM_P ((void));
diff --git a/libguile/init.c b/libguile/init.c
index ebdaf56cb..bf5c4e3f0 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -441,6 +441,7 @@ scm_boot_guile_1 (base, closure)
scm_smob_prehistory ();
scm_tables_prehistory ();
scm_init_storage (0);
+ scm_init_subr_table ();
scm_init_root ();
#ifdef USE_THREADS
scm_init_threads (base);
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 34aaf411e..3219d7821 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -141,7 +141,7 @@ scm_even_p (n)
return (4 & (int) n) ? SCM_BOOL_F : SCM_BOOL_T;
}
-SCM_PROC (s_abs, "abs", 1, 0, 0, scm_abs);
+SCM_GPROC (s_abs, "abs", 1, 0, 0, scm_abs, g_abs);
SCM
scm_abs (x)
@@ -150,13 +150,13 @@ scm_abs (x)
#ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_abs);
+ SCM_GASSERT1 (SCM_NIMP (x) && SCM_BIGP (x), g_abs, x, SCM_ARG1, s_abs);
if (SCM_TYP16 (x) == scm_tc16_bigpos)
return x;
return scm_copybig (x, 0);
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_abs);
+ SCM_GASSERT1 (SCM_INUMP (x), g_abs, x, SCM_ARG1, s_abs);
#endif
if (SCM_INUM (x) >= 0)
return x;
@@ -170,7 +170,7 @@ scm_abs (x)
return SCM_MAKINUM (x);
}
-SCM_PROC (s_quotient, "quotient", 2, 0, 0, scm_quotient);
+SCM_GPROC (s_quotient, "quotient", 2, 0, 0, scm_quotient, g_quotient);
SCM
scm_quotient (x, y)
@@ -182,7 +182,8 @@ scm_quotient (x, y)
if (SCM_NINUMP (x))
{
long w;
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_quotient);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_quotient, x, y, SCM_ARG1, s_quotient);
if (SCM_NINUMP (y))
{
SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
@@ -223,14 +224,14 @@ scm_quotient (x, y)
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_quotient);
+ SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient);
}
#endif
return SCM_INUM0;
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_quotient);
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_quotient);
+ SCM_GASSERT2 (SCM_INUMP (x), g_quotient, x, y, SCM_ARG1, s_quotient);
+ SCM_GASSERT2 (SCM_INUMP (y), g_quotient, x, y, SCM_ARG2, s_quotient);
#endif
if ((z = SCM_INUM (y)) == 0)
{
@@ -263,7 +264,7 @@ scm_quotient (x, y)
return SCM_MAKINUM (z);
}
-SCM_PROC (s_remainder, "remainder", 2, 0, 0, scm_remainder);
+SCM_GPROC (s_remainder, "remainder", 2, 0, 0, scm_remainder, g_remainder);
SCM
scm_remainder (x, y)
@@ -274,7 +275,8 @@ scm_remainder (x, y)
#ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_remainder);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_remainder, x, y, SCM_ARG1, s_remainder);
if (SCM_NINUMP (y))
{
SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
@@ -292,14 +294,14 @@ scm_remainder (x, y)
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_remainder);
+ SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder);
}
#endif
return x;
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_remainder);
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_remainder);
+ SCM_GASSERT2 (SCM_INUMP (x), g_remainder, x, y, SCM_ARG1, s_remainder);
+ SCM_GASSERT2 (SCM_INUMP (y), g_remainder, x, y, SCM_ARG2, s_remainder);
#endif
if (!(z = SCM_INUM (y)))
{
@@ -323,7 +325,7 @@ scm_remainder (x, y)
return SCM_MAKINUM (z);
}
-SCM_PROC (s_modulo, "modulo", 2, 0, 0, scm_modulo);
+SCM_GPROC (s_modulo, "modulo", 2, 0, 0, scm_modulo, g_modulo);
SCM
scm_modulo (x, y)
@@ -334,7 +336,8 @@ scm_modulo (x, y)
#ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_modulo);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_modulo, x, y, SCM_ARG1, s_modulo);
if (SCM_NINUMP (y))
{
SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
@@ -354,14 +357,14 @@ scm_modulo (x, y)
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_modulo);
+ SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo);
}
#endif
return (SCM_BIGSIGN (y) ? (x > 0) : (x < 0)) ? scm_sum (x, y) : x;
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_modulo);
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_modulo);
+ SCM_GASSERT1 (SCM_INUMP (x), g_modulo, x, y, SCM_ARG1, s_modulo);
+ SCM_GASSERT2 (SCM_INUMP (y), g_modulo, x, y, SCM_ARG2, s_modulo);
#endif
if (!(yy = SCM_INUM (y)))
{
@@ -377,7 +380,7 @@ scm_modulo (x, y)
return SCM_MAKINUM (((yy < 0) ? (z > 0) : (z < 0)) ? z + yy : z);
}
-SCM_PROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd);
+SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd);
SCM
scm_gcd (x, y)
@@ -392,13 +395,15 @@ scm_gcd (x, y)
if (SCM_NINUMP (x))
{
big_gcd:
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_gcd);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_gcd, x, y, SCM_ARG1, s_gcd);
if (SCM_BIGSIGN (x))
x = scm_copybig (x, 0);
newy:
if (SCM_NINUMP (y))
{
- SCM_ASSERT (SCM_NIMP (y) && SCM_BIGP (y), y, SCM_ARG2, s_gcd);
+ SCM_GASSERT2 (SCM_NIMP (y) && SCM_BIGP (y),
+ g_gcd, x, y, SCM_ARGn, s_gcd);
if (SCM_BIGSIGN (y))
y = scm_copybig (y, 0);
switch (scm_bigcomp (x, y))
@@ -430,8 +435,8 @@ scm_gcd (x, y)
goto big_gcd;
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_gcd);
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_gcd);
+ SCM_GASSERT2 (SCM_INUMP (x), g_gcd, x, y, SCM_ARG1, s_gcd);
+ SCM_GASSERT2 (SCM_INUMP (y), g_gcd, x, y, SCM_ARGn, s_gcd);
#endif
u = SCM_INUM (x);
if (u < 0)
@@ -474,7 +479,7 @@ scm_gcd (x, y)
return SCM_MAKINUM (u);
}
-SCM_PROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm);
+SCM_GPROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm, g_lcm);
SCM
scm_lcm (n1, n2)
@@ -482,12 +487,22 @@ scm_lcm (n1, n2)
SCM n2;
{
SCM d;
+#ifndef BIGDIG
+ SCM_GASSERT2 (SCM_INUMP (n1), g_lcm, n1, n2, SCM_ARG1, s_lcm);
+ SCM_GASSERT2 (SCM_INUMP (n2), g_lcm, n1, n2, SCM_ARGn, s_lcm);
+#else
+ SCM_GASSERT2 (SCM_INUMP (n1) || SCM_NIMP (n1) && SCM_BIGP (n1),
+ g_lcm, n1, n2, SCM_ARG1, s_lcm);
+ SCM_GASSERT2 (SCM_INUMP (n2) || SCM_NIMP (n2) && SCM_BIGP (n2),
+ g_lcm, n1, n2, SCM_ARGn, s_lcm);
+#endif
if (SCM_UNBNDP (n2))
{
n2 = SCM_MAKINUM (1L);
if (SCM_UNBNDP (n1))
return n2;
}
+
d = scm_gcd (n1, n2);
if (SCM_INUM0 == d)
return d;
@@ -2987,7 +3002,7 @@ scm_negative_p (x)
}
-SCM_PROC1 (s_max, "max", scm_tc7_asubr, scm_max);
+SCM_GPROC1 (s_max, "max", scm_tc7_asubr, scm_max, g_max);
SCM
scm_max (x, y)
@@ -3003,7 +3018,7 @@ scm_max (x, y)
if (!(SCM_NUMBERP (x)))
{
badx:
- scm_wta (x, (char *) SCM_ARG1, s_max);
+ SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARG1, s_max);
}
#endif
return x;
@@ -3026,7 +3041,8 @@ scm_max (x, y)
}
SCM_ASRTGO (SCM_REALP (x), badx);
#else
- SCM_ASSERT (SCM_NIMP (x) && SCM_REALP (x), x, SCM_ARG1, s_max);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_REALP (x),
+ g_max, x, y, SCM_ARG1, s_max);
#endif
if (SCM_INUMP (y))
return ((SCM_REALPART (x) < (z = SCM_INUM (y)))
@@ -3054,7 +3070,7 @@ scm_max (x, y)
if (!(SCM_REALP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_max);
+ SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
}
#endif
#else
@@ -3062,7 +3078,7 @@ scm_max (x, y)
if (!(SCM_NIMP (y) && SCM_REALP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_max);
+ SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
}
#endif
#endif
@@ -3074,7 +3090,8 @@ scm_max (x, y)
#ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_max);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_max, x, y, SCM_ARG1, s_max);
if (SCM_INUMP (y))
return SCM_BIGSIGN (x) ? y : x;
SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
@@ -3086,14 +3103,14 @@ scm_max (x, y)
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_max);
+ SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
}
#endif
return SCM_BIGSIGN (y) ? x : y;
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_max);
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_max);
+ SCM_GASSERT2 (SCM_INUMP (x), g_max, x, y, SCM_ARG1, s_max);
+ SCM_GASSERT2 (SCM_INUMP (y), g_max, x, y, SCM_ARGn, s_max);
#endif
#endif
return ((long) x < (long) y) ? y : x;
@@ -3102,7 +3119,7 @@ scm_max (x, y)
-SCM_PROC1 (s_min, "min", scm_tc7_asubr, scm_min);
+SCM_GPROC1 (s_min, "min", scm_tc7_asubr, scm_min, g_min);
SCM
scm_min (x, y)
@@ -3118,7 +3135,7 @@ scm_min (x, y)
if (!(SCM_NUMBERP (x)))
{
badx:
- scm_wta (x, (char *) SCM_ARG1, s_min);
+ SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min);
}
#endif
return x;
@@ -3141,7 +3158,8 @@ scm_min (x, y)
}
SCM_ASRTGO (SCM_REALP (x), badx);
#else
- SCM_ASSERT (SCM_NIMP (x) && SCM_REALP (x), x, SCM_ARG1, s_min);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_REALP (x),
+ g_min, x, y, SCM_ARG1, s_min);
#endif
if (SCM_INUMP (y))
return ((SCM_REALPART (x) > (z = SCM_INUM (y)))
@@ -3169,7 +3187,7 @@ scm_min (x, y)
if (!(SCM_REALP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_min);
+ SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
}
#endif
#else
@@ -3177,7 +3195,7 @@ scm_min (x, y)
if (!(SCM_NIMP (y) && SCM_REALP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_min);
+ SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
}
#endif
#endif
@@ -3189,7 +3207,8 @@ scm_min (x, y)
#ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_min);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_min, x, y, SCM_ARG1, s_min);
if (SCM_INUMP (y))
return SCM_BIGSIGN (x) ? x : y;
SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
@@ -3201,14 +3220,14 @@ scm_min (x, y)
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_min);
+ SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
}
#endif
return SCM_BIGSIGN (y) ? y : x;
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_min);
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_min);
+ SCM_GASSERT2 (SCM_INUMP (x), g_min, x, y, SCM_ARG1, s_min);
+ SCM_GASSERT2 (SCM_INUMP (y), g_min, x, y, SCM_ARGn, s_min);
#endif
#endif
return ((long) x > (long) y) ? y : x;
@@ -3217,7 +3236,7 @@ scm_min (x, y)
-SCM_PROC1 (s_sum, "+", scm_tc7_asubr, scm_sum);
+SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum);
SCM
scm_sum (x, y)
@@ -3232,7 +3251,7 @@ scm_sum (x, y)
if (!(SCM_NUMBERP (x)))
{
badx:
- scm_wta (x, (char *) SCM_ARG1, s_sum);
+ SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum);
}
#endif
return x;
@@ -3294,7 +3313,7 @@ scm_sum (x, y)
else if (!(SCM_INEXP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_sum);
+ SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
#endif
#else
@@ -3302,7 +3321,7 @@ scm_sum (x, y)
if (!(SCM_NIMP (y) && SCM_INEXP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_sum);
+ SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
#endif
#endif
@@ -3374,7 +3393,7 @@ scm_sum (x, y)
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_sum);
+ SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
#endif
intbig:
@@ -3391,7 +3410,7 @@ scm_sum (x, y)
}
#else
SCM_ASRTGO (SCM_INUMP (x), badx);
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_sum);
+ SCM_GASSERT2 (SCM_INUMP (y), g_sum, x, y, SCM_ARGn, s_sum);
#endif
#endif
x = SCM_INUM (x) + SCM_INUM (y);
@@ -3412,7 +3431,7 @@ scm_sum (x, y)
-SCM_PROC1 (s_difference, "-", scm_tc7_asubr, scm_difference);
+SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference);
SCM
scm_difference (x, y)
@@ -3426,7 +3445,7 @@ scm_difference (x, y)
if (!(SCM_NIMP (x)))
{
badx:
- scm_wta (x, (char *) SCM_ARG1, s_difference);
+ SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference);
}
#endif
if (SCM_UNBNDP (y))
@@ -3510,7 +3529,7 @@ scm_difference (x, y)
if (!(SCM_INEXP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_difference);
+ SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
#endif
#else
@@ -3518,7 +3537,7 @@ scm_difference (x, y)
if (!(SCM_NIMP (y) && SCM_INEXP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_difference);
+ SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
#endif
#endif
@@ -3529,7 +3548,8 @@ scm_difference (x, y)
#ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_difference);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_difference, x, y, SCM_ARG1, s_difference);
if (SCM_UNBNDP (y))
{
x = scm_copybig (x, !SCM_BIGSIGN (x));
@@ -3568,7 +3588,7 @@ scm_difference (x, y)
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_difference);
+ SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
#endif
{
@@ -3585,13 +3605,13 @@ scm_difference (x, y)
}
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_difference);
+ SCM_GASSERT2 (SCM_INUMP (x), g_difference, x, y, SCM_ARG1, s_difference);
if (SCM_UNBNDP (y))
{
x = -SCM_INUM (x);
goto checkx;
}
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_difference);
+ SCM_GASSERT2 (SCM_INUMP (y), g_difference, x, y, SCM_ARGn, s_difference);
#endif
#endif
x = SCM_INUM (x) - SCM_INUM (y);
@@ -3613,7 +3633,7 @@ scm_difference (x, y)
-SCM_PROC1 (s_product, "*", scm_tc7_asubr, scm_product);
+SCM_GPROC1 (s_product, "*", scm_tc7_asubr, scm_product, g_product);
SCM
scm_product (x, y)
@@ -3628,7 +3648,7 @@ scm_product (x, y)
if (!(SCM_NUMBERP (x)))
{
badx:
- scm_wta (x, (char *) SCM_ARG1, s_product);
+ SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARG1, s_product);
}
#endif
return x;
@@ -3685,7 +3705,7 @@ scm_product (x, y)
else if (!(SCM_INEXP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_product);
+ SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
}
#endif
#else
@@ -3693,7 +3713,7 @@ scm_product (x, y)
if (!(SCM_NIMP (y) && SCM_INEXP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_product);
+ SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
}
#endif
#endif
@@ -3770,7 +3790,7 @@ scm_product (x, y)
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_product);
+ SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
}
#endif
intbig:
@@ -3795,7 +3815,7 @@ scm_product (x, y)
}
#else
SCM_ASRTGO (SCM_INUMP (x), badx);
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_product);
+ SCM_GASSERT (SCM_INUMP (y), g_product, x, y, SCM_ARGn, s_product);
#endif
#endif
{
@@ -3858,7 +3878,7 @@ scm_num2dbl (a, why)
}
-SCM_PROC1 (s_divide, "/", scm_tc7_asubr, scm_divide);
+SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide);
SCM
scm_divide (x, y)
@@ -3873,7 +3893,7 @@ scm_divide (x, y)
if (!(SCM_NIMP (x)))
{
badx:
- scm_wta (x, (char *) SCM_ARG1, s_divide);
+ SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide);
}
#endif
if (SCM_UNBNDP (y))
@@ -3994,7 +4014,7 @@ scm_divide (x, y)
if (!(SCM_INEXP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_divide);
+ SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
#endif
#else
@@ -4002,7 +4022,7 @@ scm_divide (x, y)
if (!(SCM_NIMP (y) && SCM_INEXP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_divide);
+ SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
#endif
#endif
@@ -4020,7 +4040,8 @@ scm_divide (x, y)
if (SCM_NINUMP (x))
{
SCM z;
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_divide);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_divide, x, y, SCM_ARG1, s_divide);
if (SCM_UNBNDP (y))
goto ov;
if (SCM_INUMP (y))
@@ -4078,20 +4099,20 @@ scm_divide (x, y)
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_divide);
+ SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
#endif
goto ov;
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_divide);
+ SCM_GASSERT2 (SCM_INUMP (x), g_divide, x, y, SCM_ARG1, s_divide);
if (SCM_UNBNDP (y))
{
if ((SCM_MAKINUM (1L) == x) || (SCM_MAKINUM (-1L) == x))
return x;
goto ov;
}
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_divide);
+ SCM_GASSERT2 (SCM_INUMP (y), g_divide, x, y, SCM_ARGn, s_divide);
#endif
#endif
{
@@ -4119,7 +4140,7 @@ scm_divide (x, y)
#ifdef SCM_FLOATS
-SCM_PROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh);
+SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh, g_asinh);
double
scm_asinh (x)
@@ -4131,7 +4152,7 @@ scm_asinh (x)
-SCM_PROC1 (s_acosh, "$acosh", scm_tc7_cxr, (SCM (*)()) scm_acosh);
+SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_cxr, (SCM (*)()) scm_acosh, g_acosh);
double
scm_acosh (x)
@@ -4143,7 +4164,7 @@ scm_acosh (x)
-SCM_PROC1 (s_atanh, "$atanh", scm_tc7_cxr, (SCM (*)()) scm_atanh);
+SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_cxr, (SCM (*)()) scm_atanh, g_atanh);
double
scm_atanh (x)
@@ -4155,7 +4176,7 @@ scm_atanh (x)
-SCM_PROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate);
+SCM_GPROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate, g_truncate);
double
scm_truncate (x)
@@ -4168,7 +4189,7 @@ scm_truncate (x)
-SCM_PROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round);
+SCM_GPROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round, g_round);
double
scm_round (x)
@@ -4183,7 +4204,7 @@ scm_round (x)
-SCM_PROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM (*)()) scm_exact_to_inexact);
+SCM_GPROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM (*)()) scm_exact_to_inexact, g_exact_to_inexact);
double
scm_exact_to_inexact (z)
@@ -4193,21 +4214,21 @@ scm_exact_to_inexact (z)
}
-SCM_PROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor);
-SCM_PROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil);
-SCM_PROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)()) sqrt);
-SCM_PROC1 (s_i_abs, "$abs", scm_tc7_cxr, (SCM (*)()) fabs);
-SCM_PROC1 (s_i_exp, "$exp", scm_tc7_cxr, (SCM (*)()) exp);
-SCM_PROC1 (s_i_log, "$log", scm_tc7_cxr, (SCM (*)()) log);
-SCM_PROC1 (s_i_sin, "$sin", scm_tc7_cxr, (SCM (*)()) sin);
-SCM_PROC1 (s_i_cos, "$cos", scm_tc7_cxr, (SCM (*)()) cos);
-SCM_PROC1 (s_i_tan, "$tan", scm_tc7_cxr, (SCM (*)()) tan);
-SCM_PROC1 (s_i_asin, "$asin", scm_tc7_cxr, (SCM (*)()) asin);
-SCM_PROC1 (s_i_acos, "$acos", scm_tc7_cxr, (SCM (*)()) acos);
-SCM_PROC1 (s_i_atan, "$atan", scm_tc7_cxr, (SCM (*)()) atan);
-SCM_PROC1 (s_i_sinh, "$sinh", scm_tc7_cxr, (SCM (*)()) sinh);
-SCM_PROC1 (s_i_cosh, "$cosh", scm_tc7_cxr, (SCM (*)()) cosh);
-SCM_PROC1 (s_i_tanh, "$tanh", scm_tc7_cxr, (SCM (*)()) tanh);
+SCM_GPROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor, g_i_floor);
+SCM_GPROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil, g_i_ceil);
+SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)()) sqrt, g_i_sqrt);
+SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_cxr, (SCM (*)()) fabs, g_i_abs);
+SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_cxr, (SCM (*)()) exp, g_i_exp);
+SCM_GPROC1 (s_i_log, "$log", scm_tc7_cxr, (SCM (*)()) log, g_i_log);
+SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_cxr, (SCM (*)()) sin, g_i_sin);
+SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_cxr, (SCM (*)()) cos, g_i_cos);
+SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_cxr, (SCM (*)()) tan, g_i_tan);
+SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_cxr, (SCM (*)()) asin, g_i_asin);
+SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_cxr, (SCM (*)()) acos, g_i_acos);
+SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_cxr, (SCM (*)()) atan, g_i_atan);
+SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_cxr, (SCM (*)()) sinh, g_i_sinh);
+SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_cxr, (SCM (*)()) cosh, g_i_cosh);
+SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_cxr, (SCM (*)()) tanh, g_i_tanh);
struct dpair
{
@@ -4392,7 +4413,7 @@ scm_imag_part (z)
-SCM_PROC (s_magnitude, "magnitude", 1, 0, 0, scm_magnitude);
+SCM_GPROC (s_magnitude, "magnitude", 1, 0, 0, scm_magnitude, g_magnitude);
SCM
scm_magnitude (z)
@@ -4408,11 +4429,12 @@ scm_magnitude (z)
if (!(SCM_INEXP (z)))
{
badz:
- scm_wta (z, (char *) SCM_ARG1, s_magnitude);
+ SCM_WTA_DISPATCH_1 (g_magnitude, z, SCM_ARG1, s_magnitude);
}
#endif
#else
- SCM_ASSERT (SCM_NIMP (z) && SCM_INEXP (z), z, SCM_ARG1, s_magnitude);
+ SCM_GASSERT1 (SCM_NIMP (z) && SCM_INEXP (z),
+ g_magnitude, z, SCM_ARG1, s_magnitude);
#endif
if (SCM_CPLXP (z))
{
@@ -4425,7 +4447,7 @@ scm_magnitude (z)
-SCM_PROC (s_angle, "angle", 1, 0, 0, scm_angle);
+SCM_GPROC (s_angle, "angle", 1, 0, 0, scm_angle, g_angle);
SCM
scm_angle (z)
@@ -4448,11 +4470,11 @@ scm_angle (z)
if (!(SCM_INEXP (z)))
{
badz:
- scm_wta (z, (char *) SCM_ARG1, s_angle);
+ SCM_WTA_DISPATCH_1 (g_angle, z, SCM_ARG1, s_angle);
}
#endif
#else
- SCM_ASSERT (SCM_NIMP (z) && SCM_INEXP (z), z, SCM_ARG1, s_angle);
+ SCM_GASSERT1 (SCM_NIMP (z) && SCM_INEXP (z), g_angle, z, SCM_ARG1, s_angle);
#endif
if (SCM_REALP (z))
{
@@ -4509,13 +4531,13 @@ scm_inexact_to_exact (z)
#else /* ~SCM_FLOATS */
-SCM_PROC (s_trunc, "truncate", 1, 0, 0, scm_trunc);
+SCM_GPROC (s_trunc, "truncate", 1, 0, 0, scm_trunc, g_trunc);
SCM
scm_trunc (x)
SCM x;
{
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_truncate);
+ SCM_GASSERT2 (SCM_INUMP (x), g_trunc, x, y, SCM_ARG1, s_truncate);
return x;
}
diff --git a/libguile/objects.c b/libguile/objects.c
index b898d9383..0b0acf35e 100644
--- a/libguile/objects.c
+++ b/libguile/objects.c
@@ -52,6 +52,8 @@
#include "chars.h"
#include "keywords.h"
#include "smob.h"
+#include "eval.h"
+#include "alist.h"
#include "objects.h"
@@ -62,7 +64,7 @@ SCM scm_metaclass_operator;
/* These variables are filled in by the object system when loaded. */
SCM scm_class_boolean, scm_class_char, scm_class_pair;
SCM scm_class_procedure, scm_class_string, scm_class_symbol;
-SCM scm_class_procedure_with_setter;
+SCM scm_class_procedure_with_setter, scm_class_primitive_generic;
SCM scm_class_vector, scm_class_null;
SCM scm_class_integer, scm_class_real, scm_class_complex;
SCM scm_class_unknown;
@@ -72,6 +74,8 @@ SCM *scm_smob_class = 0;
SCM scm_apply_generic_env;
+SCM scm_no_applicable_method;
+
SCM (*scm_make_extended_class) (char *type_name);
void (*scm_make_port_classes) (int ptobnum, char *type_name);
void (*scm_change_object_class) (SCM, SCM, SCM);
@@ -137,6 +141,10 @@ scm_class_of (SCM x)
case scm_tc7_subr_2o:
case scm_tc7_lsubr_2:
case scm_tc7_lsubr:
+ if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x))
+ return scm_class_primitive_generic;
+ else
+ return scm_class_procedure;
case scm_tc7_cclo:
return scm_class_procedure;
case scm_tc7_pws:
@@ -209,6 +217,147 @@ scm_class_of (SCM x)
return scm_class_unknown;
}
+SCM
+scm_mcache_lookup_cmethod (SCM cache, SCM args)
+{
+ int i, n, end, mask;
+ SCM ls, methods, z = SCM_CDDR (cache);
+ n = SCM_INUM (SCM_CAR (z)); /* maximum number of specializers */
+ methods = SCM_CADR (z);
+
+ if (SCM_NIMP (methods))
+ {
+ /* Prepare for linear search */
+ mask = -1;
+ i = 0;
+ end = SCM_LENGTH (methods);
+ }
+ else
+ {
+ /* Compute a hash value */
+ int hashset = SCM_INUM (methods);
+ int j = n;
+ mask = SCM_INUM (SCM_CAR (z = SCM_CDDR (z)));
+ methods = SCM_CADR (z);
+ i = 0;
+ ls = args;
+ do
+ {
+ i += (SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls)))
+ [scm_si_hashsets + hashset]);
+ ls = SCM_CDR (ls);
+ }
+ while (--j && SCM_NIMP (ls));
+ i &= mask;
+ end = i;
+ }
+
+ /* Search for match */
+ do
+ {
+ int j = n;
+ z = SCM_VELTS (methods)[i];
+ ls = args; /* list of arguments */
+ do
+ {
+ /* More arguments than specifiers => CLASS != ENV */
+ if (scm_class_of (SCM_CAR (ls)) != SCM_CAR (z))
+ goto next_method;
+ ls = SCM_CDR (ls);
+ z = SCM_CDR (z);
+ }
+ while (--j && SCM_NIMP (ls));
+ /* Fewer arguments than specifiers => CAR != ENV */
+ if (!SCM_CONSP (SCM_CAR (z)))
+ goto next_method;
+ return z;
+ next_method:
+ i = (i + 1) & mask;
+ } while (i != end);
+ return SCM_BOOL_F;
+}
+
+SCM
+scm_mcache_create_cmethod (SCM cache, SCM args)
+{
+ SCM cmethod = scm_mcache_lookup_cmethod (cache, args);
+ if (SCM_IMP (cmethod))
+ /* No match - memoize */
+ return scm_memoize_method (cache, args);
+ return cmethod;
+}
+
+SCM
+scm_call_generic_0 (SCM gf)
+{
+ SCM clos = SCM_ENTITY_PROC_0 (gf);
+ if (SCM_CLOSUREP (clos))
+ return scm_eval_body (SCM_CDR (SCM_CODE (clos)),
+ SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (clos)),
+ SCM_LIST1 (gf),
+ SCM_ENV (clos)));
+ else
+ return SCM_SUBRF (clos) (gf);
+}
+
+SCM
+scm_call_generic_1 (SCM gf, SCM a1)
+{
+ SCM args = SCM_LIST1 (a1);
+ SCM cmethod = scm_mcache_create_cmethod (SCM_ENTITY_PROC_1 (gf), args);
+ return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
+ SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
+ args,
+ SCM_CMETHOD_ENV (cmethod)));
+}
+
+SCM
+scm_call_generic_2 (SCM gf, SCM a1, SCM a2)
+{
+ SCM args = SCM_LIST2 (a1, a2);
+ SCM cmethod = scm_mcache_create_cmethod (SCM_ENTITY_PROC_2 (gf), args);
+ if (SCM_IMP (cmethod))
+ return scm_call_generic_2 (scm_no_applicable_method, gf, args);
+ return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
+ SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
+ args,
+ SCM_CMETHOD_ENV (cmethod)));
+}
+
+SCM
+scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
+{
+ SCM args = SCM_LIST3 (a1, a2, a3);
+ SCM cmethod = scm_mcache_create_cmethod (SCM_ENTITY_PROC_3 (gf), args);
+ if (SCM_IMP (cmethod))
+ return scm_call_generic_2 (scm_no_applicable_method, gf, args);
+ return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
+ SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
+ args,
+ SCM_CMETHOD_ENV (cmethod)));
+}
+
+SCM
+scm_apply_generic (SCM gf, SCM args)
+{
+ if (SCM_NULLP (args))
+ return scm_call_generic_0 (gf);
+ {
+ SCM cache = (SCM_NULLP (SCM_CDR (args))
+ ? SCM_ENTITY_PROC_1 (gf)
+ : (SCM_NULLP (SCM_CDDR (args))
+ ? SCM_ENTITY_PROC_2 (gf)
+ : SCM_ENTITY_PROC_3 (gf)));
+ SCM cmethod = scm_mcache_create_cmethod (cache, args);
+ if (SCM_IMP (cmethod))
+ return scm_call_generic_2 (scm_no_applicable_method, gf, args);
+ return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
+ SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
+ args,
+ SCM_CMETHOD_ENV (cmethod)));
+ }
+}
+
SCM_PROC (s_entity_p, "entity?", 1, 0, 0, scm_entity_p);
SCM
diff --git a/libguile/objects.h b/libguile/objects.h
index 6ca410581..01092ef31 100644
--- a/libguile/objects.h
+++ b/libguile/objects.h
@@ -193,6 +193,9 @@ typedef struct scm_effective_slot_definition {
#define SCM_ESLOTDEF(x) ((scm_effective_slot_definition *) SCM_CDR (x))
+#define SCM_CMETHOD_CODE(cmethod) SCM_CDR (cmethod)
+#define SCM_CMETHOD_ENV(cmethod) SCM_CAR (cmethod)
+
/* Port classes */
#define SCM_IN_PCLASS_INDEX 0x000
#define SCM_OUT_PCLASS_INDEX 0x100
@@ -203,7 +206,7 @@ extern SCM scm_metaclass_standard;
extern SCM scm_metaclass_operator;
extern SCM scm_class_boolean, scm_class_char, scm_class_pair;
extern SCM scm_class_procedure, scm_class_string, scm_class_symbol;
-extern SCM scm_class_procedure_with_setter;
+extern SCM scm_class_procedure_with_setter, scm_class_primitive_generic;
extern SCM scm_class_vector, scm_class_null;
extern SCM scm_class_real, scm_class_complex, scm_class_integer;
extern SCM scm_class_unknown;
@@ -212,15 +215,26 @@ extern SCM *scm_smob_class;
extern SCM scm_apply_generic_env;
+extern SCM scm_no_applicable_method;
+
/* Plugin Goops functions. */
extern SCM (*scm_make_extended_class) (char *type_name);
extern void (*scm_make_port_classes) (int ptobnum, char *type_name);
extern void (*scm_change_object_class) (SCM, SCM, SCM);
-extern void (*scm_memoize_method) (SCM x, SCM args);
+extern SCM (*scm_memoize_method) (SCM x, SCM args);
extern SCM scm_sym_atdispatch;
extern SCM scm_class_of (SCM obj);
+extern SCM scm_mcache_lookup_cmethod (SCM cache, SCM args);
+extern SCM scm_mcache_create_cmethod (SCM cache, SCM args);
+extern SCM scm_call_generic_0 (SCM gf);
+/* The following are declared in __scm.h
+extern SCM scm_call_generic_1 (SCM gf, SCM a1);
+extern SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2);
+*/
+extern SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3);
+extern SCM scm_apply_generic (SCM gf, SCM args);
extern SCM scm_entity_p (SCM obj);
extern SCM scm_operator_p (SCM obj);
extern SCM scm_set_object_procedure_x (SCM obj, SCM procs);
diff --git a/libguile/print.c b/libguile/print.c
index d90c77f3e..024ccc5b9 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -589,7 +589,10 @@ taloop:
scm_raprin1 (exp, port, pstate);
break;
case scm_tcs_subrs:
- scm_puts ("#<primitive-procedure ", port);
+ scm_puts (SCM_SUBR_GENERIC (exp) && *SCM_SUBR_GENERIC (exp)
+ ? "#<primitive-generic "
+ : "#<primitive-procedure ",
+ port);
scm_puts (SCM_CHARS (SCM_SNAME (exp)), port);
scm_putc ('>', port);
break;
diff --git a/libguile/procs.c b/libguile/procs.c
index c38906ea6..a0ea5163f 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -52,6 +52,12 @@
/* {Procedures}
*/
+scm_subr_entry *scm_subr_table;
+
+/* libguile contained approx. 700 primitive procedures 990824. */
+
+int scm_subr_table_size = 0;
+int scm_subr_table_room = 750;
SCM
scm_make_subr_opt (name, type, fcn, set)
@@ -61,21 +67,51 @@ scm_make_subr_opt (name, type, fcn, set)
int set;
{
SCM symcell;
- long tmp;
register SCM z;
- symcell = scm_sysintern (name, SCM_UNDEFINED);
- tmp = ((((SCM_CELLPTR) (SCM_CAR (symcell))) - scm_heap_org) << 8);
- if ((tmp >> 8) != ((SCM_CELLPTR) (SCM_CAR (symcell)) - scm_heap_org))
- tmp = 0;
+ int entry;
+
+ if (scm_subr_table_size == scm_subr_table_room)
+ {
+ scm_sizet new_size = scm_port_table_room * 3 / 2;
+ void *new_table = scm_must_realloc ((char *) scm_subr_table,
+ scm_subr_table_room,
+ new_size,
+ "scm_make_subr_opt");
+ scm_subr_table = new_table;
+ scm_subr_table_room = new_size;
+ }
+
SCM_NEWCELL (z);
+ symcell = set ? scm_sysintern0 (name) : scm_intern0 (name);
+
+ entry = scm_subr_table_size;
+ scm_subr_table[entry].handle = z;
+ scm_subr_table[entry].name = SCM_CAR (symcell);
+ scm_subr_table[entry].generic = 0;
+ scm_subr_table[entry].properties = SCM_EOL;
+ scm_subr_table[entry].documentation = SCM_BOOL_F;
+
SCM_SUBRF (z) = fcn;
- SCM_SETCAR (z, tmp + type);
+ SCM_SETCAR (z, (entry << 8) + type);
+ scm_subr_table_size++;
+
if (set)
SCM_SETCDR (symcell, z);
+
return z;
}
-
+/* This function isn't currently used since subrs are never freed. */
+/* *fixme* Need mutex here. */
+void
+scm_free_subr_entry (SCM subr)
+{
+ int entry = SCM_SUBRNUM (subr);
+ /* Move last entry in table to the free position */
+ scm_subr_table[entry] = scm_subr_table[scm_subr_table_size - 1];
+ SCM_SET_SUBRNUM (scm_subr_table[entry].handle, entry);
+ scm_subr_table_size--;
+}
SCM
scm_make_subr (name, type, fcn)
@@ -86,8 +122,32 @@ scm_make_subr (name, type, fcn)
return scm_make_subr_opt (name, type, fcn, 1);
}
-#ifdef CCLO
+SCM
+scm_make_subr_with_generic (const char *name, int type, SCM (*fcn) (), SCM *gf)
+{
+ SCM subr = scm_make_subr_opt (name, type, fcn, 1);
+ scm_subr_table[scm_subr_table_size - 1].generic = gf;
+ return subr;
+}
+
+void
+scm_mark_subr_table ()
+{
+ int i;
+ for (i = 0; i < scm_subr_table_size; ++i)
+ {
+ SCM_SETGC8MARK (scm_subr_table[i].name);
+ if (scm_subr_table[i].generic && *scm_subr_table[i].generic)
+ scm_gc_mark (*scm_subr_table[i].generic);
+ if (SCM_NIMP (scm_subr_table[i].properties))
+ scm_gc_mark (scm_subr_table[i].properties);
+ if (SCM_NIMP (scm_subr_table[i].documentation))
+ scm_gc_mark (scm_subr_table[i].documentation);
+ }
+}
+
+#ifdef CCLO
SCM
scm_makcclo (proc, len)
SCM proc;
@@ -194,6 +254,21 @@ scm_thunk_p (obj)
return SCM_BOOL_F;
}
+/* Only used internally. */
+int
+scm_subr_p (SCM obj)
+{
+ if (SCM_NIMP (obj))
+ switch (SCM_TYP7 (obj))
+ {
+ case scm_tcs_subrs:
+ return 1;
+ default:
+ ;
+ }
+ return 0;
+}
+
SCM_PROC(s_procedure_documentation, "procedure-documentation", 1, 0, 0, scm_procedure_documentation);
SCM
@@ -293,6 +368,7 @@ scm_setter (SCM proc)
return 0;
}
+
void
scm_init_iprocs(subra, type)
const scm_iproc *subra;
@@ -305,12 +381,17 @@ scm_init_iprocs(subra, type)
}
-
-
+void
+scm_init_subr_table ()
+{
+ scm_subr_table
+ = ((scm_subr_entry *)
+ scm_must_malloc (sizeof (scm_subr_entry) * scm_subr_table_room,
+ "scm_subr_table"));
+}
void
scm_init_procs ()
{
#include "procs.x"
}
-
diff --git a/libguile/procs.h b/libguile/procs.h
index 12511d96f..7bced8a21 100644
--- a/libguile/procs.h
+++ b/libguile/procs.h
@@ -70,11 +70,30 @@ typedef struct scm_dsubr
double (*dproc) ();
} scm_dsubr;
-#define SCM_SNAME(x) ((SCM_CAR(x)>>8)?(SCM)(scm_heap_org+(SCM_CAR(x)>>8)):scm_nullstr)
+typedef struct
+{
+ SCM handle; /* link back to procedure object */
+ SCM name;
+ SCM *generic; /* 0 if no generic support
+ * *generic == 0 until first method
+ */
+ SCM properties; /* procedure properties */
+ SCM documentation;
+} scm_subr_entry;
+
+#define SCM_SUBRNUM(subr) (SCM_CAR (subr) >> 8)
+#define SCM_SET_SUBRNUM(subr, num) \
+ SCM_SETCAR (subr, (num >> 8) + SCM_TYP7 (subr))
+#define SCM_SUBR_ENTRY(x) (scm_subr_table[SCM_SUBRNUM (x)])
+#define SCM_SNAME(x) (SCM_SUBR_ENTRY (x).name)
#define SCM_SUBRF(x) (((scm_subr *)(SCM2PTR(x)))->cproc)
#define SCM_DSUBRF(x) (((scm_dsubr *)(SCM2PTR(x)))->dproc)
#define SCM_CCLO_SUBR(x) (SCM_VELTS(x)[0])
+#define SCM_SUBR_GENERIC(x) (SCM_SUBR_ENTRY (x).generic)
+#define SCM_SUBR_PROPS(x) (SCM_SUBR_ENTRY (x).properties)
+#define SCM_SUBR_DOC(x) (SCM_SUBR_ENTRY (x).documentation)
+
/* Closures
*/
@@ -139,9 +158,19 @@ typedef struct scm_dsubr
#define SCM_PROCEDURE(obj) SCM_CADR (obj)
#define SCM_SETTER(obj) SCM_CDDR (obj)
+extern scm_subr_entry *scm_subr_table;
+extern int scm_subr_table_size;
+extern int scm_subr_table_room;
+
+extern void scm_mark_subr_table (void);
+extern void scm_free_subr_entry (SCM subr);
extern SCM scm_make_subr SCM_P ((const char *name, int type, SCM (*fcn) ()));
+extern SCM scm_make_subr_with_generic (const char *name,
+ int type,
+ SCM (*fcn) (),
+ SCM *gf);
extern SCM scm_make_subr_opt SCM_P ((const char *name,
int type,
SCM (*fcn) (),
@@ -150,12 +179,14 @@ extern SCM scm_makcclo SCM_P ((SCM proc, long len));
extern SCM scm_procedure_p SCM_P ((SCM obj));
extern SCM scm_closure_p SCM_P ((SCM obj));
extern SCM scm_thunk_p SCM_P ((SCM obj));
+extern int scm_subr_p (SCM obj);
extern SCM scm_procedure_documentation SCM_P ((SCM proc));
extern SCM scm_procedure_with_setter_p SCM_P ((SCM obj));
extern SCM scm_make_procedure_with_setter SCM_P ((SCM procedure, SCM setter));
extern SCM scm_procedure SCM_P ((SCM proc));
extern SCM scm_setter SCM_P ((SCM proc));
extern void scm_init_iprocs SCM_P ((const scm_iproc *subra, int type));
+extern void scm_init_subr_table (void);
extern void scm_init_procs SCM_P ((void));
#ifdef GUILE_DEBUG
diff --git a/libguile/snarf.h b/libguile/snarf.h
index ae51deefe..052d8f012 100644
--- a/libguile/snarf.h
+++ b/libguile/snarf.h
@@ -51,19 +51,33 @@
#ifndef SCM_MAGIC_SNARFER
#define SCM_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
#define SCM_PROC1(RANAME, STR, TYPE, CFN) \
static const char RANAME[]=STR
+#define SCM_GPROC1(RANAME, STR, TYPE, CFN, GF) \
+ static const char RANAME[]=STR; \
+ static SCM GF = 0
#else
#if defined(__cplusplus) || defined(GUILE_CPLUSPLUS_SNARF)
#define SCM_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) \
%%% scm_make_subr(RANAME, TYPE, (SCM (*)(...))CFN)
+#define SCM_GPROC1(RANAME, STR, TYPE, CFN, GF) \
+%%% scm_make_subr_with_generic(RANAME, TYPE, (SCM (*)(...))CFN, &GF)
#else
#define SCM_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) \
%%% scm_make_subr(RANAME, TYPE, CFN)
+#define SCM_GPROC1(RANAME, STR, TYPE, CFN, GF) \
+%%% scm_make_subr_with_generic(RANAME, TYPE, CFN, &GF)
#endif
#endif