diff options
author | Andy Wingo <wingo@pobox.com> | 2009-11-01 20:45:02 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-11-15 20:28:12 +0100 |
commit | efcebb5b56a315f42c32e8bbc682d218a38c9428 (patch) | |
tree | 3b24d189c8ffeefa2cd675a47fb331f54dfd1f65 /libguile/goops.c | |
parent | 11561496bad94481cc2b3d8acba1a154e3c052fc (diff) | |
download | guile-efcebb5b56a315f42c32e8bbc682d218a38c9428.tar.gz |
fold objects.[ch] into goops.[ch]
Remove objects.h #includes as appropriate.
Diffstat (limited to 'libguile/goops.c')
-rw-r--r-- | libguile/goops.c | 165 |
1 files changed, 160 insertions, 5 deletions
diff --git a/libguile/goops.c b/libguile/goops.c index 0a97a4a42..c6188ba3a 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -44,9 +44,9 @@ #include "libguile/keywords.h" #include "libguile/macros.h" #include "libguile/modules.h" -#include "libguile/objects.h" #include "libguile/ports.h" #include "libguile/procprop.h" +#include "libguile/programs.h" #include "libguile/random.h" #include "libguile/root.h" #include "libguile/smob.h" @@ -54,12 +54,23 @@ #include "libguile/strports.h" #include "libguile/vectors.h" #include "libguile/weaks.h" +#include "libguile/vm.h" #include "libguile/validate.h" #include "libguile/goops.h" #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers) +#define SCM_CMETHOD_CODE(cmethod) SCM_CDR (cmethod) +#define SCM_CMETHOD_FORMALS(cmethod) SCM_CAR (SCM_CMETHOD_CODE (cmethod)) +#define SCM_CMETHOD_BODY(cmethod) SCM_CDR (SCM_CMETHOD_CODE (cmethod)) +#define SCM_CMETHOD_ENV(cmethod) SCM_CAR (cmethod) + +/* Port classes */ +#define SCM_IN_PCLASS_INDEX 0 +#define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT +#define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT) + /* this file is a mess. in theory, though, we shouldn't have many SCM references -- most of the references should be to vars. */ @@ -105,10 +116,6 @@ SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic"); h1. */ -/* The following definition is located in libguile/objects.h: -#define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined]) -*/ - #define TEST_CHANGE_CLASS(obj, class) \ { \ class = SCM_CLASS_OF (obj); \ @@ -1777,6 +1784,154 @@ static SCM list_of_no_method; SCM_GLOBAL_SYMBOL (scm_sym_args, "args"); +/* The cache argument for scm_mcache_lookup_cmethod has one of two possible + * formats: + * + * Format #1: + * (SCM_IM_DISPATCH ARGS N-SPECIALIZED + * #((TYPE1 ... ENV FORMALS FORM ...) ...) + * GF) + * + * Format #2: + * (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK + * #((TYPE1 ... ENV FORMALS FORM ...) ...) + * GF) + * + * ARGS is either a list of expressions, in which case they + * are interpreted as the arguments of an application, or + * a non-pair, which is interpreted as a single expression + * yielding all arguments. + * + * SCM_IM_DISPATCH expressions in generic functions always + * have ARGS = the symbol `args' or the iloc #@0-0. + * + * Need FORMALS in order to support varying arity. This + * also avoids the need for renaming of bindings. + * + * We should probably not complicate this mechanism by + * introducing "optimizations" for getters and setters or + * primitive methods. Getters and setter will normally be + * compiled into @slot-[ref|set!] or a procedure call. + * They rely on the dispatch performed before executing + * the code which contains them. + * + * We might want to use a more efficient representation of + * this form in the future, perhaps after we have introduced + * low-level support for syntax-case macros. + */ + +SCM +scm_mcache_lookup_cmethod (SCM cache, SCM args) +{ + unsigned long i, mask, n, end; + SCM ls, methods, z = SCM_CDDR (cache); + n = scm_to_ulong (SCM_CAR (z)); /* maximum number of specializers */ + methods = SCM_CADR (z); + + if (scm_is_simple_vector (methods)) + { + /* cache format #1: prepare for linear search */ + mask = -1; + i = 0; + end = SCM_SIMPLE_VECTOR_LENGTH (methods); + } + else + { + /* cache format #2: compute a hash value */ + unsigned long hashset = scm_to_ulong (methods); + long j = n; + z = SCM_CDDR (z); + mask = scm_to_ulong (SCM_CAR (z)); + methods = SCM_CADR (z); + i = 0; + ls = args; + if (!scm_is_null (ls)) + do + { + i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls))) + [scm_si_hashsets + hashset]; + ls = SCM_CDR (ls); + } + while (j-- && !scm_is_null (ls)); + i &= mask; + end = i; + } + + /* Search for match */ + do + { + long j = n; + z = SCM_SIMPLE_VECTOR_REF (methods, i); + ls = args; /* list of arguments */ + if (!scm_is_null (ls)) + do + { + /* More arguments than specifiers => CLASS != ENV */ + if (! scm_is_eq (scm_class_of (SCM_CAR (ls)), SCM_CAR (z))) + goto next_method; + ls = SCM_CDR (ls); + z = SCM_CDR (z); + } + while (j-- && !scm_is_null (ls)); + /* Fewer arguments than specifiers => CAR != CLASS or `no-method' */ + if (!scm_is_pair (z) + || (!SCM_CLASSP (SCM_CAR (z)) && !scm_is_symbol (SCM_CAR (z)))) + return z; + next_method: + i = (i + 1) & mask; + } while (i != end); + return SCM_BOOL_F; +} + +SCM +scm_mcache_compute_cmethod (SCM cache, SCM args) +{ + SCM cmethod = scm_mcache_lookup_cmethod (cache, args); + if (scm_is_false (cmethod)) + /* No match - memoize */ + return scm_memoize_method (cache, args); + return cmethod; +} + +SCM +scm_apply_generic (SCM gf, SCM args) +{ + SCM cmethod = scm_mcache_compute_cmethod (SCM_GENERIC_METHOD_CACHE (gf), args); + if (SCM_PROGRAM_P (cmethod)) + return scm_vm_apply (scm_the_vm (), cmethod, args); + else if (scm_is_pair (cmethod)) + return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)), + SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)), + args, + SCM_CMETHOD_ENV (cmethod))); + else + return scm_apply (cmethod, args, SCM_EOL); +} + +SCM +scm_call_generic_0 (SCM gf) +{ + return scm_apply_generic (gf, SCM_EOL); +} + +SCM +scm_call_generic_1 (SCM gf, SCM a1) +{ + return scm_apply_generic (gf, scm_list_1 (a1)); +} + +SCM +scm_call_generic_2 (SCM gf, SCM a1, SCM a2) +{ + return scm_apply_generic (gf, scm_list_2 (a1, a2)); +} + +SCM +scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3) +{ + return scm_apply_generic (gf, scm_list_3 (a1, a2, a3)); +} + SCM scm_make_method_cache (SCM gf) { |