* 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.
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;
"")
#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);
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;
}
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;
}
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,
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,
}
#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
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"
/* 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);
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
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)
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));
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,
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);
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);
*/
#define SCM_VTABLE_FLAG_GOOPS_CLASS SCM_VTABLE_FLAG_GOOPS_0
#define SCM_VTABLE_FLAG_GOOPS_VALID SCM_VTABLE_FLAG_GOOPS_1
-#define SCM_VTABLE_FLAG_GOOPS_METACLASS SCM_VTABLE_FLAG_GOOPS_2
-#define SCM_VTABLE_FLAG_GOOPS_FOREIGN SCM_VTABLE_FLAG_GOOPS_3
-#define SCM_VTABLE_FLAG_GOOPS_PURE_GENERIC SCM_VTABLE_FLAG_GOOPS_4
-#define SCM_VTABLE_FLAG_GOOPS_SIMPLE_METHOD SCM_VTABLE_FLAG_GOOPS_5
-#define SCM_VTABLE_FLAG_GOOPS_ACCESSOR_METHOD SCM_VTABLE_FLAG_GOOPS_6
+#define SCM_VTABLE_FLAG_GOOPS_PURE_GENERIC SCM_VTABLE_FLAG_GOOPS_2
#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
#define SCM_CLASS_FLAGS(class) (SCM_VTABLE_FLAGS (class))
#define SCM_SET_CLASS_FLAGS(c, f) (SCM_SET_VTABLE_FLAGS (c, f))
#define SCM_CLEAR_CLASS_FLAGS(c, f) (SCM_CLEAR_VTABLE_FLAGS (c, f))
-#define SCM_CLASSF_FOREIGN SCM_VTABLE_FLAG_GOOPS_FOREIGN
-#define SCM_CLASSF_METACLASS SCM_VTABLE_FLAG_GOOPS_METACLASS
+#define SCM_CLASSF_METACLASS (SCM_VTABLE_FLAG_GOOPS_CLASS|SCM_VTABLE_FLAG_VTABLE)
#define SCM_CLASSF_PURE_GENERIC SCM_VTABLE_FLAG_GOOPS_PURE_GENERIC
#define SCM_CLASSF_GOOPS_VALID SCM_VTABLE_FLAG_GOOPS_VALID
#define SCM_CLASSF_GOOPS SCM_VTABLE_FLAG_GOOPS_CLASS
-#define SCM_CLASSF_SIMPLE_METHOD SCM_VTABLE_FLAG_GOOPS_SIMPLE_METHOD
-#define SCM_CLASSF_ACCESSOR_METHOD SCM_VTABLE_FLAG_GOOPS_ACCESSOR_METHOD
#define SCM_CLASSF_GOOPS_OR_VALID (SCM_CLASSF_GOOPS | SCM_CLASSF_GOOPS_VALID)
/*
(SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_PURE_GENERIC))
#define SCM_VALIDATE_PUREGENERIC(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, PUREGENERICP, "pure generic function")
-#define SCM_ACCESSORP(x) \
- (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_ACCESSOR_METHOD))
-#define SCM_VALIDATE_ACCESSOR(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, ACCESSORP, "accessor")
-
#define SCM_SLOT(x, i) (SCM_STRUCT_SLOT_REF (x, i))
#define SCM_SET_SLOT(x, i, v) (SCM_STRUCT_SLOT_SET (x, i, v))
#define SCM_INSTANCE_HASH(c, i) (SCM_INST (c) [scm_si_hashsets + (i)])
#define SCM_INITIAL_MCACHE_SIZE 1
-#define scm_si_methods 0 /* offset of methods slot in a <generic> */
-#define scm_si_n_specialized 1
-#define scm_si_cache_mutex 2
-#define scm_si_extended_by 3
-#define scm_si_generic_cache 4
-#define scm_si_dispatch_procedure 5
-#define scm_si_effective_methods 6
-#define scm_si_generic_setter 7
+#define scm_si_dispatch_procedure scm_applicable_struct_index_procedure /* 0 */
+#define scm_si_methods 1
+#define scm_si_n_specialized 2
+#define scm_si_cache_mutex 3
+#define scm_si_extended_by 4
+#define scm_si_generic_cache 5
+#define scm_si_effective_methods 6
+#define scm_si_generic_setter 7
#define scm_si_generic_function 0 /* offset of gf slot in a <method> */
#define scm_si_specializers 1 /* offset of spec. slot in a <method> */
SCM_API SCM scm_class_object;
SCM_API SCM scm_class_class;
SCM_API SCM scm_class_applicable;
-SCM_API SCM scm_class_entity;
-SCM_API SCM scm_class_entity_with_setter;
+SCM_API SCM scm_class_applicable_struct;
+SCM_API SCM scm_class_applicable_struct_with_setter;
SCM_API SCM scm_class_generic;
SCM_API SCM scm_class_generic_with_setter;
SCM_API SCM scm_class_accessor;
SCM_API SCM scm_class_extended_generic_with_setter;
SCM_API SCM scm_class_extended_accessor;
SCM_API SCM scm_class_method;
-SCM_API SCM scm_class_simple_method;
SCM_API SCM scm_class_accessor_method;
SCM_API SCM scm_class_procedure_class;
-SCM_API SCM scm_class_entity_class;
+SCM_API SCM scm_class_applicable_struct_class;
SCM_API SCM scm_class_number;
SCM_API SCM scm_class_list;
SCM_API SCM scm_class_keyword;
SCM_API SCM scm_class_input_output_port;
SCM_API SCM scm_class_input_port;
SCM_API SCM scm_class_output_port;
-SCM_API SCM scm_class_foreign_class;
-SCM_API SCM scm_class_foreign_object;
SCM_API SCM scm_class_foreign_slot;
SCM_API SCM scm_class_self;
SCM_API SCM scm_class_protected;
SCM_API SCM scm_method_generic_function (SCM obj);
SCM_API SCM scm_method_specializers (SCM obj);
SCM_API SCM scm_method_procedure (SCM obj);
-SCM_API SCM scm_accessor_method_slot_definition (SCM obj);
SCM_API SCM scm_sys_tag_body (SCM body);
SCM_API SCM scm_sys_fast_slot_ref (SCM obj, SCM index);
SCM_API SCM scm_sys_fast_slot_set_x (SCM obj, SCM index, SCM value);
\f
+void
+scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
+#define FUNC_NAME "%inherit-vtable-magic"
+{
+ /* Verily, what is the deal here, you ask? Basically, we need to know a couple
+ of properties of structures at runtime. For example, "is this structure a
+ vtable of vtables (a metaclass)?"; also, "is this structure applicable?".
+ Both of these questions also imply a certain layout of the structure. So
+ instead of checking the layout at runtime, what we do is pre-verify the
+ layout -- so that at runtime we can just check the applicable flag and
+ dispatch directly to the Scheme procedure in slot 0.
+ */
+ SCM olayout;
+
+ /* verify that obj is a valid vtable */
+ if (scm_is_false (scm_symbol_p (SCM_VTABLE_LAYOUT (obj))))
+ scm_misc_error (FUNC_NAME, "invalid layout for new vtable",
+ scm_list_1 (SCM_VTABLE_LAYOUT (obj)));
+
+ /* if obj's vtable is compatible with the required vtable (class) layout, it
+ is a metaclass */
+ olayout = scm_symbol_to_string (SCM_VTABLE_LAYOUT (obj));
+ if (scm_is_true (scm_leq_p (scm_string_length (required_vtable_fields),
+ scm_string_length (olayout)))
+ && scm_is_true (scm_string_eq (olayout, required_vtable_fields,
+ scm_from_size_t (0),
+ scm_string_length (required_vtable_fields),
+ scm_from_size_t (0),
+ scm_string_length (required_vtable_fields))))
+ SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);
+
+ /* finally if obj is an applicable class, verify that its vtable is
+ compatible with the required applicable layout */
+ if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SETTER_VTABLE))
+ {
+ if (scm_is_false (scm_string_eq (olayout, required_applicable_with_setter_fields,
+ scm_from_size_t (0),
+ scm_from_size_t (4),
+ scm_from_size_t (0),
+ scm_from_size_t (4))))
+ scm_misc_error (FUNC_NAME, "invalid applicable-with-setter struct layout",
+ scm_list_1 (olayout));
+ SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE | SCM_VTABLE_FLAG_SETTER);
+ }
+ else if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE))
+ {
+ if (scm_is_false (scm_string_eq (olayout, required_applicable_fields,
+ scm_from_size_t (0),
+ scm_from_size_t (2),
+ scm_from_size_t (0),
+ scm_from_size_t (2))))
+ scm_misc_error (FUNC_NAME, "invalid applicable struct layout",
+ scm_list_1 (olayout));
+ SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE);
+ }
+}
+#undef FUNC_NAME
static void
#undef FUNC_NAME
+/* Finalization: invoke the finalizer of the struct pointed to by PTR. */
+static void
+struct_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);
+}
+
/* All struct data must be allocated at an address whose bottom three
bits are zero. This is because the tag for a struct lives in the
bottom three bits of the struct's car, and the upper bits point to
points to the given vtable data, then a data pointer, then n_words of data.
*/
SCM
-scm_alloc_struct (scm_t_bits *vtable_data, int n_words, const char *what)
+scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words, const char *what)
{
scm_t_bits ret;
ret = (scm_t_bits)scm_gc_malloc (sizeof (scm_t_bits) * (n_words + 2), "struct");
- /* Now that all platforms support scm_t_uint64, I would think that malloc on
- all platforms is required to return 8-byte-aligned blocks. This test will
- let us find out quickly though ;-) */
- if (ret & 7)
- abort ();
SCM_SET_CELL_WORD_0 (SCM_PACK (ret), (scm_t_bits)vtable_data | scm_tc3_struct);
SCM_SET_CELL_WORD_1 (SCM_PACK (ret),
(scm_t_bits)SCM_CELL_OBJECT_LOC (SCM_PACK (ret), 2));
- return SCM_PACK (ret);
-}
-\f
-/* Finalization. */
-
-
-/* Invoke the finalizer of the struct pointed to by PTR. */
-static void
-struct_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data)
-{
- SCM obj = PTR2SCM (ptr);
- scm_t_struct_finalize finalize = SCM_STRUCT_FINALIZER (obj);
+ /* vtable_data can be null when making a vtable vtable */
+ if (vtable_data && vtable_data[scm_vtable_index_instance_finalize])
+ {
+ /* Register a finalizer for the newly created instance. */
+ GC_finalization_proc prev_finalizer;
+ GC_PTR prev_finalizer_data;
+ GC_REGISTER_FINALIZER_NO_ORDER ((void*)ret,
+ struct_finalizer_trampoline,
+ NULL,
+ &prev_finalizer,
+ &prev_finalizer_data);
+ }
- if (finalize)
- finalize (obj);
+ return SCM_PACK (ret);
}
-
-
\f
SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
(SCM vtable, SCM tail_array_size, SCM init),
goto bad_tail;
}
- obj = scm_alloc_struct (SCM_STRUCT_DATA (vtable), basic_size + tail_elts,
- "struct");
-
- if (SCM_VTABLE_INSTANCE_FINALIZER (vtable))
- {
- /* 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),
- struct_finalizer_trampoline,
- NULL,
- &prev_finalizer,
- &prev_finalizer_data);
- }
+ obj = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), basic_size + tail_elts,
+ "struct");
scm_struct_init (obj, layout, tail_elts, init);
- /* Verily, what is the deal here, you ask? Basically, we need to know a couple
- of properties of structures at runtime. For example, "is this structure a
- vtable of vtables (a metaclass)?"; also, "is this structure applicable?".
- Both of these questions also imply a certain layout of the structure. So
- instead of checking the layout at runtime, what we do is pre-verify the
- layout -- so that at runtime we can just check the applicable flag and
- dispatch directly to the Scheme procedure in slot 0.
- */
+ /* only check things and inherit magic if the layout was passed as an initarg.
+ something of a hack, but it's for back-compatibility. */
if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE)
- /* only do these checks if the layout was passed as an initarg.
- something of a hack, but it's for back-compatibility. */
&& scm_is_true (SCM_VTABLE_LAYOUT (obj)))
- {
- /* scm_struct_init will have initialized our layout */
- SCM olayout;
-
- /* verify that obj is a valid vtable */
- if (scm_is_false (scm_symbol_p (SCM_VTABLE_LAYOUT (obj))))
- scm_misc_error (FUNC_NAME, "invalid layout for new vtable",
- scm_list_1 (SCM_VTABLE_LAYOUT (obj)));
-
- /* if obj is a metaclass, verify that its vtable is compatible with the
- required vtable (class) layout */
- olayout = scm_symbol_to_string (SCM_VTABLE_LAYOUT (obj));
- if (scm_is_true (scm_string_eq (olayout, required_vtable_fields,
- scm_from_size_t (0),
- scm_string_length (olayout),
- scm_from_size_t (0),
- scm_string_length (required_vtable_fields))))
- SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);
-
- /* finally if obj is an applicable class, verify that its vtable is
- compatible with the required applicable layout */
- if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SETTER_VTABLE))
- {
- if (scm_is_false (scm_string_eq (olayout, required_applicable_with_setter_fields,
- scm_from_size_t (0),
- scm_from_size_t (4),
- scm_from_size_t (0),
- scm_from_size_t (4))))
- scm_misc_error (FUNC_NAME, "invalid applicable-with-setter struct layout",
- scm_list_1 (olayout));
- SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE | SCM_VTABLE_FLAG_SETTER);
- }
- else if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE))
- {
- if (scm_is_false (scm_string_eq (olayout, required_applicable_fields,
- scm_from_size_t (0),
- scm_from_size_t (2),
- scm_from_size_t (0),
- scm_from_size_t (2))))
- scm_misc_error (FUNC_NAME, "invalid applicable struct layout",
- scm_list_1 (olayout));
- SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE);
- }
- }
+ scm_i_struct_inherit_vtable_magic (vtable, obj);
return obj;
}
basic_size = scm_i_symbol_length (layout) / 2;
tail_elts = scm_to_size_t (tail_array_size);
SCM_CRITICAL_SECTION_START;
- obj = scm_alloc_struct (NULL, basic_size + tail_elts, "struct");
+ obj = scm_i_alloc_struct (NULL, basic_size + tail_elts, "struct");
/* magic magic magic */
SCM_SET_CELL_WORD_0 (obj, (scm_t_bits)SCM_STRUCT_DATA (obj) | scm_tc3_struct);
SCM_CRITICAL_SECTION_END;
\f
-SCM_API SCM scm_alloc_struct (scm_t_bits *vtable_data, int n_words, const char *what);
SCM_API SCM scm_make_struct_layout (SCM fields);
SCM_API SCM scm_struct_p (SCM x);
SCM_API SCM scm_struct_vtable_p (SCM x);
SCM_API SCM scm_make_struct (SCM vtable, SCM tail_array_size, SCM init);
SCM_API SCM scm_make_vtable (SCM fields, SCM printer);
SCM_API SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init);
-SCM_INTERNAL SCM scm_i_struct_equalp (SCM s1, SCM s2);
SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
SCM_API SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
SCM_API SCM scm_struct_vtable (SCM handle);
SCM_API SCM scm_struct_vtable_tag (SCM handle);
-SCM_INTERNAL unsigned long scm_struct_ihashq (SCM, unsigned long, void *);
SCM_API SCM scm_struct_create_handle (SCM obj);
SCM_API SCM scm_struct_vtable_name (SCM vtable);
SCM_API SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name);
SCM_API void scm_print_struct (SCM exp, SCM port, scm_print_state *);
SCM_API void scm_struct_prehistory (void);
+
+SCM_INTERNAL SCM scm_i_struct_equalp (SCM s1, SCM s2);
+SCM_INTERNAL unsigned long scm_struct_ihashq (SCM, unsigned long, void *);
+SCM_INTERNAL SCM scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words, const char *what);
+SCM_INTERNAL void scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj);
SCM_INTERNAL void scm_init_struct (void);
#endif /* SCM_STRUCT_H */
primitive-generic-generic enable-primitive-generic!
method-procedure accessor-method-slot-definition
slot-exists? make find-method get-keyword)
- :replace (<class> <entity-class> <entity>)
:no-backtrace)
(define *goops-module* (current-module))
(define (slot-init-function class slot-name)
(cadr (assq slot-name (slot-ref class 'getters-n-setters))))
+(define (accessor-method-slot-definition obj)
+ "Return the slot definition of the accessor @var{obj}."
+ (slot-ref obj 'slot-definition))
+
;;;
;;; {Standard methods used by the C runtime}
(display #\> file))
(next-method))))
-(define-method (write (o <foreign-object>) file)
- (let ((class (class-of o)))
- (if (slot-bound? class 'name)
- (begin
- (display "#<foreign-object " file)
- (display (class-name class) file)
- (display #\space file)
- (display-address o file)
- (display #\> file))
- (next-method))))
-
(define-method (write (class <class>) file)
(let ((meta (class-of class)))
(if (and (slot-bound? class 'name)
;;; compute-getters-n-setters
;;;
+;; FIXME!!!
(define (make-thunk thunk)
(lambda () (thunk)))
;; Support for the underlying structs:
- ;; Inherit class flags (invisible on scheme level) from supers
- (%inherit-magic! class supers)
-
;; Set the layout slot
- (%prep-layout! class)))
+ (%prep-layout! class)
+ ;; Inherit class flags (invisible on scheme level) from supers
+ (%inherit-magic! class supers)))
(define (initialize-object-procedure object initargs)
(let ((proc (get-keyword #:procedure initargs #f)))
(set-object-procedure! object
(lambda args (apply proc args)))))))
-(define-method (initialize (entity <entity>) initargs)
+(define-method (initialize (applicable-struct <applicable-struct>) initargs)
(next-method)
- (initialize-object-procedure entity initargs))
-
-(define-method (initialize (ews <entity-with-setter>) initargs)
- (next-method)
- (%set-object-setter! ews (get-keyword #:setter initargs #f)))
+ (initialize-object-procedure applicable-struct initargs))
(define-method (initialize (generic <generic>) initargs)
(let ((previous-definition (get-keyword #:default initargs #f))
(set-procedure-property! generic 'name name))
))
+(define-method (initialize (gws <generic-with-setter>) initargs)
+ (next-method)
+ (%set-object-setter! gws (get-keyword #:setter initargs #f)))
+
(define-method (initialize (eg <extended-generic>) initargs)
(next-method)
(slot-set! eg 'extends (get-keyword #:extends initargs '())))
(slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f)))
-(define-method (initialize (obj <foreign-object>) initargs))
-
;;;
;;; {Change-class}
;;;
(with-fluids ((*in-progress* (cons gf in-progress)))
(let ((dispatch (compute-dispatch-procedure
gf (slot-ref gf 'effective-methods))))
- (slot-set! gf 'dispatch-procedure dispatch)
+ (slot-set! gf 'procedure dispatch)
(apply dispatch args))))))))))
(define (cache-dispatch gf args)
(cache (cons (vector len types rest? cmethod)
(slot-ref gf 'effective-methods))))
(slot-set! gf 'effective-methods cache)
- (slot-set! gf 'dispatch-procedure (delayed-compile gf))
+ (slot-set! gf 'procedure (delayed-compile gf))
cmethod))
(parse 0 args))
HCoop / bpt / guile.git / commitdiff