mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 09:10:22 +02:00
Code Activity

* objects.c (scm_set_object_procedure_x): New procedure: Use this

Browse source 
to set the dispatch procedure of an operator or entity object.
This commit is contained in:
Mikael Djurfeldt 1998-05-04 11:32:30 +00:00
parent dc0938d8a4
commit 47b210500b
1 changed files with 152 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

152
libguile/objects.c
View file

@ -48,6 +48,7 @@
#include "_scm.h"
#include "struct.h"
#include "procprop.h"
#include "objects.h"
@ -55,6 +56,155 @@
SCM scm_metaclass_standard;
SCM scm_metaclass_operator;
SCM_PROC (s_set_object_procedure_x, "set-object-procedure!", 1, 0, 1, scm_set_object_procedure_x);
SCM
scm_set_object_procedure_x (SCM obj, SCM procs)
{
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)),
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];
return SCM_UNSPECIFIED;
}
static SCM
make_class_object (SCM meta,
SCM pl,
SCM layout,
unsigned long flags,
char* subr)
{
SCM c;
SCM_ASSERT (SCM_NIMP (meta) && SCM_STRUCTP (meta), meta, SCM_ARG1, subr);
SCM_ASSERT (SCM_NIMP (layout) && SCM_STRINGP (layout),
layout,
SCM_ARG2,
subr);
layout = scm_make_struct_layout (scm_string_append (SCM_LIST2 (pl, layout)));
c = scm_make_struct (meta,
SCM_INUM0,
SCM_LIST4 (layout, SCM_BOOL_F, SCM_EOL, SCM_EOL));
SCM_SET_CLASS_FLAGS (c, flags);
return c;
}
SCM_PROC (s_make_class_object, "make-class-object", 2, 0, 0, scm_make_class_object);
SCM
scm_make_class_object (SCM metaclass, SCM layout)
{
unsigned long flags = 0;
if (metaclass == scm_metaclass_operator)
flags = SCM_CLASSF_OPERATOR;
return make_class_object (metaclass,
scm_nullstr,
layout,
flags,
s_make_class_object);
}
SCM_PROC (s_make_subclass_object, "make-subclass-object", 2, 0, 0, scm_make_subclass_object);
SCM
scm_make_subclass_object (SCM class, SCM layout)
{
SCM pl;
SCM_ASSERT (SCM_NIMP (class) && SCM_STRUCTP (class),
class,
SCM_ARG1,
s_make_subclass_object);
pl = SCM_STRUCT_DATA (class)[scm_vtable_index_layout];
pl = scm_makfromstr (SCM_CHARS (pl), (scm_sizet) SCM_LENGTH (pl), 0);
return make_class_object (scm_metaclass_standard,
pl,
layout,
SCM_CLASS_FLAGS (class),
s_make_subclass_object);
}
void
scm_init_objects ()
{
@ -79,4 +229,6 @@ scm_init_objects ()
scm_metaclass_operator = ot;
SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY);
scm_sysintern ("<entity-class>", et);
#include "objects.x"
}