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:
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));
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:
#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));
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:
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;
}
#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:
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
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)));
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:
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:
* If you do not wish that, delete this exception notice. */
\f
+/* 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"
\f
-#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;
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;
} 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));
HCoop / bpt / guile.git / commitdiff