summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/debug.c2
-rw-r--r--libguile/eval.c6
-rw-r--r--libguile/eval.i.c10
-rw-r--r--libguile/goops.c49
-rw-r--r--libguile/goops.h2
-rw-r--r--libguile/objects.c69
-rw-r--r--libguile/objects.h26
-rw-r--r--libguile/procprop.c6
-rw-r--r--libguile/procs.c9
-rw-r--r--libguile/struct.c2
-rw-r--r--libguile/struct.h2
11 files changed, 51 insertions, 132 deletions
diff --git a/libguile/debug.c b/libguile/debug.c
index c277c1398..fda071cb5 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -356,7 +356,7 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
}
}
case scm_tcs_struct:
- if (!SCM_I_ENTITYP (proc))
+ if (!(SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC))
break;
goto procprop;
case scm_tc7_smob:
diff --git a/libguile/eval.c b/libguile/eval.c
index 317be4042..8039efdef 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -3270,8 +3270,6 @@ scm_trampoline_0 (SCM proc)
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
trampoline = scm_call_generic_0;
- else if (SCM_I_ENTITYP (proc))
- trampoline = scm_call_0;
else
return NULL;
break;
@@ -3396,8 +3394,6 @@ scm_trampoline_1 (SCM proc)
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
trampoline = scm_call_generic_1;
- else if (SCM_I_ENTITYP (proc))
- trampoline = scm_call_1;
else
return NULL;
break;
@@ -3493,8 +3489,6 @@ scm_trampoline_2 (SCM proc)
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
trampoline = scm_call_generic_2;
- else if (SCM_I_ENTITYP (proc))
- trampoline = scm_call_2;
else
return NULL;
break;
diff --git a/libguile/eval.i.c b/libguile/eval.i.c
index 15107c51d..ccb612611 100644
--- a/libguile/eval.i.c
+++ b/libguile/eval.i.c
@@ -1031,6 +1031,7 @@ dispatch:
arg1 = SCM_EOL;
goto type_dispatch;
}
+#if 0
else if (SCM_I_ENTITYP (proc))
{
arg1 = proc;
@@ -1041,6 +1042,7 @@ dispatch:
#endif
goto evap1;
}
+#endif
else
goto badfun;
case scm_tc7_subr_1:
@@ -1162,6 +1164,7 @@ dispatch:
#endif
goto type_dispatch;
}
+#if 0
else if (SCM_I_ENTITYP (proc))
{
arg2 = arg1;
@@ -1173,6 +1176,7 @@ dispatch:
#endif
goto evap2;
}
+#endif
else
goto badfun;
case scm_tc7_subr_2:
@@ -1241,6 +1245,7 @@ dispatch:
#endif
goto type_dispatch;
}
+#if 0
else if (SCM_I_ENTITYP (proc))
{
operatorn:
@@ -1258,6 +1263,7 @@ dispatch:
SCM_EOL));
#endif
}
+#endif
else
goto badfun;
case scm_tc7_subr_0:
@@ -1467,8 +1473,10 @@ dispatch:
x = SCM_GENERIC_METHOD_CACHE (proc);
goto type_dispatch;
}
+#if 0
else if (SCM_I_ENTITYP (proc))
goto operatorn;
+#endif
else
goto badfun;
case scm_tc7_subr_2:
@@ -1772,6 +1780,7 @@ tail:
#endif
RETURN (scm_apply_generic (proc, args));
}
+#if 0
else if (SCM_I_ENTITYP (proc))
{
/* operator */
@@ -1791,6 +1800,7 @@ tail:
else
goto badproc;
}
+#endif
else
goto badproc;
default:
diff --git a/libguile/goops.c b/libguile/goops.c
index 3f9ad90d1..0a97a4a42 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -287,8 +287,9 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
if (!scm_is_symbol (name))
name = scm_string_to_symbol (scm_nullstr);
+ /* FIXME APPLICABLE structs */
class =
- scm_make_extended_class_from_symbol (name, SCM_I_ENTITYP (x));
+ scm_make_extended_class_from_symbol (name, 0);
SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
return class;
}
@@ -752,7 +753,7 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0,
}
flags &= SCM_CLASSF_INHERIT;
- if (! (flags & SCM_CLASSF_ENTITY))
+ if (! (flags & SCM_CLASSF_PURE_GENERIC))
{
long n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
#if 0
@@ -827,10 +828,8 @@ scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
}
/* Support for the underlying structs: */
- SCM_SET_CLASS_FLAGS (z, (class == scm_class_entity_class
- ? (SCM_CLASSF_GOOPS_OR_VALID
- | SCM_CLASSF_ENTITY)
- : SCM_CLASSF_GOOPS_OR_VALID));
+ /* FIXME: set entity flag on z if class == entity_class ? */
+ SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_GOOPS_OR_VALID);
return z;
}
@@ -1564,22 +1563,18 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
- /* Entities */
- if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY)
+ /* FIXME applicable structs */
+ /* Generic functions */
+ if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
{
+ SCM gf;
m = (SCM *) scm_alloc_struct (n, scm_struct_entity_n_extra_words,
- "entity struct");
+ "generic function");
m[scm_struct_i_setter] = SCM_BOOL_F;
m[scm_struct_i_procedure] = SCM_BOOL_F;
- /* Generic functions */
- if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
- {
- SCM gf = wrap_init (class, m, n);
- clear_method_cache (gf);
- return gf;
- }
- else
- return wrap_init (class, m, n);
+ gf = wrap_init (class, m, n);
+ clear_method_cache (gf);
+ return gf;
}
/* Class objects */
@@ -1594,8 +1589,7 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
for (i = scm_si_goops_fields; i < n; i++)
SCM_SET_SLOT (z, i, SCM_GOOPS_UNBOUND);
- if (SCM_SUBCLASSP (class, scm_class_entity_class))
- SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_ENTITY);
+ /* FIXME propagate applicable struct flag */
return z;
}
@@ -1613,11 +1607,12 @@ SCM_DEFINE (scm_sys_set_object_setter_x, "%set-object-setter!", 2, 0, 0,
"")
#define FUNC_NAME s_scm_sys_set_object_setter_x
{
- SCM_ASSERT (SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj),
+ SCM_ASSERT (SCM_STRUCTP (obj)
+ && (SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC),
obj,
SCM_ARG1,
FUNC_NAME);
- SCM_SET_ENTITY_SETTER (obj, setter);
+ SCM_SET_GENERIC_SETTER (obj, setter);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -2559,21 +2554,27 @@ create_standard_classes (void)
scm_class_entity_class,
scm_list_2 (scm_class_object, scm_class_applicable),
SCM_EOL);
+ SCM_CLEAR_CLASS_FLAGS (scm_class_entity, SCM_STRUCTF_LIGHT);
make_stdcls (&scm_class_entity_with_setter, "<entity-with-setter>",
scm_class_entity_class, scm_class_entity, SCM_EOL);
+ SCM_CLEAR_CLASS_FLAGS (scm_class_entity_with_setter, SCM_STRUCTF_LIGHT);
make_stdcls (&scm_class_generic, "<generic>",
scm_class_entity_class, scm_class_entity, gf_slots);
+ SCM_CLEAR_CLASS_FLAGS (scm_class_generic, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_generic, "<extended-generic>",
scm_class_entity_class, scm_class_generic, egf_slots);
+ SCM_CLEAR_CLASS_FLAGS (scm_class_extended_generic, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_extended_generic, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_generic_with_setter, "<generic-with-setter>",
scm_class_entity_class,
scm_list_2 (scm_class_generic, scm_class_entity_with_setter),
SCM_EOL);
+ SCM_CLEAR_CLASS_FLAGS (scm_class_generic_with_setter, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_accessor, "<accessor>",
scm_class_entity_class, scm_class_generic_with_setter, SCM_EOL);
+ SCM_CLEAR_CLASS_FLAGS (scm_class_accessor, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_generic_with_setter,
"<extended-generic-with-setter>",
@@ -2581,6 +2582,7 @@ create_standard_classes (void)
scm_list_2 (scm_class_generic_with_setter,
scm_class_extended_generic),
SCM_EOL);
+ SCM_CLEAR_CLASS_FLAGS (scm_class_extended_generic_with_setter, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_accessor, "<extended-accessor>",
@@ -2590,6 +2592,7 @@ create_standard_classes (void)
SCM_EOL);
fix_cpl (scm_class_extended_accessor,
scm_class_extended_generic, scm_class_generic);
+ SCM_CLEAR_CLASS_FLAGS (scm_class_extended_accessor, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
/* Primitive types classes */
@@ -2818,7 +2821,7 @@ make_struct_class (void *closure SCM_UNUSED,
SCM sym = SCM_STRUCT_TABLE_NAME (data);
if (scm_is_true (sym))
{
- int applicablep = SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_ENTITY;
+ int applicablep = 0; /* FIXME SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_ENTITY */
SCM_SET_STRUCT_TABLE_CLASS (data,
scm_make_extended_class_from_symbol (sym, applicablep));
diff --git a/libguile/goops.h b/libguile/goops.h
index 5d626c413..0f8a3e7a1 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -135,6 +135,8 @@ typedef struct scm_t_method {
#define SCM_GENERIC_METHOD_CACHE(G) (SCM_PACK (SCM_STRUCT_DATA (G) [scm_struct_i_procedure]))
#define SCM_SET_GENERIC_METHOD_CACHE(G,C) (SCM_STRUCT_DATA (G) [scm_struct_i_procedure] = SCM_UNPACK (C))
+#define SCM_GENERIC_SETTER(G) (SCM_PACK (SCM_STRUCT_DATA (G) [scm_struct_i_setter]))
+#define SCM_SET_GENERIC_SETTER(G,C) (SCM_STRUCT_DATA (G) [scm_struct_i_setter] = SCM_UNPACK (C))
#define SCM_MCACHE_N_SPECIALIZED(C) SCM_CADDR (C)
#define SCM_SET_MCACHE_N_SPECIALIZED(C, X) SCM_SETCAR (SCM_CDDR (C), X)
diff --git a/libguile/objects.c b/libguile/objects.c
index 81b941cf4..99aa6617d 100644
--- a/libguile/objects.c
+++ b/libguile/objects.c
@@ -199,78 +199,9 @@ scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
return scm_apply_generic (gf, scm_list_3 (a1, a2, a3));
}
-SCM_DEFINE (scm_entity_p, "entity?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is an entity.")
-#define FUNC_NAME s_scm_entity_p
-{
- return scm_from_bool(SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj));
-}
-#undef FUNC_NAME
-
-/* XXX - What code requires the object procedure to be only of certain
- types? */
-
-SCM_DEFINE (scm_valid_object_procedure_p, "valid-object-procedure?", 1, 0, 0,
- (SCM proc),
- "Return @code{#t} iff @var{proc} is a procedure that can be used "
- "with @code{set-object-procedure}. It is always valid to use "
- "a closure constructed by @code{lambda}.")
-#define FUNC_NAME s_scm_valid_object_procedure_p
-{
- if (SCM_IMP (proc))
- return SCM_BOOL_F;
- switch (SCM_TYP7 (proc))
- {
- default:
- return SCM_BOOL_F;
- case scm_tcs_closures:
- case scm_tc7_subr_1:
- case scm_tc7_subr_2:
- case scm_tc7_subr_3:
- case scm_tc7_lsubr_2:
- return SCM_BOOL_T;
- }
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0,
- (SCM obj, SCM proc),
- "Set the object procedure of @var{obj} to @var{proc}.\n"
- "@var{obj} must be an entity.")
-#define FUNC_NAME s_scm_set_object_procedure_x
-{
- SCM_ASSERT (SCM_STRUCTP (obj)
- && (SCM_I_ENTITYP (obj)
- && !(SCM_OBJ_CLASS_FLAGS (obj)
- & SCM_CLASSF_PURE_GENERIC)),
- obj,
- SCM_ARG1,
- FUNC_NAME);
- SCM_SET_ENTITY_PROCEDURE (obj, proc);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-#define SCM_METACLASS_STANDARD_LAYOUT ""
-
void
scm_init_objects ()
{
- SCM ms = scm_from_locale_string (SCM_METACLASS_STANDARD_LAYOUT);
- SCM mt = scm_make_vtable_vtable (ms, SCM_INUM0,
- scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
-
- SCM es = scm_from_locale_string (SCM_ENTITY_LAYOUT);
- SCM el = scm_make_struct_layout (es);
- SCM et = scm_make_struct (mt, SCM_INUM0,
- scm_list_4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL));
-
- scm_c_define ("<class>", mt);
- scm_metaclass_standard = mt;
- SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_ENTITY);
- scm_c_define ("<entity>", et);
-
#include "libguile/objects.x"
}
diff --git a/libguile/objects.h b/libguile/objects.h
index 4ab31a88f..aabc4ecf7 100644
--- a/libguile/objects.h
+++ b/libguile/objects.h
@@ -51,32 +51,11 @@
#define SCM_CLEAR_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) &= ~(f))
#define SCM_CLASSF_MASK SCM_STRUCTF_MASK
-#define SCM_CLASSF_ENTITY SCM_STRUCTF_ENTITY
-
-#define SCM_I_ENTITYP(obj)\
- ((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_ENTITY) != 0)
-#define SCM_ENTITY_PROCEDURE(obj) \
- (SCM_PACK (SCM_STRUCT_DATA (obj) [scm_struct_i_procedure]))
-#define SCM_SET_ENTITY_PROCEDURE(obj, v) \
- (SCM_STRUCT_DATA (obj) [scm_struct_i_procedure] = SCM_UNPACK (v))
-#define SCM_ENTITY_SETTER(obj) (SCM_PACK (SCM_STRUCT_DATA (obj)[scm_struct_i_setter]))
-#define SCM_SET_ENTITY_SETTER(obj, v) \
- (SCM_STRUCT_DATA (obj) [scm_struct_i_setter] = SCM_UNPACK (v))
-
#define SCM_SET_CLASS_DESTRUCTOR(c, d) SCM_SET_VTABLE_DESTRUCTOR (c, d)
#define SCM_SET_CLASS_INSTANCE_SIZE(c, s) \
(SCM_STRUCT_DATA (c)[scm_struct_i_size] \
= (SCM_STRUCT_DATA (c) [scm_struct_i_size] & SCM_STRUCTF_MASK) | s)
-/* {Entity classes}
- *
- * For instances of entity classes (entities), the procedures to be
- * applied are stored in the instance itself.
- *
- * An example of an entity class is the class of generic methods.
- */
-#define SCM_ENTITY_LAYOUT ""
-
/* {Interface to Goops}
*
* The evaluator contains a multi-method dispatch mechanism.
@@ -85,7 +64,7 @@
*/
/* Internal representation of Goops objects. */
-#define SCM_CLASSF_PURE_GENERIC (0x010 << 20)
+#define SCM_CLASSF_PURE_GENERIC SCM_STRUCTF_GOOPS_HACK
#define SCM_CLASSF_GOOPS_VALID (0x080 << 20)
#define SCM_CLASSF_GOOPS (0x100 << 20)
#define scm_si_redefined 5
@@ -119,9 +98,6 @@ SCM_API SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2);
SCM_API SCM scm_apply_generic (SCM gf, SCM args);
*/
SCM_API SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3);
-SCM_API SCM scm_entity_p (SCM obj);
-SCM_API SCM scm_valid_object_procedure_p (SCM proc);
-SCM_API SCM scm_set_object_procedure_x (SCM obj, SCM proc);
SCM_INTERNAL void scm_init_objects (void);
diff --git a/libguile/procprop.c b/libguile/procprop.c
index c461edd73..b7e8059ca 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -127,11 +127,13 @@ scm_i_procedure_arity (SCM proc)
r = 1;
break;
}
- else if (!SCM_I_ENTITYP (proc))
- return SCM_BOOL_F;
+ /* FIXME applicable structs */
+ return SCM_BOOL_F;
+#if 0
proc = SCM_ENTITY_PROCEDURE (proc);
a -= 1;
goto loop;
+#endif
default:
return SCM_BOOL_F;
}
diff --git a/libguile/procs.c b/libguile/procs.c
index d0e7fbd26..14646d989 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -98,7 +98,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
switch (SCM_TYP7 (obj))
{
case scm_tcs_struct:
- if (!SCM_I_ENTITYP (obj))
+ if (!(SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC))
break;
case scm_tcs_closures:
case scm_tcs_subrs:
@@ -262,7 +262,8 @@ SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0,
return SCM_PROCEDURE (proc);
else if (SCM_STRUCTP (proc))
{
- SCM_ASSERT (SCM_I_ENTITYP (proc), proc, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC,
+ proc, SCM_ARG1, FUNC_NAME);
return proc;
}
SCM_WRONG_TYPE_ARG (1, proc);
@@ -281,9 +282,9 @@ scm_setter (SCM proc)
else if (SCM_STRUCTP (proc))
{
SCM setter;
- SCM_GASSERT1 (SCM_I_ENTITYP (proc),
+ SCM_GASSERT1 (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC,
g_setter, proc, SCM_ARG1, s_setter);
- setter = SCM_ENTITY_SETTER (proc);
+ setter = SCM_GENERIC_SETTER (proc);
if (SCM_NIMP (setter))
return setter;
/* fall through */
diff --git a/libguile/struct.c b/libguile/struct.c
index 9dd900e37..33be8ad9b 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -420,7 +420,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
need for a lock on the section below, as it does not access or update
any globals, so the critical section has been removed. */
- if (c_vtable[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
+ if (c_vtable[scm_struct_i_flags] & SCM_STRUCTF_GOOPS_HACK)
{
data = scm_alloc_struct (basic_size + tail_elts,
scm_struct_entity_n_extra_words,
diff --git a/libguile/struct.h b/libguile/struct.h
index 206c82d29..fb655aa5e 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -51,7 +51,7 @@
typedef void (*scm_t_struct_free) (scm_t_bits * vtable, scm_t_bits * data);
#define SCM_STRUCTF_MASK (0xFFF << 20)
-#define SCM_STRUCTF_ENTITY (1L << 30) /* Indicates presence of proc slots */
+#define SCM_STRUCTF_GOOPS_HACK (0x010 << 20) /* FIXME -- PURE_GENERIC */
#define SCM_STRUCTF_LIGHT (1L << 31) /* Light representation
(no hidden words) */