summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>1999-01-05 09:25:59 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>1999-01-05 09:25:59 +0000
commit98fae09612357fbf7efe3463d5cef35f6821b112 (patch)
tree1dc0ca2f1618e1240b643aeaca70e86d119b7886 /libguile
parente1f2bf99e9c4fa9f03e3c74f5ec8e2f1b70dee03 (diff)
downloadguile-98fae09612357fbf7efe3463d5cef35f6821b112.tar.gz
*** empty log message ***
Diffstat (limited to 'libguile')
-rw-r--r--libguile/eval.c52
-rw-r--r--libguile/gc.c16
-rw-r--r--libguile/objects.c120
-rw-r--r--libguile/objects.h18
-rw-r--r--libguile/struct.h2
-rw-r--r--libguile/tags.h2
6 files changed, 207 insertions, 3 deletions
diff --git a/libguile/eval.c b/libguile/eval.c
index 02811b1d5..33062ee25 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -93,6 +93,9 @@ char *alloca ();
#include "feature.h"
#include "eval.h"
+
+void (*scm_memoize_method) (SCM, SCM);
+
/* The evaluator contains a plethora of EVAL symbols.
@@ -1975,6 +1978,55 @@ dispatch:
ENTER_APPLY;
goto evap1;
+ case (SCM_ISYMNUM (SCM_IM_DISPATCH)):
+ {
+ int i, end, mask;
+ mask = -1;
+ proc = SCM_CDR (x);
+ i = 0;
+ end = SCM_LENGTH (proc);
+ find_method:
+ do
+ {
+ t.arg1 = SCM_CDDAR (env);
+ arg2 = SCM_VELTS (proc)[i];
+ do
+ {
+ if (scm_class_of (SCM_CAR (t.arg1)) != SCM_CAR (arg2))
+ goto next_method;
+ t.arg1 = SCM_CDR (t.arg1);
+ arg2 = SCM_CDR (arg2);
+ }
+ while (SCM_NIMP (t.arg1));
+ x = SCM_CAR (arg2);
+ env = scm_cons (SCM_CAR (env), SCM_CDR (arg2));
+ goto begin;
+ next_method:
+ i = (i + 1) & mask;
+ } while (i != end);
+ memoize_method:
+ scm_memoize_method (x, SCM_CDAR (env));
+ goto loop;
+
+ case (SCM_ISYMNUM (SCM_IM_HASH_DISPATCH)):
+ {
+ int hashset = SCM_INUM (SCM_CADR (x));
+ mask = SCM_INUM (SCM_CADDR (x));
+ proc = SCM_CDDDR (x);
+ i = 0;
+ t.arg1 = SCM_CDDAR (env);
+ do
+ {
+ i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t.arg1)))[scm_si_hashsets + hashset];
+ t.arg1 = SCM_CDR (t.arg1);
+ }
+ while (SCM_NIMP (t.arg1));
+ i &= mask;
+ end = i;
+ }
+ goto find_method;
+ }
+
default:
goto badfun;
}
diff --git a/libguile/gc.c b/libguile/gc.c
index 46b4507ed..823c3ce4c 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -1113,9 +1113,19 @@ scm_gc_sweep ()
if ((SCM_CDR (vcell) == 0) || (SCM_CDR (vcell) == 1))
{
SCM *p = (SCM *) SCM_GCCDR (scmptr);
- m += p[scm_struct_i_n_words] * sizeof (SCM);
- /* I feel like I'm programming in BCPL here... */
- free ((char *) p[scm_struct_i_ptr]);
+ if (((SCM*) vcell)[scm_vtable_index_layout]
+ & SCM_STRUCTF_LIGHT)
+ {
+ SCM layout = ((SCM*)vcell)[scm_vtable_index_layout];
+ m += SCM_LENGTH (layout) / 2;
+ free ((char *) p);
+ }
+ else
+ {
+ m += p[scm_struct_i_n_words] * sizeof (SCM);
+ /* I feel like I'm programming in BCPL here... */
+ free ((char *) p[scm_struct_i_ptr]);
+ }
}
}
break;
diff --git a/libguile/objects.c b/libguile/objects.c
index cbb6b4ca9..a55209b13 100644
--- a/libguile/objects.c
+++ b/libguile/objects.c
@@ -49,6 +49,8 @@
#include "struct.h"
#include "procprop.h"
+#include "chars.h"
+#include "kw.h"
#include "objects.h"
@@ -56,6 +58,124 @@
SCM scm_metaclass_standard;
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_vector, scm_class_null;
+SCM scm_class_real, scm_class_complex, scm_class_integer;
+SCM scm_class_keyword, scm_class_unknown;
+
+void (*scm_change_object_class) (SCM, SCM, SCM);
+
+/* This function is used for efficient type dispatch. */
+SCM
+scm_class_of (SCM x)
+{
+ switch (SCM_ITAG3 (x))
+ {
+ case scm_tc3_int_1:
+ case scm_tc3_int_2:
+ return scm_class_integer;
+
+ case scm_tc3_imm24:
+ if (SCM_ICHRP (x))
+ return scm_class_char;
+ else
+ {
+ switch (SCM_ISYMNUM (x))
+ {
+ case SCM_ISYMNUM (SCM_BOOL_F):
+ case SCM_ISYMNUM (SCM_BOOL_T):
+ return scm_class_boolean;
+ case SCM_ISYMNUM (SCM_EOL):
+ return scm_class_null;
+ default:
+ return scm_class_unknown;
+ }
+ }
+
+ case scm_tc3_cons:
+ switch (SCM_TYP7 (x))
+ {
+ case scm_tcs_cons_nimcar:
+ return scm_class_pair;
+ case scm_tcs_closures:
+ return scm_class_procedure;
+ case scm_tcs_symbols:
+ return scm_class_symbol;
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ case scm_tc7_bvect:
+ case scm_tc7_byvect:
+ case scm_tc7_svect:
+ case scm_tc7_ivect:
+ case scm_tc7_uvect:
+ case scm_tc7_fvect:
+ case scm_tc7_dvect:
+ case scm_tc7_cvect:
+ return scm_class_vector;
+ case scm_tc7_string:
+ case scm_tc7_substring:
+ return scm_class_string;
+ case scm_tc7_asubr:
+ case scm_tc7_subr_0:
+ case scm_tc7_subr_1:
+ case scm_tc7_cxr:
+ case scm_tc7_subr_3:
+ case scm_tc7_subr_2:
+ case scm_tc7_rpsubr:
+ case scm_tc7_subr_1o:
+ case scm_tc7_subr_2o:
+ case scm_tc7_lsubr_2:
+ case scm_tc7_lsubr:
+ return scm_class_procedure;
+
+ case scm_tc7_port:
+ return scm_class_unknown;
+ case scm_tc7_smob:
+ {
+ SCM type = SCM_TYP16 (x);
+ if (type == scm_tc16_flo)
+ {
+ if (SCM_CAR (x) & SCM_IMAG_PART)
+ return scm_class_complex;
+ else
+ return scm_class_real;
+ }
+ else if (type == scm_tc16_bigpos || type == scm_tc16_bigneg)
+ return scm_class_integer;
+ else if (type == scm_tc16_kw)
+ return scm_class_keyword;
+ else
+ return scm_class_unknown;
+ }
+ case scm_tcs_cons_gloc:
+ /* must be a struct */
+ if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
+ {
+ if (CLASS_REDEF (SCM_CLASS_OF (x)) != SCM_BOOL_F)
+ scm_change_object_class (x,
+ SCM_CLASS_OF (x),
+ CLASS_REDEF (SCM_CLASS_OF (x)));
+ return SCM_CLASS_OF (x);
+ }
+ default:
+ if (SCM_CONSP (x))
+ return scm_class_pair;
+ else
+ return scm_class_unknown;
+ }
+
+ case scm_tc3_cons_gloc:
+ case scm_tc3_tc7_1:
+ case scm_tc3_tc7_2:
+ case scm_tc3_closure:
+ /* Never reached */
+ break;
+ }
+ return scm_class_unknown;
+}
+
SCM_PROC (s_entity_p, "entity?", 1, 0, 0, scm_entity_p);
SCM
diff --git a/libguile/objects.h b/libguile/objects.h
index 8f778838c..e70c1a4a4 100644
--- a/libguile/objects.h
+++ b/libguile/objects.h
@@ -159,9 +159,27 @@ struct scm_metaclass_operator {
*/
#define SCM_ENTITY_LAYOUT ""
+/* The following three definitions are Goops dependencies needed by
+ scm_class_of. */
+#define SCM_CLASSF_GOOPS (0x10 << 24)
+#define scm_si_redefined 17
+#define scm_si_hashsets 19
+#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
+
+#define CLASS_REDEF(c) (SCM_STRUCT_DATA(c)[scm_si_redefined])
+
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_vector, scm_class_null;
+extern SCM scm_class_real, scm_class_complex, scm_class_integer;
+extern SCM scm_class_keyword, scm_class_unknown;
+
+extern void (*scm_change_object_class) (SCM, SCM, SCM);
+extern void (*scm_memoize_method) (SCM x, SCM args);
+extern SCM scm_class_of (SCM obj);
extern SCM scm_entity_p (SCM obj);
extern SCM scm_set_object_procedure_x (SCM obj, SCM procs);
extern SCM scm_make_class_object (SCM metaclass, SCM layout);
diff --git a/libguile/struct.h b/libguile/struct.h
index ea2221880..3e3708b5f 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -65,6 +65,8 @@
#define scm_vtable_offset_user 4 /* Where do user fields start? */
#define SCM_STRUCTF_ENTITY (1L << 30) /* Indicates presence of proc slots */
+#define SCM_STRUCTF_LIGHT (1L << 31) /* Light representation
+ (no hidden words) */
#define SCM_STRUCTP(X) (SCM_TYP3(X) == scm_tc3_cons_gloc)
#define SCM_STRUCT_DATA(X) ((SCM*)(SCM_CDR(X)))
diff --git a/libguile/tags.h b/libguile/tags.h
index 2c97f4f78..715d7b131 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -472,6 +472,8 @@ enum scm_tags
#define SCM_EOF_VAL SCM_MAKIFLAG(19)
#define SCM_EOL SCM_MAKIFLAG(20)
#define SCM_UNSPECIFIED SCM_MAKIFLAG(21)
+#define SCM_IM_DISPATCH SCM_MAKISYM(22)
+#define SCM_IM_HASH_DISPATCH SCM_MAKISYM(23)
#define SCM_UNBNDP(x) (SCM_UNDEFINED==(x))