mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 04:10:18 +02:00
Code Activity

* procs.c, procs.h (scm_subr_entry): New type: Stores data

Browse source 
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.
This commit is contained in:
Mikael Djurfeldt 1999-08-26 04:24:42 +00:00
parent 52235e7173
commit 9de33deb2e
15 changed files with 614 additions and 128 deletions
Download patch file Download diff file Expand all files Collapse all files

78
libguile/ChangeLog
View file

@ -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

22
libguile/__scm.h
View file

@ -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

48
libguile/eval.c
View file

@ -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);

1
libguile/eval.h
View file

@ -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));

8
libguile/gc.c
View file

@ -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))

34
libguile/gsubr.c
View file

@ -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);

6
libguile/gsubr.h
View file

@ -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));

1
libguile/init.c
View file

@ -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);

220
libguile/numbers.c
View file

@ -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;
}

151
libguile/objects.c
View file

@ -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

18
libguile/objects.h
View file

@ -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);

5
libguile/print.c
View file

@ -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;

103
libguile/procs.c
View file

@ -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"
}

33
libguile/procs.h
View file

@ -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

14
libguile/snarf.h
View file

@ -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