diff options
-rw-r--r-- | libguile/debug.c | 2 | ||||
-rw-r--r-- | libguile/eval.c | 6 | ||||
-rw-r--r-- | libguile/eval.i.c | 10 | ||||
-rw-r--r-- | libguile/goops.c | 49 | ||||
-rw-r--r-- | libguile/goops.h | 2 | ||||
-rw-r--r-- | libguile/objects.c | 69 | ||||
-rw-r--r-- | libguile/objects.h | 26 | ||||
-rw-r--r-- | libguile/procprop.c | 6 | ||||
-rw-r--r-- | libguile/procs.c | 9 | ||||
-rw-r--r-- | libguile/struct.c | 2 | ||||
-rw-r--r-- | libguile/struct.h | 2 |
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) */ |