summaryrefslogtreecommitdiff
path: root/libguile/struct.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/struct.c')
-rw-r--r--libguile/struct.c657
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:
-*/