diff options
author | Andy Wingo <wingo@pobox.com> | 2009-11-03 23:59:51 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-11-26 00:24:58 +0100 |
commit | b6cf4d026506b8e5042671f7503d4d9e9a810d49 (patch) | |
tree | 23fc026ced45b0ae756c4d0de111e9521711c7a8 /libguile/struct.c | |
parent | 9bd48cb17b4ce685f94f974442d452485a1017d6 (diff) | |
download | guile-b6cf4d026506b8e5042671f7503d4d9e9a810d49.tar.gz |
a very big commit cleaning up structs & goops. also applicable structs.
I tried to split this one, and I know it's a bit disruptive, but this
stuff really is one big cobweb. So instead we'll pretend like these are
separate commits, by separating the changelog.
Applicable struct runtime support.
* libguile/debug.c (scm_procedure_source):
* libguile/eval.c (scm_trampoline_0, scm_trampoline_1)
(scm_trampoline_2):
* libguile/eval.i.c (CEVAL):
* libguile/goops.c (scm_class_of):
* libguile/procprop.c (scm_i_procedure_arity):
* libguile/procs.c (scm_procedure_p, scm_procedure, scm_setter): Allow
for applicable structs. Whee!
* libguile/deprecated.h (scm_vtable_index_vtable): Define as a synonym
for scm_vtable_index_self.
(scm_vtable_index_printer): Alias scm_vtable_index_instance_printer.
(scm_struct_i_free): Alias scm_vtable_index_instance_finalize.
(scm_struct_i_flags): Alias scm_vtable_index_flags.
(SCM_STRUCTF_FLAGS): Be a -1 mask, we have a whole word now.
(SCM_SET_VTABLE_DESTRUCTOR): Implement by hand.
Hidden slots.
* libguile/struct.c (scm_make_struct_layout): Add support for "hidden"
fields, writable fields that are not visible to make-struct. This
allows us to add fields to vtables and not break existing make-struct
invocations.
(scm_struct_ref, scm_struct_set_x): Always get struct length from the
vtable. Support hidden fields.
* libguile/goops.c (scm_class_hidden, scm_class_protected_hidden): New
slot classes, to correspond to the new vtable slots.
(scm_sys_prep_layout_x): Turn hidden slots into 'h'.
(build_class_class_slots): Reorder the class slots to account for
vtable fields coming out of negative-land, for name as a vtable slot,
and for hidden fields.
(create_standard_classes): Define <hidden-slot> and
<protected-hidden-slot>.
Clean up struct.h.
* libguile/struct.h: Lay things out cleaner. There are no more hidden
(negative) words. Names are nicer. The exposition is nicer. But the
basics are the same. The incompatibilities are that <vtable> has more
slots now, and that scm_alloc_struct's signature has changed. The
former is ameliorated by the "hidden" slots mentioned before, and the
latter, well, it was always a very internal thing...
(scm_t_struct_finalize): New type, a finalizer function to be run when
instances of a vtable are collected.
(scm_t_struct_free): Removed, structs' data is managed by the GC now,
and not freed by vtable functions.
* libguile/struct.c: (scm_vtable_p): Now we keep flags on
vtable-vtables, so this check is cheaper.
(scm_alloc_struct): No hidden words. Yippee.
(struct_finalizer_trampoline): Entersify.
(scm_make_struct): No need to babysit extra words, though now we have
to babysit flags. Propagate the vtable, applicable, and setter flags
appropriately.
(scm_make_vtable_vtable): Update for new simplicity.
(scm_print_struct): A better printer.
(scm_init_struct): Define <applicable-struct-vtable>, a magical vtable
like CL's funcallable-standard-class. Also define
<applicable-struct-with-setter-vtable>.
Remove foreign object implementation.
* libguile/goops.h:
* libguile/goops.c (scm_make_foreign_object, scm_make_class)
(scm_add_slot, scm_wrap_object, scm_wrap_component): Remove, these
were undocumented and unworking.
Clean up goops.h, a little.
* libguile/goops.h:
* libguile/goops.c: Also clean up.
* module/oop/goops/dispatch.scm (hashset-index): Adapt for new hashset
index.
Diffstat (limited to 'libguile/struct.c')
-rw-r--r-- | libguile/struct.c | 356 |
1 files changed, 183 insertions, 173 deletions
diff --git a/libguile/struct.c b/libguile/struct.c index f202d661e..ca3f68860 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -45,8 +45,13 @@ +/* A needlessly obscure test. */ +#define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */ + static SCM required_vtable_fields = SCM_BOOL_F; -SCM scm_struct_table; +static SCM required_applicable_fields = SCM_BOOL_F; +static SCM required_applicable_with_setter_fields = SCM_BOOL_F; +SCM scm_struct_table = SCM_BOOL_F; SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, @@ -57,9 +62,14 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, "type, the second a field protection. Allowed types are 'p' for\n" "GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n" "a field that points to the structure itself. Allowed protections\n" - "are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque\n" - "fields. The last field protection specification may be capitalized to\n" - "indicate that the field is a tail-array.") + "are 'w' for mutable fields, 'h' for hidden fields, 'r' for read-only\n" + "fields, and 'o' for opaque fields.\n\n" + "Hidden fields are writable, but they will not consume an initializer arg\n" + "passed to @code{make-struct}. They are useful to add slots to a struct\n" + "in a way that preserves backward-compatibility with existing calls to\n" + "@code{make-struct}, especially for derived vtables.\n\n" + "The last field protection specification may be capitalized to indicate\n" + "that the field is a tail-array.") #define FUNC_NAME s_scm_make_struct_layout { SCM new_sym; @@ -96,6 +106,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, switch (c = scm_i_string_ref (fields, x + 1)) { case 'w': + case 'h': if (scm_i_string_ref (fields, x) == 's') SCM_MISC_ERROR ("self fields not writable", SCM_EOL); case 'r': @@ -138,12 +149,13 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, static void -scm_struct_init (SCM handle, SCM layout, scm_t_bits * mem, int tail_elts, SCM inits) +scm_struct_init (SCM handle, SCM layout, int tail_elts, SCM inits) { scm_t_wchar prot = 0; int n_fields = scm_i_symbol_length (layout) / 2; int tailp = 0; int i; + scm_t_bits *mem = SCM_STRUCT_DATA (handle); i = -2; while (n_fields) @@ -236,33 +248,9 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0, "Return @code{#t} iff @var{x} is a vtable structure.") #define FUNC_NAME s_scm_struct_vtable_p { - SCM layout; - scm_t_bits * mem; - SCM tmp; - size_t len; - - if (!SCM_STRUCTP (x)) - return SCM_BOOL_F; - - layout = SCM_STRUCT_LAYOUT (x); - - if (scm_i_symbol_length (layout) - < scm_i_string_length (required_vtable_fields)) - return SCM_BOOL_F; - - len = scm_i_string_length (required_vtable_fields); - tmp = scm_string_eq (scm_symbol_to_string (layout), - required_vtable_fields, - scm_from_size_t (0), - scm_from_size_t (len), - scm_from_size_t (0), - scm_from_size_t (len)); - if (scm_is_false (tmp)) - return SCM_BOOL_F; - - mem = SCM_STRUCT_DATA (x); - - return scm_from_bool (scm_is_symbol (SCM_PACK (mem[scm_vtable_index_layout]))); + return scm_from_bool + (SCM_STRUCTP (x) + && SCM_STRUCT_VTABLE_FLAG_IS_SET (x, SCM_VTABLE_FLAG_VTABLE)); } #undef FUNC_NAME @@ -274,54 +262,27 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0, address of that data doesn't end in three zeros, tagging it will destroy the pointer. - This function allocates a block of memory, and returns a pointer at - least scm_struct_n_extra_words words into the block. Furthermore, - it guarantees that that pointer's least three significant bits are - all zero. - - The argument n_words should be the number of words that should - appear after the returned address. (That is, it shouldn't include - scm_struct_n_extra_words.) - - This function initializes the following fields of the struct: - - scm_struct_i_ptr --- the actual start of the block of memory; the - address you should pass to 'free' to dispose of the block. - This field allows us to both guarantee that the returned - address is divisible by eight, and allow the GC to free the - block. + I suppose we should make it clear here that, the data must be 8-byte aligned, + *within* the struct, and the struct itself should be 8-byte aligned. In + practice we ensure this because the data starts two words into a struct. - scm_struct_i_n_words --- the number of words allocated to the - block, including the extra fields. This is used by the GC. - - Ugh. */ - - -scm_t_bits * -scm_alloc_struct (int n_words, int n_extra, const char *what) + This function allocates an 8-byte aligned block of memory, whose first word + 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) { - int size = sizeof (scm_t_bits) * (n_words + n_extra) + 7; - void * block = scm_gc_malloc (size, what); - - /* Adjust the pointer to hide the extra words. */ - scm_t_bits * p = (scm_t_bits *) block + n_extra; - - /* Adjust it even further so it's aligned on an eight-byte boundary. */ - p = (scm_t_bits *) (((scm_t_bits) p + 7) & ~7); - - /* Initialize a few fields as described above. */ - p[scm_struct_i_free] = (scm_t_bits) 0; - p[scm_struct_i_ptr] = (scm_t_bits) block; - p[scm_struct_i_n_words] = n_words; - p[scm_struct_i_flags] = 0; - - /* Since `SCM' objects will record either P or P + SCM_TC3_STRUCT, we need - to register them as valid displacements. Fortunately, only a handful of - N_EXTRA values are used in core Guile. */ - GC_REGISTER_DISPLACEMENT ((char *)p - (char *)block); - GC_REGISTER_DISPLACEMENT ((char *)p - (char *)block + scm_tc3_struct); - - return p; + 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); } @@ -333,25 +294,10 @@ 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); - /* XXX - use less explicit code. */ - scm_t_bits word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_struct; - scm_t_bits *vtable_data = (scm_t_bits *) word0; - scm_t_bits *data = SCM_STRUCT_DATA (obj); - scm_t_struct_free free_struct_data - = ((scm_t_struct_free) vtable_data[scm_struct_i_free]); - - SCM_SET_CELL_TYPE (obj, scm_tc3_struct); - -#if 0 - /* A sanity check. However, this check can fail if the free function - changed between the `make-struct' time and now. */ - if (free_struct_data != (scm_t_struct_free)unused_data) - abort (); -#endif - - if (free_struct_data) - free_struct_data (vtable_data, data); + if (finalize) + finalize (obj); } @@ -368,30 +314,23 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, "successive fields of the structure should be initialized. Only fields\n" "with protection 'r' or 'w' can be initialized, except for fields of\n" "type 's', which are automatically initialized to point to the new\n" - "structure itself; fields with protection 'o' can not be initialized by\n" + "structure itself. Fields with protection 'o' can not be initialized by\n" "Scheme programs.\n\n" "If fewer optional arguments than initializable fields are supplied,\n" "fields of type 'p' get default value #f while fields of type 'u' are\n" "initialized to 0.\n\n" - "Structs are currently the basic representation for record-like data\n" - "structures in Guile. The plan is to eventually replace them with a\n" - "new representation which will at the same time be easier to use and\n" - "more powerful.\n\n" "For more information, see the documentation for @code{make-vtable-vtable}.") #define FUNC_NAME s_scm_make_struct { SCM layout; size_t basic_size; size_t tail_elts; - scm_t_bits *data, *c_vtable; - SCM handle; + SCM obj; SCM_VALIDATE_VTABLE (1, vtable); SCM_VALIDATE_REST_ARGUMENT (init); - c_vtable = SCM_STRUCT_DATA (vtable); - - layout = SCM_PACK (c_vtable [scm_vtable_index_layout]); + layout = SCM_VTABLE_LAYOUT (vtable); basic_size = scm_i_symbol_length (layout) / 2; tail_elts = scm_to_size_t (tail_array_size); @@ -414,47 +353,81 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, goto bad_tail; } - /* In guile 1.8.5 and earlier, everything below was covered by a - CRITICAL_SECTION lock. This can lead to deadlocks in garbage - collection, since other threads might be holding the heap_mutex, while - sleeping on the CRITICAL_SECTION lock. There does not seem to be any - need for a lock on the section below, as it does not access or update - any globals, so the critical section has been removed. */ + obj = scm_alloc_struct (SCM_STRUCT_DATA (vtable), basic_size + tail_elts, + "struct"); - if (c_vtable[scm_struct_i_flags] & SCM_STRUCTF_GOOPS_HACK) - { - data = scm_alloc_struct (basic_size + tail_elts, - scm_struct_entity_n_extra_words, - "entity struct"); - data[scm_struct_i_procedure] = SCM_UNPACK (SCM_BOOL_F); - data[scm_struct_i_setter] = SCM_UNPACK (SCM_BOOL_F); - } - else - data = scm_alloc_struct (basic_size + tail_elts, - scm_struct_n_extra_words, - "struct"); - handle = scm_double_cell ((((scm_t_bits) c_vtable) - + scm_tc3_struct), - (scm_t_bits) data, 0, 0); - - if (c_vtable[scm_struct_i_free]) + if (SCM_VTABLE_INSTANCE_FINALIZER (vtable)) { /* Register a finalizer for the newly created instance. */ GC_finalization_proc prev_finalizer; GC_PTR prev_finalizer_data; - scm_t_struct_free free_struct = - (scm_t_struct_free)c_vtable[scm_struct_i_free]; - - GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (handle), + GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (obj), struct_finalizer_trampoline, - free_struct, + NULL, &prev_finalizer, &prev_finalizer_data); } - scm_struct_init (handle, layout, data, tail_elts, init); + 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. + */ + 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); + } + } - return handle; + return obj; } #undef FUNC_NAME @@ -512,8 +485,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, SCM layout; size_t basic_size; size_t tail_elts; - scm_t_bits *data; - SCM handle; + SCM obj; SCM_VALIDATE_STRING (1, user_fields); SCM_VALIDATE_REST_ARGUMENT (init); @@ -524,15 +496,13 @@ 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; - data = scm_alloc_struct (basic_size + tail_elts, - scm_struct_n_extra_words, - "struct"); - handle = scm_double_cell ((scm_t_bits) data + scm_tc3_struct, - (scm_t_bits) data, 0, 0); - data [scm_vtable_index_layout] = SCM_UNPACK (layout); - scm_struct_init (handle, layout, data, tail_elts, scm_cons (layout, init)); + obj = scm_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; - return handle; + scm_struct_init (obj, layout, tail_elts, scm_cons (layout, init)); + SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE); + return obj; } #undef FUNC_NAME @@ -611,8 +581,7 @@ scm_i_struct_equalp (SCM s1, SCM s2) SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, (SCM handle, SCM pos), - "@deffnx {Scheme Procedure} struct-set! struct n value\n" - "Access (or modify) the @var{n}th field of @var{struct}.\n\n" + "Access the @var{n}th field of @var{struct}.\n\n" "If the field is of type 'p', then it can be set to an arbitrary value.\n\n" "If the field is of type 'u', then it can only be set to a non-negative\n" "integer value small enough to fit in one machine word.") @@ -634,11 +603,9 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, p = scm_to_size_t (pos); layout_len = scm_i_symbol_length (layout); - if (SCM_STRUCT_VTABLE_FLAGS (handle) & SCM_STRUCTF_LIGHT) - /* no extra words */ - n_fields = layout_len / 2; - else - n_fields = data[scm_struct_i_n_words]; + n_fields = layout_len / 2; + if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1))) + n_fields += data[n_fields - 1]; SCM_ASSERT_RANGE(1, pos, p < n_fields); @@ -647,7 +614,7 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, scm_t_wchar ref; field_type = scm_i_symbol_ref (layout, p * 2); ref = scm_i_symbol_ref (layout, p * 2 + 1); - if ((ref != 'r') && (ref != 'w')) + if ((ref != 'r') && (ref != 'w') && (ref != 'h')) { if ((ref == 'R') || (ref == 'W')) field_type = 'u'; @@ -713,11 +680,9 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, p = scm_to_size_t (pos); layout_len = scm_i_symbol_length (layout); - if (SCM_STRUCT_VTABLE_FLAGS (handle) & SCM_STRUCTF_LIGHT) - /* no extra words */ - n_fields = layout_len / 2; - else - n_fields = data[scm_struct_i_n_words]; + n_fields = layout_len / 2; + if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1))) + n_fields += data[n_fields - 1]; SCM_ASSERT_RANGE (1, pos, p < n_fields); @@ -726,7 +691,7 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, char set_x; field_type = scm_i_symbol_ref (layout, p * 2); set_x = scm_i_symbol_ref (layout, p * 2 + 1); - if (set_x != 'w') + if (set_x != 'w' && set_x != 'h') SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos)); } else if (scm_i_symbol_ref (layout, layout_len - 1) == 'W') @@ -854,13 +819,39 @@ scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) SCM name = scm_struct_vtable_name (vtable); scm_puts ("#<", port); if (scm_is_true (name)) - scm_display (name, port); + { + scm_display (name, port); + scm_putc (' ', port); + } else - scm_puts ("struct", port); - scm_putc (' ', port); - scm_uintprint (SCM_UNPACK (vtable), 16, port); - scm_putc (':', port); + { + if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE)) + scm_puts ("vtable:", port); + else + scm_puts ("struct:", port); + scm_uintprint (SCM_UNPACK (vtable), 16, port); + scm_putc (' ', port); + scm_write (SCM_VTABLE_LAYOUT (vtable), port); + scm_putc (' ', port); + } scm_uintprint (SCM_UNPACK (exp), 16, port); + /* hackety hack */ + if (SCM_STRUCT_APPLICABLE_P (exp)) + { + if (scm_is_true (SCM_STRUCT_PROCEDURE (exp))) + { + scm_puts (" proc: ", port); + if (scm_is_true (scm_procedure_p (SCM_STRUCT_PROCEDURE (exp)))) + scm_write (SCM_STRUCT_PROCEDURE (exp), port); + else + scm_puts ("(not a procedure?)", port); + } + if (SCM_STRUCT_SETTER_P (exp)) + { + scm_puts (" setter: ", port); + scm_write (SCM_STRUCT_SETTER (exp), port); + } + } scm_putc ('>', port); } } @@ -874,19 +865,38 @@ scm_struct_prehistory () void scm_init_struct () { - scm_struct_table - = scm_permanent_object (scm_make_weak_key_hash_table (scm_from_int (31))); - required_vtable_fields = scm_from_locale_string ("prsrpw"); - scm_permanent_object (required_vtable_fields); + SCM scm_applicable_struct_vtable_vtable; + SCM scm_applicable_struct_with_setter_vtable_vtable; + + GC_REGISTER_DISPLACEMENT (2*sizeof(scm_t_bits)); /* for the self data pointer */ + GC_REGISTER_DISPLACEMENT (2*sizeof(scm_t_bits) + + scm_tc3_struct); /* for the vtable data pointer */ + + scm_struct_table = scm_make_weak_key_hash_table (scm_from_int (31)); + required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT); + required_applicable_fields = scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT); + required_applicable_with_setter_fields = scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT); scm_i_vtable_vtable_no_extra_fields = - scm_permanent_object - (scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL)); + scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL); + + scm_applicable_struct_vtable_vtable = + scm_make_struct (scm_i_vtable_vtable_no_extra_fields, SCM_INUM0, + scm_list_1 (scm_make_struct_layout (required_vtable_fields))); + SCM_SET_VTABLE_FLAGS (scm_applicable_struct_vtable_vtable, + SCM_VTABLE_FLAG_APPLICABLE_VTABLE); + scm_c_define ("<applicable-struct-vtable>", scm_applicable_struct_vtable_vtable); + + scm_applicable_struct_with_setter_vtable_vtable = + scm_make_struct (scm_i_vtable_vtable_no_extra_fields, SCM_INUM0, + scm_list_1 (scm_make_struct_layout (required_vtable_fields))); + SCM_SET_VTABLE_FLAGS (scm_applicable_struct_with_setter_vtable_vtable, + SCM_VTABLE_FLAG_APPLICABLE_VTABLE | SCM_VTABLE_FLAG_SETTER_VTABLE); + scm_c_define ("<applicable-struct-with-setter-vtable>", scm_applicable_struct_with_setter_vtable_vtable); scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout)); - scm_c_define ("vtable-index-vtable", scm_from_int (scm_vtable_index_vtable)); scm_c_define ("vtable-index-printer", - scm_from_int (scm_vtable_index_printer)); + scm_from_int (scm_vtable_index_instance_printer)); scm_c_define ("vtable-offset-user", scm_from_int (scm_vtable_offset_user)); #include "libguile/struct.x" } |