diff options
author | Andy Wingo <wingo@pobox.com> | 2009-11-08 11:24:23 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-11-26 00:25:07 +0100 |
commit | 51f66c912078a25ab0380c8fc070abb73d178d98 (patch) | |
tree | 2cd437a4e6f1ebba412bb0c68b2ddd7bab91889b /libguile/struct.c | |
parent | e29db33c14bc2cb21b7c044fcd0d61a68ad150bb (diff) | |
download | guile-51f66c912078a25ab0380c8fc070abb73d178d98.tar.gz |
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.
Diffstat (limited to 'libguile/struct.c')
-rw-r--r-- | libguile/struct.c | 179 |
1 files changed, 88 insertions, 91 deletions
diff --git a/libguile/struct.c b/libguile/struct.c index ca3f68860..9fd73a6c0 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -146,6 +146,63 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, +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 @@ -255,6 +312,17 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0, #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 @@ -270,38 +338,30 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0, 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); -} - -/* 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); } - - SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, (SCM vtable, SCM tail_array_size, SCM init), @@ -353,79 +413,16 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, 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; } @@ -496,7 +493,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, 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; |