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

* objects.h, objects.c (scm_apply_generic_env): Added (used by

Browse source 
apply).
(scm_operator_p): Added.
(scm_sym_atdispatch): Added.
(scm_set_object_procedure_x): Modified to handle the new style
generic functions.
(scm_object_procedures): New debugging procedure.
This commit is contained in:
Mikael Djurfeldt 1999-08-06 19:39:07 +00:00
parent f3d2630a64
commit a43a8375d8
2 changed files with 82 additions and 9 deletions
Download patch file Download diff file Expand all files Collapse all files

70
libguile/objects.c
View file

@ -70,6 +70,8 @@ SCM scm_class_unknown;
SCM *scm_port_class = 0;
SCM *scm_smob_class = 0;
SCM scm_apply_generic_env;
SCM (*scm_make_extended_class) (char *type_name);
void (*scm_make_port_classes) (int ptobnum, char *type_name);
void (*scm_change_object_class) (SCM, SCM, SCM);
@ -215,22 +217,39 @@ scm_entity_p (SCM obj)
: SCM_BOOL_F);
}
SCM_PROC (s_operator_p, "operator?", 1, 0, 0, scm_operator_p);
SCM
scm_operator_p (SCM obj)
{
return (SCM_NIMP (obj)
&& SCM_STRUCTP (obj)
&& SCM_I_OPERATORP (obj)
&& !SCM_I_ENTITYP (obj)
? SCM_BOOL_T
: 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
scm_set_object_procedure_x (SCM obj, SCM procs)
{
SCM proc[4], *pp, p, setp, arity;
int i, a, r;
int i, a, r, c = 0;
SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj)
&& ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
|| SCM_I_ENTITYP (obj)),
&& (SCM_I_ENTITYP (obj)
|| (SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)),
obj,
SCM_ARG1,
s_set_object_procedure_x);
for (i = 0; i < 4; ++i)
proc[i] = SCM_BOOL_F;
i = 0;
if (SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC)
c = 1;
while (SCM_NIMP (procs))
{
if (i == 4)
@ -238,6 +257,23 @@ scm_set_object_procedure_x (SCM obj, SCM procs)
p = SCM_CAR (procs);
setp = 0;
SCM_ASSERT (SCM_NIMP (p), p, SCM_ARG2 + i, s_set_object_procedure_x);
if (c != 0)
{
if ((SCM_CAR (p) == scm_sym_atdispatch
|| SCM_CAR (p) == SCM_IM_DISPATCH)
&& c < 4)
{
proc[c++] = setp = p;
goto next;
}
else
SCM_ASSERT (SCM_TYP7 (p) == scm_tc7_subr_1
|| (SCM_CLOSUREP (p)
&& (SCM_INUM (SCM_CAR (scm_procedure_property
(p, scm_sym_arity)))
== 1)),
p, SCM_ARG2 + i, s_set_object_procedure_x);
}
if (SCM_CLOSUREP (p))
{
arity = scm_procedure_property (p, scm_sym_arity);
@ -298,17 +334,45 @@ scm_set_object_procedure_x (SCM obj, SCM procs)
proc[3] = setp = p;
}
SCM_ASSERT (setp, p, SCM_ARG2 + i, s_set_object_procedure_x);
next:
++i;
procs = SCM_CDR (procs);
}
/* Fill the rest of the method cache slots
if a cache has been supplied earlier. */
if (c != 0)
for (; c < 4; ++c)
proc[c] = proc[c - 1];
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;
}
#ifdef GUILE_DEBUG
SCM_PROC (s_object_procedures, "object-procedures", 1, 0, 0, scm_object_procedures);
SCM
scm_object_procedures (SCM obj)
{
SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj) && SCM_I_OPERATORP (obj),
obj, SCM_ARG1, s_object_procedures);
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)));
}
#endif /* GUILE_DEBUG */
/* The following procedures are not a part of Goops but a minimal
* object system built upon structs. They are here for those who
* want to implement their own object system.

21
libguile/objects.h
View file

@ -175,12 +175,13 @@ struct scm_metaclass_operator {
*/
/* Internal representation of Goops objects. */
#define SCM_CLASSF_GOOPS_VALID (0x080 << 20)
#define SCM_CLASSF_GOOPS (0x100 << 20)
#define scm_si_redefined 9
#define scm_si_hashsets 10
#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
#define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
#define SCM_CLASSF_PURE_GENERIC (0x010 << 20)
#define SCM_CLASSF_GOOPS_VALID (0x080 << 20)
#define SCM_CLASSF_GOOPS (0x100 << 20)
#define scm_si_redefined 9
#define scm_si_hashsets 10
#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
#define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
typedef struct scm_effective_slot_definition {
SCM name;
@ -209,15 +210,23 @@ extern SCM scm_class_unknown;
extern SCM *scm_port_class;
extern SCM *scm_smob_class;
extern SCM scm_apply_generic_env;
/* Plugin Goops functions. */
extern SCM (*scm_make_extended_class) (char *type_name);
extern void (*scm_make_port_classes) (int ptobnum, char *type_name);
extern void (*scm_change_object_class) (SCM, SCM, SCM);
extern void (*scm_memoize_method) (SCM x, SCM args);
extern SCM scm_sym_atdispatch;
extern SCM scm_class_of (SCM obj);
extern SCM scm_entity_p (SCM obj);
extern SCM scm_operator_p (SCM obj);
extern SCM scm_set_object_procedure_x (SCM obj, SCM procs);
#ifdef GUILE_DEBUG
extern SCM scm_object_procedures (SCM obj);
#endif
extern SCM scm_make_class_object (SCM metaclass, SCM layout);
extern SCM scm_make_subclass_object (SCM c, SCM layout);