summaryrefslogtreecommitdiff
path: root/libguile/struct.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-11-08 11:24:23 +0100
committerAndy Wingo <wingo@pobox.com>2009-11-26 00:25:07 +0100
commit51f66c912078a25ab0380c8fc070abb73d178d98 (patch)
tree2cd437a4e6f1ebba412bb0c68b2ddd7bab91889b /libguile/struct.c
parente29db33c14bc2cb21b7c044fcd0d61a68ad150bb (diff)
downloadguile-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.c179
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;