summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>1997-10-12 12:54:54 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>1997-10-12 12:54:54 +0000
commitda7f71d7d59969c10b80bd501dbea024318f6d90 (patch)
treeadb71c5ca90683ef9a7c632b0df094b2a11e634c
parente0d86ad2fb56ef481a29647bf6fb1b5f523bd78a (diff)
downloadguile-da7f71d7d59969c10b80bd501dbea024318f6d90.tar.gz
* eval.c (SCM_CEVAL, scm_apply): Completed GOOPS support code;
Some indentation fixes. * objects.h (SCM_METACLASS_STANDARD_LAYOUT): Printer field is no longer a user field; New field: class_flags. * objets.c, objects.h: New metaclass: scm_metaclass_operator.
-rw-r--r--libguile/ChangeLog12
-rw-r--r--libguile/eval.c242
-rw-r--r--libguile/objects.c17
-rw-r--r--libguile/objects.h112
4 files changed, 302 insertions, 81 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index a6368404d..444a3b987 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,15 @@
+Sun Oct 12 14:41:39 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * ports.h: #include "libguile/print.h"
+
+ * eval.c (SCM_CEVAL, scm_apply): Completed GOOPS support code;
+ Some indentation fixes.
+
+ * objects.h (SCM_METACLASS_STANDARD_LAYOUT): Printer field is no
+ longer a user field; New field: class_flags.
+
+ * objets.c, objects.h: New metaclass: scm_metaclass_operator.
+
Tue Oct 7 09:37:24 1997 Mark Galassi <rosalia@cygnus.com>
* gh_data.c (gh_bool2scm): new function which replaces
diff --git a/libguile/eval.c b/libguile/eval.c
index a6c8d3ccc..a709d4f69 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -2099,6 +2099,27 @@ evapply:
x = SCM_CODE (proc);
env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc));
goto cdrxbegin;
+ case scm_tcs_cons_gloc:
+ if (SCM_I_OPERATORP (proc))
+ {
+ x = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROC_0 (proc)
+ : SCM_OPERATOR_PROC_0 (proc));
+ if (SCM_NIMP (x))
+ if (SCM_TYP7 (x) == scm_tc7_subr_1)
+ RETURN (SCM_SUBRF (x) (proc))
+ else if (SCM_CLOSUREP (x))
+ {
+ t.arg1 = proc;
+ proc = x;
+#ifdef DEVAL
+ debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
+ debug.info->a.proc = proc;
+#endif
+ goto clos1;
+ }
+ /* Fall through. */
+ }
case scm_tc7_contin:
case scm_tc7_subr_1:
case scm_tc7_subr_2:
@@ -2196,6 +2217,7 @@ evapply:
goto evap2;
#endif
case scm_tcs_closures:
+ clos1:
x = SCM_CODE (proc);
#ifdef DEVAL
env = EXTEND_ENV (SCM_CAR (x), debug.info->a.args, SCM_ENV (proc));
@@ -2203,27 +2225,30 @@ evapply:
env = EXTEND_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
#endif
goto cdrxbegin;
- case scm_tc7_contin:
- scm_call_continuation (proc, t.arg1);
case scm_tcs_cons_gloc:
- if (SCM_I_ENTITYP (proc))
+ if (SCM_I_OPERATORP (proc))
{
- x = SCM_ENTITY_PROC_1 (proc);
- if (SCM_TYP7 (x) == scm_tc7_subr_2)
- RETURN (SCM_SUBRF (x) (proc, t.arg1))
- else if (SCM_CLOSUREP (x))
- {
- arg2 = t.arg1;
- t.arg1 = proc;
- proc = x;
+ x = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROC_1 (proc)
+ : SCM_OPERATOR_PROC_1 (proc));
+ if (SCM_NIMP (x))
+ if (SCM_TYP7 (x) == scm_tc7_subr_2)
+ RETURN (SCM_SUBRF (x) (proc, t.arg1))
+ else if (SCM_CLOSUREP (x))
+ {
+ arg2 = t.arg1;
+ t.arg1 = proc;
+ proc = x;
#ifdef DEVAL
- debug.info->a.args = scm_cons (t.arg1, debug.info->a.args);
- debug.info->a.proc = proc;
+ debug.info->a.args = scm_cons (t.arg1, debug.info->a.args);
+ debug.info->a.proc = proc;
#endif
- goto clos2;
- }
+ goto clos2;
+ }
/* Fall through. */
}
+ case scm_tc7_contin:
+ scm_call_continuation (proc, t.arg1);
case scm_tc7_subr_2:
case scm_tc7_subr_0:
case scm_tc7_subr_3:
@@ -2273,7 +2298,8 @@ evapply:
#else
RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc,
scm_cons2 (t.arg1, arg2,
- scm_cons (scm_eval_args (x, env), SCM_EOL))));
+ scm_cons (scm_eval_args (x, env),
+ SCM_EOL))));
#endif
/* case scm_tc7_cclo:
x = scm_cons(arg2, scm_eval_args(x, env));
@@ -2283,25 +2309,28 @@ evapply:
goto evap3; */
#endif
case scm_tcs_cons_gloc:
- if (SCM_I_ENTITYP (proc))
+ if (SCM_I_OPERATORP (proc))
{
- x = SCM_ENTITY_PROC_2 (proc);
- if (SCM_TYP7 (x) == scm_tc7_subr_3)
- RETURN (SCM_SUBRF (x) (proc, t.arg1, arg2))
- else if (SCM_CLOSUREP (x))
- {
+ x = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROC_2 (proc)
+ : SCM_OPERATOR_PROC_2 (proc));
+ if (SCM_NIMP (x))
+ if (SCM_TYP7 (x) == scm_tc7_subr_3)
+ RETURN (SCM_SUBRF (x) (proc, t.arg1, arg2))
+ else if (SCM_CLOSUREP (x))
+ {
#ifdef DEVAL
- SCM_SET_ARGSREADY (debug);
- debug.info->a.args = scm_cons (proc, debug.info->a.args);
- debug.info->a.proc = x;
-#endif
- env = EXTEND_ENV (SCM_CAR (SCM_CODE (x)),
- scm_cons2 (proc, t.arg1,
- scm_cons (arg2, env)),
- SCM_ENV (proc));
- x = SCM_CODE (proc);
- goto cdrxbegin;
- }
+ SCM_SET_ARGSREADY (debug);
+ debug.info->a.args = scm_cons (proc, debug.info->a.args);
+ debug.info->a.proc = x;
+#endif
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (x)),
+ scm_cons2 (proc, t.arg1,
+ scm_cons (arg2, env)),
+ SCM_ENV (x));
+ x = SCM_CODE (x);
+ goto cdrxbegin;
+ }
/* Fall through. */
}
case scm_tc7_subr_0:
@@ -2316,9 +2345,12 @@ evapply:
case scm_tcs_closures:
clos2:
#ifdef DEVAL
- env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), debug.info->a.args, SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
+ debug.info->a.args,
+ SCM_ENV (proc));
#else
- env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
+ scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
#endif
x = SCM_CODE (proc);
goto cdrxbegin;
@@ -2326,24 +2358,26 @@ evapply:
}
#ifdef DEVAL
debug.info->a.args = scm_cons2 (t.arg1, arg2,
- scm_deval_args (x, env, SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
+ scm_deval_args (x, env, SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
#endif
ENTER_APPLY;
- evap3:
switch (SCM_TYP7 (proc))
{ /* have 3 or more arguments */
#ifdef DEVAL
case scm_tc7_subr_3:
SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CAR (SCM_CDR (SCM_CDR (debug.info->a.args)))));
+ RETURN (SCM_SUBRF (proc) (t.arg1, arg2,
+ SCM_CADDR (debug.info->a.args)));
case scm_tc7_asubr:
#ifdef BUILTIN_RPASUBR
t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
arg2 = SCM_CDR (SCM_CDR (debug.info->a.args));
- do {
- t.arg1 = SCM_SUBRF(proc)(t.arg1, SCM_CAR (arg2));
- arg2 = SCM_CDR (arg2);
- } while (SCM_NIMP (arg2));
+ do
+ {
+ t.arg1 = SCM_SUBRF(proc)(t.arg1, SCM_CAR (arg2));
+ arg2 = SCM_CDR (arg2);
+ }
+ while (SCM_NIMP (arg2));
RETURN (t.arg1)
#endif /* BUILTIN_RPASUBR */
case scm_tc7_rpsubr:
@@ -2351,18 +2385,24 @@ evapply:
if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2)))
RETURN (SCM_BOOL_F)
t.arg1 = SCM_CDR (SCM_CDR (debug.info->a.args));
- do {
- if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (t.arg1))))
- RETURN (SCM_BOOL_F)
- arg2 = SCM_CAR (t.arg1);
- t.arg1 = SCM_CDR (t.arg1);
- } while (SCM_NIMP (t.arg1));
+ do
+ {
+ if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (t.arg1))))
+ RETURN (SCM_BOOL_F)
+ arg2 = SCM_CAR (t.arg1);
+ t.arg1 = SCM_CDR (t.arg1);
+ }
+ while (SCM_NIMP (t.arg1));
RETURN (SCM_BOOL_T)
#else /* BUILTIN_RPASUBR */
- RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, SCM_CDR (SCM_CDR (debug.info->a.args)), SCM_EOL)))
+ RETURN (SCM_APPLY (proc, t.arg1,
+ scm_acons (arg2,
+ SCM_CDR (SCM_CDR (debug.info->a.args)),
+ SCM_EOL)))
#endif /* BUILTIN_RPASUBR */
case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CDR (SCM_CDR (debug.info->a.args))))
+ RETURN (SCM_SUBRF (proc) (t.arg1, arg2,
+ SCM_CDR (SCM_CDR (debug.info->a.args))))
case scm_tc7_lsubr:
RETURN (SCM_SUBRF (proc) (debug.info->a.args))
#ifdef CCLO
@@ -2382,27 +2422,32 @@ evapply:
RETURN (SCM_SUBRF (proc) (t.arg1, arg2, EVALCAR (x, env)));
case scm_tc7_asubr:
#ifdef BUILTIN_RPASUBR
- t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
- do {
- t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
- x = SCM_CDR(x);
- } while (SCM_NIMP (x));
+ t.arg1 = SCM_SUBRF (proc) (t.arg1, arg2);
+ do
+ {
+ t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
+ x = SCM_CDR(x);
+ }
+ while (SCM_NIMP (x));
RETURN (t.arg1)
#endif /* BUILTIN_RPASUBR */
case scm_tc7_rpsubr:
#ifdef BUILTIN_RPASUBR
if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2)))
RETURN (SCM_BOOL_F)
- do {
- t.arg1 = EVALCAR (x, env);
- if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, t.arg1)))
- RETURN (SCM_BOOL_F)
- arg2 = t.arg1;
- x = SCM_CDR (x);
- } while (SCM_NIMP (x));
+ do
+ {
+ t.arg1 = EVALCAR (x, env);
+ if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, t.arg1)))
+ RETURN (SCM_BOOL_F)
+ arg2 = t.arg1;
+ x = SCM_CDR (x);
+ }
+ while (SCM_NIMP (x));
RETURN (SCM_BOOL_T)
#else /* BUILTIN_RPASUBR */
- RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, scm_eval_args (x, env), SCM_EOL)));
+ RETURN (SCM_APPLY (proc, t.arg1,
+ scm_acons (arg2, scm_eval_args (x, env), SCM_EOL)));
#endif /* BUILTIN_RPASUBR */
case scm_tc7_lsubr_2:
RETURN (SCM_SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env)));
@@ -2423,8 +2468,44 @@ evapply:
goto cdrxbegin;
#endif /* DEVAL */
case scm_tcs_cons_gloc:
- if (SCM_I_ENTITYP (proc))
- ;
+ if (SCM_I_OPERATORP (proc))
+ {
+ SCM p = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROC_3 (proc)
+ : SCM_OPERATOR_PROC_3 (proc));
+ if (SCM_NIMP (p))
+ if (SCM_TYP7 (p) == scm_tc7_lsubr_2)
+#ifdef DEVAL
+ RETURN (SCM_SUBRF (p) (proc, t.arg1,
+ scm_cons (arg2, SCM_CDDR (debug.info->a.args))))
+#else
+ RETURN (SCM_SUBRF (p) (proc, t.arg1,
+ scm_cons (arg2,
+ scm_eval_args (x, env))))
+#endif
+ else if (SCM_CLOSUREP (p))
+ {
+#ifdef DEVAL
+ SCM_SET_ARGSREADY (debug);
+ debug.info->a.args = scm_cons (proc, debug.info->a.args);
+ debug.info->a.proc = p;
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (p)),
+ scm_cons2 (proc, t.arg1,
+ scm_cons (arg2,
+ SCM_CDDDR (debug.info->a.args))),
+ SCM_ENV (p));
+#else
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (p)),
+ scm_cons2 (proc, t.arg1,
+ scm_cons (arg2,
+ scm_eval_args (x, env))),
+ SCM_ENV (p));
+#endif
+ x = SCM_CODE (p);
+ goto cdrxbegin;
+ }
+ /* Fall through. */
+ }
case scm_tc7_subr_2:
case scm_tc7_subr_1o:
case scm_tc7_subr_2o:
@@ -2777,8 +2858,35 @@ tail:
goto tail;
#endif
case scm_tcs_cons_gloc:
- if (SCM_I_ENTITYP (proc))
- ;
+ if (SCM_I_OPERATORP (proc))
+ {
+#ifdef DEVAL
+ args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
+#else
+ args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
+#endif
+ arg1 = proc;
+ proc = (SCM_NULLP (args)
+ ? (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROC_0 (proc)
+ : SCM_OPERATOR_PROC_0 (proc))
+ : SCM_NULLP (SCM_CDR (args))
+ ? (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROC_1 (proc)
+ : SCM_OPERATOR_PROC_1 (proc))
+ : SCM_NULLP (SCM_CDDR (args))
+ ? (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROC_2 (proc)
+ : SCM_OPERATOR_PROC_2 (proc))
+ : (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROC_3 (proc)
+ : SCM_OPERATOR_PROC_3 (proc)));
+#ifdef DEVAL
+ debug.vect[0].a.proc = proc;
+ debug.vect[0].a.args = scm_cons (arg1, args);
+#endif
+ goto tail;
+ }
wrongnumargs:
scm_wrong_num_args (proc);
default:
diff --git a/libguile/objects.c b/libguile/objects.c
index 7e3dec0d9..7c64ce666 100644
--- a/libguile/objects.c
+++ b/libguile/objects.c
@@ -40,9 +40,9 @@
* If you do not wish that, delete this exception notice. */
-/* This file contains those minimal pieces of the Guile Object
- * Oriented Programming System which needs to be included in
- * libguile.
+/* This file and objects.h contains those minimal pieces of the Guile
+ * Object Oriented Programming System which need to be included in
+ * libguile. See the comments in objects.h.
*/
#include "_scm.h"
@@ -53,7 +53,7 @@
SCM scm_metaclass_standard;
-SCM *scm_entity_vtable;
+SCM scm_metaclass_operator;
void
scm_init_objects ()
@@ -63,6 +63,11 @@ scm_init_objects ()
SCM mt = scm_make_vtable_vtable (ml, SCM_INUM0,
SCM_LIST3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
+ SCM os = scm_makfrom0str (SCM_METACLASS_OPERATOR_LAYOUT);
+ SCM ol = scm_make_struct_layout (os);
+ SCM ot = scm_make_vtable_vtable (ol, SCM_INUM0,
+ SCM_LIST3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
+
SCM es = scm_makfrom0str (SCM_ENTITY_LAYOUT);
SCM el = scm_make_struct_layout (es);
SCM et = scm_make_struct (mt, SCM_INUM0,
@@ -70,6 +75,8 @@ scm_init_objects ()
scm_sysintern ("<standard-metaclass>", mt);
scm_metaclass_standard = mt;
+ scm_sysintern ("<operator-metaclass>", ot);
+ scm_metaclass_operator = ot;
+ SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY);
scm_sysintern ("<entity-class>", et);
- scm_entity_vtable = SCM_STRUCT_DATA (et);
}
diff --git a/libguile/objects.h b/libguile/objects.h
index db3ba4a85..3de1b5f45 100644
--- a/libguile/objects.h
+++ b/libguile/objects.h
@@ -45,20 +45,92 @@
* If you do not wish that, delete this exception notice. */
+/* This file and objects.c contains those minimal pieces of the Guile
+ * Object Oriented Programming System which need to be included in
+ * libguile.
+ *
+ * {Objects and structs}
+ *
+ * Objects are currently based upon structs. Although the struct
+ * implementation will change thoroughly in the future, objects will
+ * still be based upon structs.
+ */
+
#include "libguile/__scm.h"
#include "libguile/struct.h"
-#define SCM_I_ENTITYP(OBJ)\
-(SCM_STRUCT_VTABLE_DATA (OBJ) == scm_entity_vtable)
-#define SCM_ENTITY(OBJ) ((scm_entity*) SCM_STRUCT_DATA (OBJ))
-#define SCM_ENTITY_PROC_0(OBJ) (SCM_ENTITY (OBJ)->proc0)
-#define SCM_ENTITY_PROC_1(OBJ) (SCM_ENTITY (OBJ)->proc1)
-#define SCM_ENTITY_PROC_2(OBJ) (SCM_ENTITY (OBJ)->proc2)
-#define SCM_ENTITY_PROC_3(OBJ) (SCM_ENTITY (OBJ)->proc3)
+/* {Class flags}
+ *
+ * These are used for efficient identification of instances of a
+ * certain class or its subclasses when traversal of the inheritance
+ * graph would be too costly.
+ */
+#define SCM_CLASS_FLAGS(class) (SCM_STRUCT_DATA (class)[scm_struct_i_tag])
+#define SCM_OBJ_CLASS_FLAGS(obj)\
+(SCM_STRUCT_VTABLE_DATA (obj)[scm_struct_i_tag])
+#define SCM_SET_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) |= (f))
+#define SCM_CLEAR_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) &= ~(f))
+#define SCM_CLASSF_MASK (0xFF << 24)
+
+/* Operator classes need to be identified in the evaluator. */
+#define SCM_CLASSF_OPERATOR (1L << 30)
+/* Entities also have SCM_CLASSF_OPERATOR set in their vtable. */
+#define SCM_CLASSF_ENTITY (1L << 29)
+
+#define SCM_I_OPERATORP(obj)\
+((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) != 0)
+#define SCM_OPERATOR_CLASS(obj)\
+((struct scm_metaclass_operator *) SCM_STRUCT_DATA (obj))
+#define SCM_OBJ_OPERATOR_CLASS(obj)\
+((struct scm_metaclass_operator *) SCM_STRUCT_VTABLE_DATA (obj))
+#define SCM_OPERATOR_PROC_0(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->proc0)
+#define SCM_OPERATOR_PROC_1(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->proc1)
+#define SCM_OPERATOR_PROC_2(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->proc2)
+#define SCM_OPERATOR_PROC_3(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->proc3)
+
+#define SCM_I_ENTITYP(obj)\
+((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_ENTITY) != 0)
+#define SCM_ENTITY(obj) ((scm_entity*) SCM_STRUCT_DATA (obj))
+#define SCM_ENTITY_PROC_0(obj) (SCM_ENTITY (obj)->proc0)
+#define SCM_ENTITY_PROC_1(obj) (SCM_ENTITY (obj)->proc1)
+#define SCM_ENTITY_PROC_2(obj) (SCM_ENTITY (obj)->proc2)
+#define SCM_ENTITY_PROC_3(obj) (SCM_ENTITY (obj)->proc3)
-#define SCM_METACLASS_STANDARD_LAYOUT "pwpwpw"
+/* {Operator classes}
+ *
+ * Instances of operator classes can work as operators, i. e., they
+ * can be applied to arguments just as if they were ordinary
+ * procedures.
+ *
+ * For instances of operator classes, the procedures to be applied are
+ * stored in four dedicated slots in the associated class object.
+ * Which one is selected depends on the number of arguments in the
+ * application.
+ *
+ * If zero arguments are passed, the first will be selected.
+ * If one argument is passed, the second will be selected.
+ * If two arguments are passed, the third will be selected.
+ * If three or more arguments are passed, the fourth will be selected.
+ *
+ * This is complicated and may seem gratuitous but has to do with the
+ * architecture of the evaluator. Using only one procedure would
+ * result in a great deal less efficient application, loss of
+ * tail-recursion and would be difficult to reconcile with the
+ * debugging evaluator.
+ *
+ * Also, using this "forked" application in low-level code has the
+ * advantage of speeding up some code. An example is method dispatch
+ * for generic operators applied to few arguments. On the user level,
+ * the "forked" application will be hidden by mechanisms in the GOOPS
+ * package.
+ *
+ * Operator classes have the metaclass <operator-metaclass>.
+ *
+ * An example of an operator class is the class <tk-command>.
+ */
+#define SCM_METACLASS_STANDARD_LAYOUT "pwpw"
struct scm_metaclass_standard {
SCM layout;
SCM vcell;
@@ -68,6 +140,28 @@ struct scm_metaclass_standard {
SCM direct_slots;
};
+#define SCM_METACLASS_OPERATOR_LAYOUT "pwpwpwpwpwpw"
+struct scm_metaclass_operator {
+ SCM layout;
+ SCM vcell;
+ SCM vtable;
+ SCM print;
+ SCM direct_supers;
+ SCM direct_slots;
+ SCM proc0;
+ SCM proc1;
+ SCM proc2;
+ SCM proc3;
+};
+
+/* {Entity classes}
+ *
+ * For instances of entity classes (entities), the procedures to be
+ * applied are stored in the instance itself rather than in the class
+ * object as is the case for instances of operator classes (see above).
+ *
+ * An example of an entity class is the class of generic methods.
+ */
#define SCM_ENTITY_LAYOUT "pwpwpwpw"
typedef struct scm_entity {
SCM proc0;
@@ -77,7 +171,7 @@ typedef struct scm_entity {
} scm_entity;
extern SCM scm_metaclass_standard;
-extern SCM *scm_entity_vtable;
+extern SCM scm_metaclass_operator;
extern void scm_init_objects SCM_P ((void));