mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 20:30:28 +02:00
Code Activity

* objects.c, objects.h (scm_mcache_lookup_cmethod): Moved here

Browse source 
from eval.c; Support 0 arity methods.
(scm_set_object_procedure_x): Removed scm_sym_atdispatch;
(scm_apply_generic_env): Removed.
Replaced slots proc0-3 with procedure.
This commit is contained in:
Mikael Djurfeldt 1999-08-29 03:26:38 +00:00
parent 73e10adf20
commit a12be5461e
1 changed files with 82 additions and 166 deletions
Download patch file Download diff file Expand all files Collapse all files

216
libguile/objects.c
View file

@ -72,8 +72,6 @@ SCM scm_class_unknown;
SCM *scm_port_class = 0; SCM *scm_port_class = 0;
SCM *scm_smob_class = 0; SCM *scm_smob_class = 0;
SCM scm_apply_generic_env;
SCM scm_no_applicable_method; SCM scm_no_applicable_method;
SCM (*scm_make_extended_class) (char *type_name); SCM (*scm_make_extended_class) (char *type_name);
@ -217,6 +215,37 @@ scm_class_of (SCM x)
return scm_class_unknown; return scm_class_unknown;
} }
/* (SCM_IM_DISPATCH ARGS N-SPECIALIZED
* #((TYPE1 ... ENV FORMALS FORM ...) ...)
* GF)
*
* (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
scm_mcache_lookup_cmethod (SCM cache, SCM args) scm_mcache_lookup_cmethod (SCM cache, SCM args)
{ {
@ -241,6 +270,7 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args)
methods = SCM_CADR (z); methods = SCM_CADR (z);
i = 0; i = 0;
ls = args; ls = args;
if (SCM_NIMP (ls))
do do
{ {
i += (SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls))) i += (SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls)))
@ -258,6 +288,7 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args)
int j = n; int j = n;
z = SCM_VELTS (methods)[i]; z = SCM_VELTS (methods)[i];
ls = args; /* list of arguments */ ls = args; /* list of arguments */
if (SCM_NIMP (ls))
do do
{ {
/* More arguments than specifiers => CLASS != ENV */ /* More arguments than specifiers => CLASS != ENV */
@ -277,8 +308,10 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args)
return SCM_BOOL_F; return SCM_BOOL_F;
} }
SCM (*scm_memoize_method) (SCM, SCM);
SCM SCM
scm_mcache_create_cmethod (SCM cache, SCM args) scm_mcache_compute_cmethod (SCM cache, SCM args)
{ {
SCM cmethod = scm_mcache_lookup_cmethod (cache, args); SCM cmethod = scm_mcache_lookup_cmethod (cache, args);
if (SCM_IMP (cmethod)) if (SCM_IMP (cmethod))
@ -287,75 +320,38 @@ scm_mcache_create_cmethod (SCM cache, SCM args)
return cmethod; return cmethod;
} }
SCM
scm_apply_generic (SCM gf, SCM args)
{
SCM cmethod = scm_mcache_compute_cmethod (SCM_ENTITY_PROCEDURE (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
scm_call_generic_0 (SCM gf) scm_call_generic_0 (SCM gf)
{ {
SCM clos = SCM_ENTITY_PROC_0 (gf); return scm_apply_generic (gf, SCM_EOL);
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
scm_call_generic_1 (SCM gf, SCM a1) scm_call_generic_1 (SCM gf, SCM a1)
{ {
SCM args = SCM_LIST1 (a1); return scm_apply_generic (gf, 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
scm_call_generic_2 (SCM gf, SCM a1, SCM a2) scm_call_generic_2 (SCM gf, SCM a1, SCM a2)
{ {
SCM args = SCM_LIST2 (a1, a2); return scm_apply_generic (gf, 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
scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3) scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
{ {
SCM args = SCM_LIST3 (a1, a2, a3); return scm_apply_generic (gf, 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_PROC (s_entity_p, "entity?", 1, 0, 0, scm_entity_p);
@ -381,15 +377,11 @@ scm_operator_p (SCM obj)
: SCM_BOOL_F); : SCM_BOOL_F);
} }
SCM_PROC (s_set_object_procedure_x, "set-object-procedure!", 1, 0, 1, scm_set_object_procedure_x); SCM_PROC (s_set_object_procedure_x, "set-object-procedure!", 2, 0, 0, scm_set_object_procedure_x);
SCM_SYMBOL (scm_sym_atdispatch, "@dispatch");
SCM SCM
scm_set_object_procedure_x (SCM obj, SCM procs) scm_set_object_procedure_x (SCM obj, SCM proc)
{ {
SCM proc[4], *pp, p, setp, arity;
int i, a, r;
SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj) SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj)
&& ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
|| (SCM_I_ENTITYP (obj) || (SCM_I_ENTITYP (obj)
@ -398,104 +390,28 @@ scm_set_object_procedure_x (SCM obj, SCM procs)
obj, obj,
SCM_ARG1, SCM_ARG1,
s_set_object_procedure_x); s_set_object_procedure_x);
for (i = 0; i < 4; ++i) SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (proc)),
proc[i] = SCM_BOOL_F; proc, SCM_ARG2, s_set_object_procedure_x);
i = 0; if (SCM_I_ENTITYP (obj))
while (SCM_NIMP (procs)) SCM_ENTITY_PROCEDURE (obj) = proc;
{ else
if (i == 4) SCM_OPERATOR_CLASS (obj)->procedure = proc;
scm_wrong_num_args (scm_makfrom0str (s_set_object_procedure_x));
p = SCM_CAR (procs);
setp = 0;
SCM_ASSERT (SCM_NIMP (p), p, SCM_ARG2 + i, s_set_object_procedure_x);
if (SCM_CLOSUREP (p))
{
arity = scm_procedure_property (p, scm_sym_arity);
a = SCM_INUM (SCM_CAR (arity));
/* Closures have zero optional args */
r = SCM_NFALSEP (SCM_CADDR (arity));
if (a == 1 || (a <= 1 && r))
{
if (SCM_NFALSEP (proc[0]))
goto ambiguous;
proc[0] = setp = p;
}
if (a == 2 || (a <= 2 && r))
{
if (SCM_NFALSEP (proc[1]))
goto ambiguous;
proc[1] = setp = p;
}
if (a == 3 || (a <= 3 && r))
{
if (SCM_NFALSEP (proc[2]))
goto ambiguous;
proc[2] = setp = p;
}
if (a <= 4 && r)
{
if (SCM_NFALSEP (proc[3]))
goto ambiguous;
proc[3] = setp = p;
}
}
else if (SCM_TYP7 (p) == scm_tc7_subr_1)
{
if (SCM_NFALSEP (proc[0]))
goto ambiguous;
proc[0] = setp = p;
}
else if (SCM_TYP7 (p) == scm_tc7_subr_2)
{
if (SCM_NFALSEP (proc[1]))
goto ambiguous;
proc[1] = setp = p;
}
else if (SCM_TYP7 (p) == scm_tc7_subr_3)
{
if (SCM_NFALSEP (proc[2]))
goto ambiguous;
proc[2] = setp = p;
}
else if (SCM_TYP7 (p) == scm_tc7_lsubr_2)
{
if (SCM_NFALSEP (proc[3]))
{
ambiguous:
SCM_ASSERT (0, p, "Ambiguous procedure arities",
s_set_object_procedure_x);
}
proc[3] = setp = p;
}
SCM_ASSERT (setp, p, SCM_ARG2 + i, s_set_object_procedure_x);
++i;
procs = SCM_CDR (procs);
}
pp = (SCM_I_ENTITYP (obj)
? &SCM_ENTITY_PROC_0 (obj)
: &SCM_OPERATOR_CLASS (obj)->proc0);
for (i = 0; i < 4; ++i)
*pp++ = proc[i];
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
#ifdef GUILE_DEBUG #ifdef GUILE_DEBUG
SCM_PROC (s_object_procedures, "object-procedures", 1, 0, 0, scm_object_procedures); SCM_PROC (s_object_procedure, "object-procedure", 1, 0, 0, scm_object_procedure);
SCM SCM
scm_object_procedures (SCM obj) scm_object_procedure (SCM obj)
{ {
SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj) && SCM_I_OPERATORP (obj), SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj)
obj, SCM_ARG1, s_object_procedures); && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
|| SCM_I_ENTITYP (obj)),
obj, SCM_ARG1, s_object_procedure);
return (SCM_I_ENTITYP (obj) return (SCM_I_ENTITYP (obj)
? SCM_LIST4 (SCM_ENTITY_PROC_0 (obj), ? SCM_ENTITY_PROCEDURE (obj)
SCM_ENTITY_PROC_1 (obj), : SCM_OPERATOR_CLASS (obj)->procedure);
SCM_ENTITY_PROC_2 (obj),
SCM_ENTITY_PROC_3 (obj))
: SCM_LIST4 (SCM_OPERATOR_PROC_0 (obj),
SCM_OPERATOR_PROC_1 (obj),
SCM_OPERATOR_PROC_2 (obj),
SCM_OPERATOR_PROC_3 (obj)));
} }
#endif /* GUILE_DEBUG */ #endif /* GUILE_DEBUG */