mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-21 20:20:24 +02:00
* objects.c, objects.h (scm_mcache_lookup_cmethod): Moved here
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
parent
73e10adf20
commit
a12be5461e
1 changed files with 82 additions and 166 deletions
|
|
@ -72,8 +72,6 @@ SCM scm_class_unknown;
|
|||
SCM *scm_port_class = 0;
|
||||
SCM *scm_smob_class = 0;
|
||||
|
||||
SCM scm_apply_generic_env;
|
||||
|
||||
SCM scm_no_applicable_method;
|
||||
|
||||
SCM (*scm_make_extended_class) (char *type_name);
|
||||
|
|
@ -217,6 +215,37 @@ scm_class_of (SCM x)
|
|||
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_mcache_lookup_cmethod (SCM cache, SCM args)
|
||||
{
|
||||
|
|
@ -241,13 +270,14 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args)
|
|||
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));
|
||||
if (SCM_NIMP (ls))
|
||||
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;
|
||||
}
|
||||
|
|
@ -258,15 +288,16 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args)
|
|||
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));
|
||||
if (SCM_NIMP (ls))
|
||||
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;
|
||||
|
|
@ -277,8 +308,10 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args)
|
|||
return SCM_BOOL_F;
|
||||
}
|
||||
|
||||
SCM (*scm_memoize_method) (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);
|
||||
if (SCM_IMP (cmethod))
|
||||
|
|
@ -287,75 +320,38 @@ scm_mcache_create_cmethod (SCM cache, SCM args)
|
|||
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_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);
|
||||
return scm_apply_generic (gf, SCM_EOL);
|
||||
}
|
||||
|
||||
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)));
|
||||
return scm_apply_generic (gf, SCM_LIST1 (a1));
|
||||
}
|
||||
|
||||
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)));
|
||||
return scm_apply_generic (gf, SCM_LIST2 (a1, a2));
|
||||
}
|
||||
|
||||
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)));
|
||||
}
|
||||
return scm_apply_generic (gf, SCM_LIST3 (a1, a2, a3));
|
||||
}
|
||||
|
||||
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_PROC (s_set_object_procedure_x, "set-object-procedure!", 1, 0, 1, scm_set_object_procedure_x);
|
||||
|
||||
SCM_SYMBOL (scm_sym_atdispatch, "@dispatch");
|
||||
SCM_PROC (s_set_object_procedure_x, "set-object-procedure!", 2, 0, 0, scm_set_object_procedure_x);
|
||||
|
||||
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_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
|
||||
|| (SCM_I_ENTITYP (obj)
|
||||
|
|
@ -398,104 +390,28 @@ scm_set_object_procedure_x (SCM obj, SCM procs)
|
|||
obj,
|
||||
SCM_ARG1,
|
||||
s_set_object_procedure_x);
|
||||
for (i = 0; i < 4; ++i)
|
||||
proc[i] = SCM_BOOL_F;
|
||||
i = 0;
|
||||
while (SCM_NIMP (procs))
|
||||
{
|
||||
if (i == 4)
|
||||
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];
|
||||
SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (proc)),
|
||||
proc, SCM_ARG2, s_set_object_procedure_x);
|
||||
if (SCM_I_ENTITYP (obj))
|
||||
SCM_ENTITY_PROCEDURE (obj) = proc;
|
||||
else
|
||||
SCM_OPERATOR_CLASS (obj)->procedure = proc;
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
|
||||
#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_object_procedures (SCM obj)
|
||||
scm_object_procedure (SCM obj)
|
||||
{
|
||||
SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj) && SCM_I_OPERATORP (obj),
|
||||
obj, SCM_ARG1, s_object_procedures);
|
||||
SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj)
|
||||
&& ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
|
||||
|| SCM_I_ENTITYP (obj)),
|
||||
obj, SCM_ARG1, s_object_procedure);
|
||||
return (SCM_I_ENTITYP (obj)
|
||||
? SCM_LIST4 (SCM_ENTITY_PROC_0 (obj),
|
||||
SCM_ENTITY_PROC_1 (obj),
|
||||
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)));
|
||||
? SCM_ENTITY_PROCEDURE (obj)
|
||||
: SCM_OPERATOR_CLASS (obj)->procedure);
|
||||
}
|
||||
#endif /* GUILE_DEBUG */
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue