diff options
Diffstat (limited to 'libguile/struct.c')
-rw-r--r-- | libguile/struct.c | 657 |
1 files changed, 191 insertions, 466 deletions
diff --git a/libguile/struct.c b/libguile/struct.c index b0604f7e1..3dbcc71d4 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -1,21 +1,21 @@ -/* Copyright (C) 1996-2001, 2003-2004, 2006-2013, 2015, - * 2017 Free Software Foundation, Inc. - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public License - * as published by the Free Software Foundation; either version 3 of - * the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - * 02110-1301 USA - */ +/* Copyright 1996-2001,2003-2004,2006-2013,2015,2017-2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + Guile is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public + License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with Guile. If not, see + <https://www.gnu.org/licenses/>. */ #ifdef HAVE_CONFIG_H @@ -24,36 +24,36 @@ #include <alloca.h> #include <assert.h> +#include <stdarg.h> +#include <string.h> #define SCM_BUILDING_DEPRECATED_CODE -#include "libguile/_scm.h" -#include "libguile/async.h" -#include "libguile/chars.h" -#include "libguile/deprecation.h" -#include "libguile/eval.h" -#include "libguile/alist.h" -#include "libguile/hashtab.h" -#include "libguile/ports.h" -#include "libguile/strings.h" -#include "libguile/srfi-13.h" +#include "alist.h" +#include "async.h" +#include "bdw-gc.h" +#include "boolean.h" +#include "chars.h" +#include "deprecation.h" +#include "eq.h" +#include "eval.h" +#include "finalizers.h" +#include "goops.h" +#include "gsubr.h" +#include "hashtab.h" +#include "modules.h" +#include "numbers.h" +#include "pairs.h" +#include "ports.h" +#include "srfi-13.h" +#include "strings.h" +#include "symbols.h" + +#include "struct.h" -#include "libguile/validate.h" -#include "libguile/struct.h" - -#include "libguile/eq.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - -#include "libguile/bdw-gc.h" -/* A needlessly obscure test. */ -#define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */ - static SCM required_vtable_fields = SCM_BOOL_F; static SCM required_applicable_fields = SCM_BOOL_F; static SCM required_applicable_with_setter_fields = SCM_BOOL_F; @@ -70,9 +70,8 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, "strung together. The first character of each pair describes a field\n" "type, the second a field protection. Allowed types are 'p' for\n" "GC-protected Scheme data, 'u' for unprotected binary data. \n" - "Allowed protections\n" - "are 'w' for mutable fields, 'h' for hidden fields, and\n" - "'r' for read-only fields.\n\n" + "Allowed protections are 'w' for normal fields or 'h' for \n" + "hidden 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" @@ -99,7 +98,6 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, { case 'u': case 'p': - case 's': break; default: SCM_MISC_ERROR ("unrecognized field type: ~S", @@ -110,20 +108,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, { case 'w': case 'h': - if (scm_i_string_ref (fields, x) == 's') - SCM_MISC_ERROR ("self fields not writable", SCM_EOL); case 'r': - case 'o': - break; - case 'R': - case 'W': - case 'O': - if (scm_i_string_ref (fields, x) == 's') - SCM_MISC_ERROR ("self fields not allowed in tail array", - SCM_EOL); - if (x != len - 2) - SCM_MISC_ERROR ("tail array field must be last field in layout", - SCM_EOL); break; default: SCM_MISC_ERROR ("unrecognized ref specification: ~S", @@ -138,61 +123,35 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, #undef FUNC_NAME -/* Check whether VTABLE instances have a simple layout (i.e., either - only "pr" or only "pw" fields and no tail array) and update its flags - accordingly. */ static void -set_vtable_layout_flags (SCM vtable) +set_vtable_access_fields (SCM vtable) { - size_t len, field; + size_t len, nfields, bitmask_size, field; SCM layout; const char *c_layout; - scm_t_bits flags = SCM_VTABLE_FLAG_SIMPLE; + uint32_t *unboxed_fields; layout = SCM_VTABLE_LAYOUT (vtable); c_layout = scm_i_symbol_chars (layout); len = scm_i_symbol_length (layout); assert (len % 2 == 0); + nfields = len / 2; - /* Update FLAGS according to LAYOUT. */ - for (field = 0; - field < len && flags & SCM_VTABLE_FLAG_SIMPLE; - field += 2) - { - if (c_layout[field] != 'p') - flags = 0; - else - switch (c_layout[field + 1]) - { - case 'w': - if (field == 0) - flags |= SCM_VTABLE_FLAG_SIMPLE_RW; - break; - - case 'r': - flags &= ~SCM_VTABLE_FLAG_SIMPLE_RW; - break; - - case 'o': - case 'O': - scm_c_issue_deprecation_warning - ("Opaque struct fields are deprecated. Struct field protection " - "should be layered on at a higher level."); - /* Fall through. */ - - default: - flags = 0; - } - } + bitmask_size = (nfields + 31U) / 32U; + unboxed_fields = scm_gc_malloc_pointerless (bitmask_size, "unboxed fields"); + memset (unboxed_fields, 0, bitmask_size * sizeof(*unboxed_fields)); - if (flags & SCM_VTABLE_FLAG_SIMPLE) - { - /* VTABLE is simple so update its flags and record the size of its - instances. */ - SCM_SET_VTABLE_FLAGS (vtable, flags); - SCM_STRUCT_DATA_SET (vtable, scm_vtable_index_size, len / 2); - } + /* Update FLAGS according to LAYOUT. */ + for (field = 0; field < nfields; field++) + if (c_layout[field*2] == 'u') + unboxed_fields[field/32U] |= 1U << (field%32U); + + /* Record computed size of vtable's instances. */ + SCM_SET_VTABLE_FLAGS (vtable, 0); + SCM_STRUCT_DATA_SET (vtable, scm_vtable_index_size, len / 2); + SCM_STRUCT_DATA_SET (vtable, scm_vtable_index_unboxed_fields, + (uintptr_t) unboxed_fields); } static int @@ -212,18 +171,16 @@ scm_is_valid_vtable_layout (SCM layout) { case 'u': case 'p': - case 's': switch (c_layout[n+1]) { - case 'W': - case 'R': - case 'O': - if (n + 2 != len) - return 0; case 'w': case 'h': + break; case 'r': - case 'o': + scm_c_issue_deprecation_warning + ("Read-only struct fields are deprecated. Implement access " + "control at a higher level instead, as structs no longer " + "enforce field permissions."); break; default: return 0; @@ -235,23 +192,6 @@ scm_is_valid_vtable_layout (SCM layout) return 1; } -static void -issue_deprecation_warning_for_self_slots (SCM vtable) -{ - SCM olayout; - size_t idx, first_user_slot = 0; - - olayout = scm_symbol_to_string (SCM_VTABLE_LAYOUT (vtable)); - if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE)) - first_user_slot = scm_vtable_offset_user; - - for (idx = first_user_slot * 2; idx < scm_c_string_length (olayout); idx += 2) - if (scm_is_eq (scm_c_string_ref (olayout, idx), SCM_MAKE_CHAR ('s'))) - scm_c_issue_deprecation_warning - ("Vtables with \"self\" slots are deprecated. Initialize these " - "fields manually."); -} - /* Have OBJ, a newly created vtable, inherit flags from VTABLE. VTABLE is a vtable-vtable and OBJ is an instance of VTABLE. */ void @@ -272,7 +212,7 @@ scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj) SCM_MISC_ERROR ("invalid layout for new vtable: ~a", scm_list_1 (SCM_VTABLE_LAYOUT (obj))); - set_vtable_layout_flags (obj); + set_vtable_access_fields (obj); /* If OBJ's vtable is compatible with the required vtable (class) layout, it is a metaclass. */ @@ -311,85 +251,35 @@ scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj) SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE); } - issue_deprecation_warning_for_self_slots (obj); - SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VALIDATED); } #undef FUNC_NAME static void -scm_struct_init (SCM handle, SCM layout, size_t n_tail, - size_t n_inits, scm_t_bits *inits) +scm_struct_init (SCM handle, SCM layout, size_t n_inits, scm_t_bits *inits) { - SCM vtable; - scm_t_bits *mem; - - vtable = SCM_STRUCT_VTABLE (handle); - mem = SCM_STRUCT_DATA (handle); - - if (SCM_UNPACK (vtable) != 0 - && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE) - && n_tail == 0 - && n_inits == SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size)) - /* The fast path: HANDLE has N_INITS "p" fields. */ - memcpy (mem, inits, n_inits * sizeof (SCM)); - else + size_t n, n_fields, inits_idx = 0; + + n_fields = SCM_STRUCT_SIZE (handle); + + for (n = 0; n < n_fields; n++) { - scm_t_wchar prot = 0; - int n_fields = scm_i_symbol_length (layout) / 2; - int tailp = 0; - int i; - size_t inits_idx = 0; - - i = -2; - while (n_fields) - { - if (!tailp) - { - i += 2; - prot = scm_i_symbol_ref (layout, i+1); - if (SCM_LAYOUT_TAILP (prot)) - { - tailp = 1; - prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o'; - *mem++ = (scm_t_bits)n_tail; - n_fields += n_tail - 1; - if (n_fields == 0) - break; - } - } - switch (scm_i_symbol_ref (layout, i)) - { - case 'u': - if ((prot != 'r' && prot != 'w') || inits_idx == n_inits) - *mem = 0; - else - { - *mem = scm_to_ulong (SCM_PACK (inits[inits_idx])); - inits_idx++; - } - break; - - case 'p': - if ((prot != 'r' && prot != 'w') || inits_idx == n_inits) - *mem = SCM_UNPACK (SCM_BOOL_F); - else - { - *mem = inits[inits_idx]; - inits_idx++; - } - - break; - - case 's': - *mem = SCM_UNPACK (handle); - break; - } - - n_fields--; - mem++; - } + if (inits_idx == n_inits || scm_i_symbol_ref (layout, n*2+1) == 'h') + { + if (SCM_STRUCT_FIELD_IS_UNBOXED (handle, n)) + SCM_STRUCT_DATA_SET (handle, n, 0); + else + SCM_STRUCT_SLOT_SET (handle, n, SCM_BOOL_F); + } + else + { + SCM_STRUCT_DATA_SET (handle, n, + SCM_STRUCT_FIELD_IS_UNBOXED (handle, n) + ? scm_to_uintptr_t (SCM_PACK (inits[inits_idx])) + : inits[inits_idx]); + inits_idx++; + } } } @@ -431,30 +321,17 @@ struct_finalizer_trampoline (void *ptr, void *unused_data) 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 - the data of its vtable, which is a struct itself. Thus, if the - address of that data doesn't end in three zeros, tagging it will - destroy the pointer. - - 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. - - 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_i_alloc_struct (scm_t_bits *vtable_data, int n_words) +/* A struct is a sequence of words preceded by a pointer to the struct's + vtable. The vtable reference is tagged with the struct tc3. */ +static SCM +scm_i_alloc_struct (scm_t_bits vtable_bits, int n_words) { SCM ret; - ret = scm_words ((scm_t_bits)vtable_data | scm_tc3_struct, n_words + 2); - SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2)); + ret = scm_words (vtable_bits | scm_tc3_struct, n_words + 1); - /* vtable_data can be null when making a vtable vtable */ - if (vtable_data && vtable_data[scm_vtable_index_instance_finalize]) + /* vtable_bits can be 0 when making a vtable vtable */ + if (vtable_bits && SCM_VTABLE_INSTANCE_FINALIZER (SCM_PACK (vtable_bits))) /* Register a finalizer for the newly created instance. */ scm_i_set_finalizer (SCM2PTR (ret), struct_finalizer_trampoline, NULL); @@ -466,35 +343,17 @@ SCM scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits *init) #define FUNC_NAME "make-struct" { - SCM layout; size_t basic_size; SCM obj; SCM_VALIDATE_VTABLE (1, vtable); - layout = SCM_VTABLE_LAYOUT (vtable); - basic_size = scm_i_symbol_length (layout) / 2; - - if (n_tail != 0) - { - SCM layout_str, last_char; - - if (basic_size == 0) - { - bad_tail: - SCM_MISC_ERROR ("tail array not allowed unless layout ends R, W, or O", SCM_EOL); - } - - layout_str = scm_symbol_to_string (layout); - last_char = scm_string_ref (layout_str, - scm_from_size_t (2 * basic_size - 1)); - if (! SCM_LAYOUT_TAILP (SCM_CHAR (last_char))) - goto bad_tail; - } + basic_size = SCM_VTABLE_SIZE (vtable); - obj = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), basic_size + n_tail); + SCM_ASSERT (n_tail == 0, scm_from_size_t (n_tail), 2, FUNC_NAME); - scm_struct_init (obj, layout, n_tail, n_init, init); + obj = scm_i_alloc_struct (SCM_UNPACK (vtable), basic_size); + scm_struct_init (obj, SCM_VTABLE_LAYOUT (vtable), n_init, init); /* If we're making a vtable, validate its layout and inherit flags. However we allow for separation of allocation and @@ -515,6 +374,8 @@ scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits init, .. scm_t_bits *v; size_t i; + SCM_ASSERT (n_tail == 0, scm_from_size_t (n_tail), 2, "scm_c_make_struct"); + v = alloca (sizeof (scm_t_bits) * n_init); va_start (foo, init); @@ -525,7 +386,7 @@ scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits init, .. } va_end (foo); - return scm_c_make_structv (vtable, n_tail, n_init, v); + return scm_c_make_structv (vtable, 0, n_init, v); } SCM_DEFINE (scm_allocate_struct, "allocate-struct", 2, 0, 0, @@ -546,19 +407,48 @@ SCM_DEFINE (scm_allocate_struct, "allocate-struct", 2, 0, 0, SCM_VALIDATE_VTABLE (1, vtable); c_nfields = scm_to_size_t (nfields); - SCM_ASSERT (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) == c_nfields, - nfields, 2, FUNC_NAME); + SCM_ASSERT (SCM_VTABLE_SIZE (vtable) == c_nfields, nfields, 2, FUNC_NAME); + + ret = scm_i_alloc_struct (SCM_UNPACK (vtable), c_nfields); + scm_struct_init (ret, SCM_VTABLE_LAYOUT (vtable), 0, NULL); + + return ret; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_struct_simple, "make-struct/simple", 1, 0, 1, + (SCM vtable, SCM init), + "Create a new structure.\n\n" + "@var{vtable} must be a vtable structure (@pxref{Vtables}).\n\n" + "The @var{init1}, @dots{} arguments supply the initial values\n" + "for the structure's fields\n.\n" + "This is a restricted variant of @code{make-struct/no-tail}\n" + "which applies only if the structure has no unboxed fields.\n" + "@code{make-struct/simple} must be called with as many\n" + "@var{init} values as the struct has fields. No finalizer is set\n" + "on the instance, even if the vtable has a non-zero finalizer\n" + "field. No magical vtable fields are inherited.\n\n" + "The advantage of using @code{make-struct/simple} is that the\n" + "compiler can inline it, so it is faster. When in doubt though,\n" + "use @code{make-struct/no-tail}.") +#define FUNC_NAME s_scm_make_struct_simple +{ + long i, n_init; + SCM ret; + + SCM_VALIDATE_VTABLE (1, vtable); + n_init = scm_ilength (init); + if (n_init != SCM_VTABLE_SIZE (vtable)) + SCM_MISC_ERROR ("Wrong number of initializers.", SCM_EOL); - ret = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), c_nfields); + ret = scm_words (SCM_UNPACK (vtable) | scm_tc3_struct, n_init + 1); - if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE))) + for (i = 0; i < n_init; i++, init = scm_cdr (init)) { - size_t n; - for (n = 0; n < c_nfields; n++) - SCM_STRUCT_DATA_SET (ret, n, SCM_UNPACK (SCM_BOOL_F)); + SCM_ASSERT (!SCM_VTABLE_FIELD_IS_UNBOXED (vtable, i), + vtable, 1, FUNC_NAME); + SCM_STRUCT_SLOT_SET (ret, i, scm_car (init)); } - else - scm_struct_init (ret, SCM_VTABLE_LAYOUT (vtable), 0, 0, NULL); return ret; } @@ -570,9 +460,8 @@ SCM_DEFINE (scm_make_struct_no_tail, "make-struct/no-tail", 1, 0, 1, "@var{vtable} must be a vtable structure (@pxref{Vtables}).\n\n" "The @var{init1}, @dots{} are optional arguments describing how\n" "successive fields of the structure should be initialized.\n" - "Only fields with protection 'r' or 'w' can be initialized.\n" - "Hidden fields (those with protection 'h') have to be manually\n" - "set.\n\n" + "Note that hidden fields (those with protection 'h') have to be\n" + "manually set.\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.") @@ -608,8 +497,7 @@ scm_i_make_vtable_vtable (SCM fields) #define FUNC_NAME "make-vtable-vtable" { SCM layout, obj; - size_t basic_size; - scm_t_bits v; + size_t n, nfields; SCM_VALIDATE_STRING (1, fields); @@ -617,16 +505,25 @@ scm_i_make_vtable_vtable (SCM fields) if (!scm_is_valid_vtable_layout (layout)) SCM_MISC_ERROR ("invalid user fields", scm_list_1 (fields)); - basic_size = scm_i_symbol_length (layout) / 2; + nfields = scm_i_symbol_length (layout) / 2; - obj = scm_i_alloc_struct (NULL, basic_size); + obj = scm_i_alloc_struct (0, nfields); /* Make it so that the vtable of OBJ is itself. */ - SCM_SET_CELL_WORD_0 (obj, (scm_t_bits) SCM_STRUCT_DATA (obj) | scm_tc3_struct); - - v = SCM_UNPACK (layout); - scm_struct_init (obj, layout, 0, 1, &v); - SCM_SET_VTABLE_FLAGS (obj, - SCM_VTABLE_FLAG_VTABLE | SCM_VTABLE_FLAG_VALIDATED); + SCM_SET_CELL_WORD_0 (obj, SCM_UNPACK (obj) | scm_tc3_struct); + /* Manually initialize fields. */ + SCM_STRUCT_SLOT_SET (obj, scm_vtable_index_layout, layout); + set_vtable_access_fields (obj); + SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE | SCM_VTABLE_FLAG_VALIDATED); + SCM_STRUCT_DATA_SET (obj, scm_vtable_index_instance_finalize, 0); + SCM_STRUCT_SLOT_SET (obj, scm_vtable_index_instance_printer, SCM_BOOL_F); + SCM_STRUCT_SLOT_SET (obj, scm_vtable_index_name, SCM_BOOL_F); + SCM_STRUCT_DATA_SET (obj, scm_vtable_index_reserved_7, 0); + + for (n = scm_vtable_offset_user; n < nfields; n++) + if (SCM_STRUCT_FIELD_IS_UNBOXED (obj, n)) + SCM_STRUCT_DATA_SET (obj, n, 0); + else + SCM_STRUCT_SLOT_SET (obj, n, SCM_BOOL_F); return obj; } @@ -653,26 +550,20 @@ SCM_DEFINE (scm_make_vtable, "make-vtable", 1, 1, 0, /* Return true if S1 and S2 are equal structures, i.e., if their vtable and - contents are the same. Field protections are honored. Thus, it is an - error to test the equality of structures that contain opaque fields. */ + contents are the same. */ SCM scm_i_struct_equalp (SCM s1, SCM s2) #define FUNC_NAME "scm_i_struct_equalp" { - SCM vtable1, vtable2, layout; size_t struct_size, field_num; SCM_VALIDATE_STRUCT (1, s1); SCM_VALIDATE_STRUCT (2, s2); - vtable1 = SCM_STRUCT_VTABLE (s1); - vtable2 = SCM_STRUCT_VTABLE (s2); - - if (!scm_is_eq (vtable1, vtable2)) + if (!scm_is_eq (SCM_STRUCT_VTABLE (s1), SCM_STRUCT_VTABLE (s2))) return SCM_BOOL_F; - layout = SCM_STRUCT_LAYOUT (s1); - struct_size = scm_i_symbol_length (layout) / 2; + struct_size = SCM_STRUCT_SIZE (s1); for (field_num = 0; field_num < struct_size; field_num++) { @@ -682,35 +573,21 @@ scm_i_struct_equalp (SCM s1, SCM s2) field2 = SCM_STRUCT_DATA_REF (s2, field_num); if (field1 != field2) { - switch (scm_i_symbol_ref (layout, field_num * 2)) + if (SCM_STRUCT_FIELD_IS_UNBOXED (s1, field_num)) + return SCM_BOOL_F; + + /* Having a normal field point to the object itself is a bit + bonkers, but R6RS enums do it, so here we have a horrible + hack. */ + if (field1 != SCM_UNPACK (s1) && field2 != SCM_UNPACK (s2)) { - case 'p': - /* Having a normal field point to the object itself is a bit - bonkers, but R6RS enums do it, so here we have a horrible - hack. */ - if (field1 != SCM_UNPACK (s1) && field2 != SCM_UNPACK (s2)) - { - if (scm_is_false - (scm_equal_p (SCM_PACK (field1), SCM_PACK (field2)))) - return SCM_BOOL_F; - } - break; - case 's': - /* Skip to avoid infinite recursion. */ - break; - case 'u': - return SCM_BOOL_F; - default: - /* Don't bother inspecting tail arrays; we never did this in - the past and in the future tail arrays are going away - anyway. */ - return SCM_BOOL_F; + if (scm_is_false + (scm_equal_p (SCM_PACK (field1), SCM_PACK (field2)))) + return SCM_BOOL_F; } } } - /* FIXME: Tail elements should be tested for equality. */ - return SCM_BOOL_T; } #undef FUNC_NAME @@ -732,75 +609,18 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, "word.") #define FUNC_NAME s_scm_struct_ref { - SCM vtable, answer = SCM_UNDEFINED; - scm_t_bits *data; - size_t p; + size_t nfields, p; SCM_VALIDATE_STRUCT (1, handle); - vtable = SCM_STRUCT_VTABLE (handle); - data = SCM_STRUCT_DATA (handle); + nfields = SCM_STRUCT_SIZE (handle); p = scm_to_size_t (pos); - if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE) - && p < SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size))) - /* The fast path: HANDLE is a struct with only "p" fields. */ - answer = SCM_PACK (data[p]); - else - { - SCM layout; - size_t layout_len, n_fields; - scm_t_wchar field_type = 0; - - layout = SCM_STRUCT_LAYOUT (handle); - layout_len = scm_i_symbol_length (layout); - 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 (2, pos, p < nfields); - SCM_ASSERT_RANGE (1, pos, p < n_fields); + SCM_ASSERT (!SCM_STRUCT_FIELD_IS_UNBOXED (handle, p), pos, 2, FUNC_NAME); - if (p * 2 < layout_len) - { - 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') && (ref != 'h')) - { - if ((ref == 'R') || (ref == 'W')) - field_type = 'u'; - else - SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos)); - } - } - else if (scm_i_symbol_ref (layout, layout_len - 1) != 'O') - field_type = scm_i_symbol_ref(layout, layout_len - 2); - else - SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos)); - - switch (field_type) - { - case 'u': - scm_c_issue_deprecation_warning - ("Accessing unboxed struct fields with struct-ref is deprecated. " - "Use struct-ref/unboxed instead."); - answer = scm_from_ulong (data[p]); - break; - - case 's': - case 'p': - answer = SCM_PACK (data[p]); - break; - - - default: - SCM_MISC_ERROR ("unrecognized field type: ~S", - scm_list_1 (SCM_MAKE_CHAR (field_type))); - } - } - - return answer; + return SCM_STRUCT_SLOT_REF (handle, p); } #undef FUNC_NAME @@ -812,70 +632,18 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, "to.") #define FUNC_NAME s_scm_struct_set_x { - SCM vtable; - scm_t_bits *data; - size_t p; + size_t nfields, p; SCM_VALIDATE_STRUCT (1, handle); - vtable = SCM_STRUCT_VTABLE (handle); - data = SCM_STRUCT_DATA (handle); + nfields = SCM_STRUCT_SIZE (handle); p = scm_to_size_t (pos); - if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE) - && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE_RW) - && p < SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size))) - /* The fast path: HANDLE is a struct with only "pw" fields. */ - data[p] = SCM_UNPACK (val); - else - { - SCM layout; - size_t layout_len, n_fields; - scm_t_wchar field_type = 0; + SCM_ASSERT_RANGE (2, pos, p < nfields); - layout = SCM_STRUCT_LAYOUT (handle); - layout_len = scm_i_symbol_length (layout); - n_fields = layout_len / 2; + SCM_ASSERT (!SCM_STRUCT_FIELD_IS_UNBOXED (handle, p), pos, 2, FUNC_NAME); - 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); - - if (p * 2 < layout_len) - { - 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' && 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') - field_type = scm_i_symbol_ref (layout, layout_len - 2); - else - SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos)); - - switch (field_type) - { - case 'u': - scm_c_issue_deprecation_warning - ("Accessing unboxed struct fields with struct-set! is deprecated. " - "Use struct-set!/unboxed instead."); - data[p] = SCM_NUM2ULONG (3, val); - break; - - case 'p': - data[p] = SCM_UNPACK (val); - break; - - case 's': - SCM_MISC_ERROR ("self fields immutable", SCM_EOL); - - default: - SCM_MISC_ERROR ("unrecognized field type: ~S", - scm_list_1 (SCM_MAKE_CHAR (field_type))); - } - } + SCM_STRUCT_SLOT_SET (handle, p, val); return val; } @@ -888,28 +656,16 @@ SCM_DEFINE (scm_struct_ref_unboxed, "struct-ref/unboxed", 2, 0, 0, "@var{handle}. The field must be of type 'u'.") #define FUNC_NAME s_scm_struct_ref_unboxed { - SCM vtable, layout; - size_t layout_len, n_fields; - size_t p; + size_t nfields, p; SCM_VALIDATE_STRUCT (1, handle); - vtable = SCM_STRUCT_VTABLE (handle); + nfields = SCM_STRUCT_SIZE (handle); p = scm_to_size_t (pos); - layout = SCM_VTABLE_LAYOUT (vtable); - layout_len = scm_i_symbol_length (layout); - n_fields = layout_len / 2; - - SCM_ASSERT_RANGE (1, pos, p < n_fields); - - /* Only 'u' fields, no tail arrays. */ - SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'u', - layout, 0, FUNC_NAME); + SCM_ASSERT_RANGE (2, pos, p < nfields); - /* Don't support opaque fields. */ - SCM_ASSERT (scm_i_symbol_ref (layout, p * 2 + 1) != 'o', - layout, 0, FUNC_NAME); + SCM_ASSERT (SCM_STRUCT_FIELD_IS_UNBOXED (handle, p), pos, 2, FUNC_NAME); return scm_from_uintptr_t (SCM_STRUCT_DATA_REF (handle, p)); } @@ -923,31 +679,16 @@ SCM_DEFINE (scm_struct_set_x_unboxed, "struct-set!/unboxed", 3, 0, 0, "to.") #define FUNC_NAME s_scm_struct_set_x_unboxed { - SCM vtable, layout; - size_t layout_len, n_fields; - size_t p; + size_t nfields, p; SCM_VALIDATE_STRUCT (1, handle); - vtable = SCM_STRUCT_VTABLE (handle); + nfields = SCM_STRUCT_SIZE (handle); p = scm_to_size_t (pos); - layout = SCM_VTABLE_LAYOUT (vtable); - layout_len = scm_i_symbol_length (layout); - n_fields = layout_len / 2; - - SCM_ASSERT_RANGE (1, pos, p < n_fields); - - /* Only 'u' fields, no tail arrays. */ - SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'u', - layout, 0, FUNC_NAME); - - /* Don't support opaque fields. */ - SCM_ASSERT (scm_i_symbol_ref (layout, p * 2 + 1) != 'o', - layout, 0, FUNC_NAME); + SCM_ASSERT_RANGE (2, pos, p < nfields); - if (scm_i_symbol_ref (layout, p * 2 + 1) == 'r') - SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos)); + SCM_ASSERT (SCM_STRUCT_FIELD_IS_UNBOXED (handle, p), pos, 2, FUNC_NAME); SCM_STRUCT_DATA_SET (handle, p, scm_to_uintptr_t (val)); @@ -1064,16 +805,6 @@ scm_init_struct () { SCM name; - /* The first word of a struct is equal to `SCM_STRUCT_DATA (vtable) + - scm_tc3_struct', and `SCM_STRUCT_DATA (vtable)' is 2 words after VTABLE by - default. */ - GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits) + scm_tc3_struct); - - /* In the general case, `SCM_STRUCT_DATA (obj)' points 2 words after the - beginning of a GC-allocated region; that region is different from that of - OBJ once OBJ has undergone class redefinition. */ - GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits)); - required_vtable_fields = scm_from_latin1_string (SCM_VTABLE_BASE_LAYOUT); scm_c_define ("standard-vtable-fields", required_vtable_fields); required_applicable_fields = scm_from_latin1_string (SCM_APPLICABLE_BASE_LAYOUT); @@ -1107,11 +838,5 @@ scm_init_struct () scm_c_define ("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" +#include "struct.x" } - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ |