diff options
author | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 1999-08-26 04:24:42 +0000 |
---|---|---|
committer | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 1999-08-26 04:24:42 +0000 |
commit | 9de33deb2ea07bf6c93651bbd693e7484dd29b33 (patch) | |
tree | ce3f42882590ee80cfb30221518a120920104a31 /libguile/objects.c | |
parent | 52235e71737b47b648b5511396073f023d08a78e (diff) | |
download | guile-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.
Diffstat (limited to 'libguile/objects.c')
-rw-r--r-- | libguile/objects.c | 151 |
1 files changed, 150 insertions, 1 deletions
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 |