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 + + 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 + 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 ("#', 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