diff options
-rw-r--r-- | libguile/goops.c | 123 | ||||
-rw-r--r-- | libguile/goops.h | 41 | ||||
-rw-r--r-- | libguile/struct.c | 179 | ||||
-rw-r--r-- | libguile/struct.h | 8 | ||||
-rw-r--r-- | module/oop/goops.scm | 38 | ||||
-rw-r--r-- | module/oop/goops/dispatch.scm | 4 |
6 files changed, 146 insertions, 247 deletions
diff --git a/libguile/goops.c b/libguile/goops.c index e0afa5543..d9e0525fe 100644 --- a/libguile/goops.c +++ b/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); diff --git a/libguile/goops.h b/libguile/goops.h index df92c23c3..c5b66196c 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -42,11 +42,7 @@ */ #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)) @@ -54,13 +50,10 @@ #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) /* @@ -140,10 +133,6 @@ typedef struct scm_t_method { (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)]) @@ -176,14 +165,14 @@ typedef struct scm_t_method { #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> */ @@ -213,8 +202,8 @@ SCM_API SCM scm_class_top; 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; @@ -222,10 +211,9 @@ SCM_API SCM scm_class_extended_generic; 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; @@ -233,8 +221,6 @@ SCM_API SCM scm_class_port; 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; @@ -304,7 +290,6 @@ SCM_API SCM scm_generic_function_methods (SCM obj); 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); 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; diff --git a/libguile/struct.h b/libguile/struct.h index eb4bfc2e4..a441bbab1 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -143,24 +143,26 @@ SCM_API SCM scm_struct_table; -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 */ diff --git a/module/oop/goops.scm b/module/oop/goops.scm index a1af66654..d06f62f6c 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -73,7 +73,6 @@ 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)) @@ -705,6 +704,10 @@ (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} @@ -745,17 +748,6 @@ (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) @@ -1168,6 +1160,7 @@ ;;; compute-getters-n-setters ;;; +;; FIXME!!! (define (make-thunk thunk) (lambda () (thunk))) @@ -1467,11 +1460,10 @@ ;; 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))) @@ -1484,13 +1476,9 @@ (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)) @@ -1504,6 +1492,10 @@ (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 '()))) @@ -1521,8 +1513,6 @@ (slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f))) -(define-method (initialize (obj <foreign-object>) initargs)) - ;;; ;;; {Change-class} ;;; diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm index 21a13c80b..ec03f599a 100644 --- a/module/oop/goops/dispatch.scm +++ b/module/oop/goops/dispatch.scm @@ -206,7 +206,7 @@ (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) @@ -242,7 +242,7 @@ (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)) |