limn goops flags, remove foreign objs, rename entity to applicable-struct
* libguile/goops.c (scm_class_applicable_struct) (scm_class_applicable_struct_with_setter) (scm_class_applicable_struct_class): Rename from scm_class_entity, scm_class_entity_with_setter, and scm_class_entity_class. (scm_class_simple_method): Removed; this abstraction is not used. (scm_class_foreign_class, scm_class_foreign_object): Remove these, they are undocumented and unused. They might come back later. (scm_sys_inherit_magic_x): Simply inherit the vtable flags from the class's class. Flags are about layout, and it is the class that determines the layout of the instance. (scm_basic_basic_make_class): Don't bother setting GOOPS_OR_VALID, inherit-magic will do that. (scm_basic_make_class): Inherit magic after setting the layout. Allows the struct magic checker to do its job. (scm_accessor_method_slot_definition): Move implementation to Scheme. Removes the need for the accessor flag. (scm_sys_allocate_instance): Adapt to scm_i_alloc_struct name change, and that alloc-struct will handle finalization. (scm_compute_applicable_methods): Remove accessor check, as it's unnecessary. (scm_make): Adapt to new generic slot order, and no more simple-method. (create_standard_classes): What was the GF slot "dispatch-procedure" is now the applicable-struct slot "procedure". No more foreign class, foreign object, or simple method. Rename <entity> and friends to <applicable-struct> and friends. No more entity-with-setter -- though perhaps it will come back too. Instead generic-with-setter is its own thing. * libguile/goops.h (SCM_CLASSF_METACLASS): "A goops class that is a vtable" -- no need for a separate flag. (SCM_CLASSF_FOREIGN, SCM_CLASSF_SIMPLE_METHOD) (SCM_CLASSF_ACCESSOR_METHOD): Removed these unused flags. (SCM_ACCESSORP): Removed. Renumber generic slots, rename entity classes, and remove the foreign class, foreign object, and simple method classes. * libguile/struct.c (scm_i_struct_inherit_vtable_magic): New function, called when making new vtables.applicable structs (scm_i_alloc_struct): Remove 8-bit alignment check, as libGC guarantees this for us. Handle finalizer registration here. (scm_make_struct): Factor some things to scm_i_alloc_struct and scm_i_struct_inherit_vtable_magic. (scm_make_vtable_vtable): Adapt to scm_i_alloc_struct name change. * libguile/struct.h (scm_i_alloc_struct): Change name from scm_alloc_struct, and make internal. * module/oop/goops.scm (oop): Don't declare #:replace <class> et al, because <class> isn't defined in the core any more. (accessor-method-slot-definition): Defined in Scheme now. Remove <foreign-object> methods. (initialize on <class>): Prep layout before inheriting magic, as in scm_basic_make_class. * module/oop/goops/dispatch.scm (delayed-compile) (memoize-effective-method!): Adapt to 'procedure slot name change.
This commit is contained in:
Andy Wingo
parent
e29db33c14
commit
51f66c9120
6 changed files with 147 additions and 248 deletions
123
libguile/goops.c
123
libguile/goops.c
|
|
@ -144,20 +144,19 @@ SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction;
|
|||
SCM scm_class_unknown;
|
||||
SCM scm_class_top, scm_class_object, scm_class_class;
|
||||
SCM scm_class_applicable;
|
||||
SCM scm_class_entity, scm_class_entity_with_setter;
|
||||
SCM scm_class_applicable_struct, scm_class_applicable_struct_with_setter;
|
||||
SCM scm_class_generic, scm_class_generic_with_setter;
|
||||
SCM scm_class_accessor;
|
||||
SCM scm_class_extended_generic, scm_class_extended_generic_with_setter;
|
||||
SCM scm_class_extended_accessor;
|
||||
SCM scm_class_method;
|
||||
SCM scm_class_simple_method, scm_class_accessor_method;
|
||||
SCM scm_class_accessor_method;
|
||||
SCM scm_class_procedure_class;
|
||||
SCM scm_class_entity_class;
|
||||
SCM scm_class_applicable_struct_class;
|
||||
SCM scm_class_number, scm_class_list;
|
||||
SCM scm_class_keyword;
|
||||
SCM scm_class_port, scm_class_input_output_port;
|
||||
SCM scm_class_input_port, scm_class_output_port;
|
||||
SCM scm_class_foreign_class, scm_class_foreign_object;
|
||||
SCM scm_class_foreign_slot;
|
||||
SCM scm_class_self, scm_class_protected;
|
||||
SCM scm_class_hidden, scm_class_opaque, scm_class_read_only;
|
||||
|
|
@ -747,21 +746,9 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0,
|
|||
"")
|
||||
#define FUNC_NAME s_scm_sys_inherit_magic_x
|
||||
{
|
||||
SCM ls = dsupers;
|
||||
long flags = 0;
|
||||
SCM_VALIDATE_INSTANCE (1, class);
|
||||
while (!scm_is_null (ls))
|
||||
{
|
||||
SCM_ASSERT (scm_is_pair (ls)
|
||||
&& SCM_INSTANCEP (SCM_CAR (ls)),
|
||||
dsupers,
|
||||
SCM_ARG2,
|
||||
FUNC_NAME);
|
||||
flags |= SCM_CLASS_FLAGS (SCM_CAR (ls));
|
||||
ls = SCM_CDR (ls);
|
||||
}
|
||||
|
||||
SCM_SET_CLASS_FLAGS (class, flags &~SCM_CLASSF_PURE_GENERIC);
|
||||
scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
|
||||
SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID);
|
||||
|
||||
prep_hashsets (class);
|
||||
|
||||
|
|
@ -816,9 +803,6 @@ scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
|
|||
scm_si_direct_subclasses)));
|
||||
}
|
||||
|
||||
/* Support for the underlying structs: */
|
||||
/* FIXME: set entity flag on z if class == entity_class ? */
|
||||
SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_GOOPS_OR_VALID);
|
||||
return z;
|
||||
}
|
||||
|
||||
|
|
@ -826,8 +810,8 @@ SCM
|
|||
scm_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
|
||||
{
|
||||
SCM z = scm_basic_basic_make_class (class, name, dsupers, dslots);
|
||||
scm_sys_inherit_magic_x (z, dsupers);
|
||||
scm_sys_prep_layout_x (z);
|
||||
scm_sys_inherit_magic_x (z, dsupers);
|
||||
return z;
|
||||
}
|
||||
|
||||
|
|
@ -934,7 +918,7 @@ create_basic_classes (void)
|
|||
|
||||
DEFVAR(name, scm_class_class);
|
||||
|
||||
/**** <scm_class_top> ****/
|
||||
/**** <top> ****/
|
||||
name = scm_from_locale_symbol ("<top>");
|
||||
scm_class_top = scm_permanent_object (scm_basic_make_class (scm_class_class,
|
||||
name,
|
||||
|
|
@ -943,7 +927,7 @@ create_basic_classes (void)
|
|||
|
||||
DEFVAR(name, scm_class_top);
|
||||
|
||||
/**** <scm_class_object> ****/
|
||||
/**** <object> ****/
|
||||
name = scm_from_locale_symbol ("<object>");
|
||||
scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class,
|
||||
name,
|
||||
|
|
@ -1145,16 +1129,6 @@ SCM_DEFINE (scm_method_procedure, "method-procedure", 1, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_accessor_method_slot_definition, "accessor-method-slot-definition", 1, 0, 0,
|
||||
(SCM obj),
|
||||
"Return the slot definition of the accessor @var{obj}.")
|
||||
#define FUNC_NAME s_scm_accessor_method_slot_definition
|
||||
{
|
||||
SCM_VALIDATE_ACCESSOR (1, obj);
|
||||
return scm_slot_ref (obj, scm_from_locale_symbol ("slot-definition"));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
/******************************************************************************
|
||||
*
|
||||
* S l o t a c c e s s
|
||||
|
|
@ -1505,15 +1479,6 @@ SCM_DEFINE (scm_slot_exists_p, "slot-exists?", 2, 0, 0,
|
|||
|
||||
static void clear_method_cache (SCM);
|
||||
|
||||
static void
|
||||
goops_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data)
|
||||
{
|
||||
SCM obj = PTR2SCM (ptr);
|
||||
scm_t_struct_finalize finalize = SCM_STRUCT_FINALIZER (obj);
|
||||
|
||||
if (finalize)
|
||||
finalize (obj);
|
||||
}
|
||||
SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
|
||||
(SCM class, SCM initargs),
|
||||
"Create a new instance of class @var{class} and initialize it\n"
|
||||
|
|
@ -1530,7 +1495,7 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
|
|||
/* FIXME: duplicates some of scm_make_struct. */
|
||||
|
||||
n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
|
||||
obj = scm_alloc_struct (SCM_STRUCT_DATA (class), n, "struct");
|
||||
obj = scm_i_alloc_struct (SCM_STRUCT_DATA (class), n, "struct");
|
||||
|
||||
layout = SCM_VTABLE_LAYOUT (class);
|
||||
|
||||
|
|
@ -1545,26 +1510,9 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
|
|||
SCM_STRUCT_DATA (obj)[i] = 0;
|
||||
}
|
||||
|
||||
if (SCM_VTABLE_INSTANCE_FINALIZER (class))
|
||||
{
|
||||
/* Register a finalizer for the newly created instance. */
|
||||
GC_finalization_proc prev_finalizer;
|
||||
GC_PTR prev_finalizer_data;
|
||||
GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (obj),
|
||||
goops_finalizer_trampoline,
|
||||
NULL,
|
||||
&prev_finalizer,
|
||||
&prev_finalizer_data);
|
||||
}
|
||||
|
||||
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
|
||||
clear_method_cache (obj);
|
||||
|
||||
/* Class objects */
|
||||
/* if ((SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)
|
||||
&& (SCM_SUBCLASSP (class, scm_class_entity_class)))
|
||||
SCM_SET_CLASS_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE); */
|
||||
|
||||
return obj;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
|
@ -2219,10 +2167,6 @@ scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
|
|||
for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
|
||||
{
|
||||
fl = SPEC_OF (SCM_CAR (l));
|
||||
/* Only accept accessors which match exactly in first arg. */
|
||||
if (SCM_ACCESSORP (SCM_CAR (l))
|
||||
&& (scm_is_null (fl) || types[0] != SCM_CAR (fl)))
|
||||
continue;
|
||||
for (i = 0; ; i++, fl = SCM_CDR (fl))
|
||||
{
|
||||
if (SCM_INSTANCEP (fl)
|
||||
|
|
@ -2363,7 +2307,8 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
|
|||
if (class == scm_class_generic || class == scm_class_accessor)
|
||||
{
|
||||
z = scm_make_struct (class, SCM_INUM0,
|
||||
scm_list_4 (SCM_EOL,
|
||||
scm_list_5 (SCM_BOOL_F,
|
||||
SCM_EOL,
|
||||
SCM_INUM0,
|
||||
scm_make_mutex (),
|
||||
SCM_EOL));
|
||||
|
|
@ -2384,7 +2329,6 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
|
|||
z = scm_sys_allocate_instance (class, args);
|
||||
|
||||
if (class == scm_class_method
|
||||
|| class == scm_class_simple_method
|
||||
|| class == scm_class_accessor_method)
|
||||
{
|
||||
SCM_SET_SLOT (z, scm_si_generic_function,
|
||||
|
|
@ -2588,7 +2532,6 @@ create_standard_classes (void)
|
|||
k_init_value,
|
||||
SCM_EOL),
|
||||
scm_from_locale_symbol ("%cache"),
|
||||
scm_from_locale_symbol ("dispatch-procedure"),
|
||||
scm_from_locale_symbol ("effective-methods"),
|
||||
SCM_UNDEFINED);
|
||||
SCM setter_slots = scm_list_1 (sym_setter);
|
||||
|
|
@ -2637,63 +2580,45 @@ create_standard_classes (void)
|
|||
SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
|
||||
compute_getters_n_setters (slots));
|
||||
|
||||
make_stdcls (&scm_class_foreign_class, "<foreign-class>",
|
||||
scm_class_class, scm_class_class,
|
||||
scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
|
||||
k_class,
|
||||
scm_class_opaque),
|
||||
scm_list_3 (scm_from_locale_symbol ("destructor"),
|
||||
k_class,
|
||||
scm_class_opaque)));
|
||||
make_stdcls (&scm_class_foreign_object, "<foreign-object>",
|
||||
scm_class_foreign_class, scm_class_object, SCM_EOL);
|
||||
SCM_SET_CLASS_FLAGS (scm_class_foreign_object, SCM_CLASSF_FOREIGN);
|
||||
|
||||
/* scm_class_generic functions classes */
|
||||
make_stdcls (&scm_class_procedure_class, "<procedure-class>",
|
||||
scm_class_class, scm_class_class, SCM_EOL);
|
||||
make_stdcls (&scm_class_entity_class, "<entity-class>",
|
||||
make_stdcls (&scm_class_applicable_struct_class, "<applicable-struct-class>",
|
||||
scm_class_class, scm_class_procedure_class, SCM_EOL);
|
||||
/* SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class,
|
||||
SCM_VTABLE_FLAG_APPLICABLE_VTABLE); */
|
||||
make_stdcls (&scm_class_method, "<method>",
|
||||
scm_class_class, scm_class_object, method_slots);
|
||||
make_stdcls (&scm_class_simple_method, "<simple-method>",
|
||||
scm_class_class, scm_class_method, SCM_EOL);
|
||||
SCM_SET_CLASS_FLAGS (scm_class_simple_method, SCM_CLASSF_SIMPLE_METHOD);
|
||||
make_stdcls (&scm_class_accessor_method, "<accessor-method>",
|
||||
scm_class_class, scm_class_simple_method, amethod_slots);
|
||||
SCM_SET_CLASS_FLAGS (scm_class_accessor_method, SCM_CLASSF_ACCESSOR_METHOD);
|
||||
scm_class_class, scm_class_method, amethod_slots);
|
||||
make_stdcls (&scm_class_applicable, "<applicable>",
|
||||
scm_class_class, scm_class_top, SCM_EOL);
|
||||
make_stdcls (&scm_class_entity, "<entity>",
|
||||
scm_class_entity_class,
|
||||
make_stdcls (&scm_class_applicable_struct, "<applicable-struct>",
|
||||
scm_class_applicable_struct_class,
|
||||
scm_list_2 (scm_class_object, scm_class_applicable),
|
||||
SCM_EOL);
|
||||
make_stdcls (&scm_class_entity_with_setter, "<entity-with-setter>",
|
||||
scm_class_entity_class, scm_class_entity, SCM_EOL);
|
||||
scm_list_1 (sym_procedure));
|
||||
make_stdcls (&scm_class_generic, "<generic>",
|
||||
scm_class_entity_class, scm_class_entity, gf_slots);
|
||||
scm_class_applicable_struct_class, scm_class_applicable_struct, gf_slots);
|
||||
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_class_applicable_struct_class, scm_class_generic, egf_slots);
|
||||
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),
|
||||
setter_slots);
|
||||
scm_class_applicable_struct_class, scm_class_generic, setter_slots);
|
||||
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_class_applicable_struct_class, scm_class_generic_with_setter, SCM_EOL);
|
||||
SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_PURE_GENERIC);
|
||||
make_stdcls (&scm_class_extended_generic_with_setter,
|
||||
"<extended-generic-with-setter>",
|
||||
scm_class_entity_class,
|
||||
scm_class_applicable_struct_class,
|
||||
scm_list_2 (scm_class_generic_with_setter,
|
||||
scm_class_extended_generic),
|
||||
SCM_EOL);
|
||||
SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
|
||||
SCM_CLASSF_PURE_GENERIC);
|
||||
make_stdcls (&scm_class_extended_accessor, "<extended-accessor>",
|
||||
scm_class_entity_class,
|
||||
scm_class_applicable_struct_class,
|
||||
scm_list_2 (scm_class_accessor,
|
||||
scm_class_extended_generic_with_setter),
|
||||
SCM_EOL);
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue