summaryrefslogtreecommitdiff
path: root/libguile/objects.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/objects.c')
-rw-r--r--libguile/objects.c151
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