summaryrefslogtreecommitdiff
path: root/libguile/struct.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/struct.c')
-rw-r--r--libguile/struct.c842
1 files changed, 842 insertions, 0 deletions
diff --git a/libguile/struct.c b/libguile/struct.c
new file mode 100644
index 000000000..3dbcc71d4
--- /dev/null
+++ b/libguile/struct.c
@@ -0,0 +1,842 @@
+/* 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
+# include <config.h>
+#endif
+
+#include <alloca.h>
+#include <assert.h>
+#include <stdarg.h>
+#include <string.h>
+
+#define SCM_BUILDING_DEPRECATED_CODE
+
+#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"
+
+
+
+
+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;
+SCM scm_applicable_struct_vtable_vtable;
+SCM scm_applicable_struct_with_setter_vtable_vtable;
+SCM scm_standard_vtable_vtable;
+
+
+
+SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
+ (SCM fields),
+ "Return a new structure layout object.\n\n"
+ "@var{fields} must be a string made up of pairs of characters\n"
+ "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 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"
+ "@code{make-struct}, especially for derived vtables.")
+#define FUNC_NAME s_scm_make_struct_layout
+{
+ SCM new_sym;
+ scm_t_wchar c;
+
+ SCM_VALIDATE_STRING (1, fields);
+
+ { /* scope */
+ size_t len;
+ int x;
+
+ len = scm_i_string_length (fields);
+ if (len % 2 == 1)
+ SCM_MISC_ERROR ("odd length field specification: ~S",
+ scm_list_1 (fields));
+
+ for (x = 0; x < len; x += 2)
+ {
+ switch (c = scm_i_string_ref (fields, x))
+ {
+ case 'u':
+ case 'p':
+ break;
+ default:
+ SCM_MISC_ERROR ("unrecognized field type: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (c)));
+ }
+
+ switch (c = scm_i_string_ref (fields, x + 1))
+ {
+ case 'w':
+ case 'h':
+ case 'r':
+ break;
+ default:
+ SCM_MISC_ERROR ("unrecognized ref specification: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (c)));
+ }
+ }
+ new_sym = scm_string_to_symbol (fields);
+ }
+ scm_remember_upto_here_1 (fields);
+ return new_sym;
+}
+#undef FUNC_NAME
+
+
+static void
+set_vtable_access_fields (SCM vtable)
+{
+ size_t len, nfields, bitmask_size, field;
+ SCM layout;
+ const char *c_layout;
+ 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;
+
+ bitmask_size = (nfields + 31U) / 32U;
+ unboxed_fields = scm_gc_malloc_pointerless (bitmask_size, "unboxed fields");
+ memset (unboxed_fields, 0, bitmask_size * sizeof(*unboxed_fields));
+
+ /* 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
+scm_is_valid_vtable_layout (SCM layout)
+{
+ size_t len, n;
+ const char *c_layout;
+
+ c_layout = scm_i_symbol_chars (layout);
+ len = scm_i_symbol_length (layout);
+
+ if (len % 2)
+ return 0;
+
+ for (n = 0; n < len; n += 2)
+ switch (c_layout[n])
+ {
+ case 'u':
+ case 'p':
+ switch (c_layout[n+1])
+ {
+ case 'w':
+ case 'h':
+ break;
+ case 'r':
+ 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;
+ }
+ break;
+ default:
+ return 0;
+ }
+ return 1;
+}
+
+/* Have OBJ, a newly created vtable, inherit flags from VTABLE. VTABLE is a
+ vtable-vtable and OBJ is an instance of VTABLE. */
+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_valid_vtable_layout (SCM_VTABLE_LAYOUT (obj)))
+ SCM_MISC_ERROR ("invalid layout for new vtable: ~a",
+ scm_list_1 (SCM_VTABLE_LAYOUT (obj)));
+
+ set_vtable_access_fields (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 ("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 ("invalid applicable struct layout",
+ scm_list_1 (olayout));
+ SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE);
+ }
+
+ SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VALIDATED);
+}
+#undef FUNC_NAME
+
+
+static void
+scm_struct_init (SCM handle, SCM layout, size_t n_inits, scm_t_bits *inits)
+{
+ size_t n, n_fields, inits_idx = 0;
+
+ n_fields = SCM_STRUCT_SIZE (handle);
+
+ for (n = 0; n < n_fields; n++)
+ {
+ 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++;
+ }
+ }
+}
+
+
+SCM_DEFINE (scm_struct_p, "struct?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} iff @var{x} is a structure object, else\n"
+ "@code{#f}.")
+#define FUNC_NAME s_scm_struct_p
+{
+ return scm_from_bool(SCM_STRUCTP (x));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} iff @var{x} is a vtable structure.")
+#define FUNC_NAME s_scm_struct_vtable_p
+{
+ if (!SCM_STRUCTP (x)
+ || !SCM_STRUCT_VTABLE_FLAG_IS_SET (x, SCM_VTABLE_FLAG_VTABLE))
+ return SCM_BOOL_F;
+ if (!SCM_VTABLE_FLAG_IS_SET (x, SCM_VTABLE_FLAG_VALIDATED))
+ SCM_MISC_ERROR ("vtable has invalid layout: ~A",
+ scm_list_1 (SCM_VTABLE_LAYOUT (x)));
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+
+/* Finalization: invoke the finalizer of the struct pointed to by PTR. */
+static void
+struct_finalizer_trampoline (void *ptr, void *unused_data)
+{
+ SCM obj = PTR2SCM (ptr);
+ scm_t_struct_finalize finalize = SCM_STRUCT_FINALIZER (obj);
+
+ if (finalize)
+ finalize (obj);
+}
+
+/* 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 (vtable_bits | scm_tc3_struct, n_words + 1);
+
+ /* 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);
+
+ return ret;
+}
+
+
+SCM
+scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits *init)
+#define FUNC_NAME "make-struct"
+{
+ size_t basic_size;
+ SCM obj;
+
+ SCM_VALIDATE_VTABLE (1, vtable);
+
+ basic_size = SCM_VTABLE_SIZE (vtable);
+
+ SCM_ASSERT (n_tail == 0, scm_from_size_t (n_tail), 2, FUNC_NAME);
+
+ 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
+ initialization, to humor GOOPS, so only validate if the layout was
+ passed as an initarg. */
+ if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE)
+ && scm_is_true (SCM_VTABLE_LAYOUT (obj)))
+ scm_i_struct_inherit_vtable_magic (vtable, obj);
+
+ return obj;
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits init, ...)
+{
+ va_list foo;
+ 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);
+ for (i = 0; i < n_init; i++)
+ {
+ v[i] = init;
+ init = va_arg (foo, scm_t_bits);
+ }
+ va_end (foo);
+
+ return scm_c_make_structv (vtable, 0, n_init, v);
+}
+
+SCM_DEFINE (scm_allocate_struct, "allocate-struct", 2, 0, 0,
+ (SCM vtable, SCM nfields),
+ "Allocate a new structure with space for @var{nfields} fields.\n\n"
+ "@var{vtable} must be a vtable structure (@pxref{Vtables}).\n\n"
+ "@var{nfields} must be a non-negative integer. Strictly speaking\n"
+ "@var{nfields} is redundant, as the vtable carries the size\n"
+ "for its instances. However passing it is useful as a sanity\n"
+ "check, given that one module can inline a constructor in\n"
+ "another.\n\n"
+ "Fields will be initialized with their default values.")
+#define FUNC_NAME s_scm_allocate_struct
+{
+ SCM ret;
+ size_t c_nfields;
+
+ SCM_VALIDATE_VTABLE (1, vtable);
+ c_nfields = scm_to_size_t (nfields);
+
+ 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_words (SCM_UNPACK (vtable) | scm_tc3_struct, n_init + 1);
+
+ for (i = 0; i < n_init; i++, init = scm_cdr (init))
+ {
+ SCM_ASSERT (!SCM_VTABLE_FIELD_IS_UNBOXED (vtable, i),
+ vtable, 1, FUNC_NAME);
+ SCM_STRUCT_SLOT_SET (ret, i, scm_car (init));
+ }
+
+ return ret;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_struct_no_tail, "make-struct/no-tail", 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{} are optional arguments describing how\n"
+ "successive fields of the structure should be initialized.\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.")
+#define FUNC_NAME s_scm_make_struct_no_tail
+{
+ size_t i, n_init;
+ long ilen;
+ scm_t_bits *v;
+
+ SCM_VALIDATE_VTABLE (1, vtable);
+ ilen = scm_ilength (init);
+ if (ilen < 0)
+ SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL);
+
+ n_init = (size_t)ilen;
+
+ /* best to use alloca, but init could be big, so hack to avoid a possible
+ stack overflow */
+ if (n_init < 64)
+ v = alloca (n_init * sizeof(scm_t_bits));
+ else
+ v = scm_gc_malloc (n_init * sizeof(scm_t_bits), "struct");
+
+ for (i = 0; i < n_init; i++, init = SCM_CDR (init))
+ v[i] = SCM_UNPACK (SCM_CAR (init));
+
+ return scm_c_make_structv (vtable, 0, n_init, v);
+}
+#undef FUNC_NAME
+
+SCM
+scm_i_make_vtable_vtable (SCM fields)
+#define FUNC_NAME "make-vtable-vtable"
+{
+ SCM layout, obj;
+ size_t n, nfields;
+
+ SCM_VALIDATE_STRING (1, fields);
+
+ layout = scm_make_struct_layout (fields);
+ if (!scm_is_valid_vtable_layout (layout))
+ SCM_MISC_ERROR ("invalid user fields", scm_list_1 (fields));
+
+ nfields = scm_i_symbol_length (layout) / 2;
+
+ obj = scm_i_alloc_struct (0, nfields);
+ /* Make it so that the vtable of OBJ is itself. */
+ 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;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_vtable, "make-vtable", 1, 1, 0,
+ (SCM fields, SCM printer),
+ "Create a vtable, for creating structures with the given\n"
+ "@var{fields}.\n"
+ "\n"
+ "The optional @var{printer} argument is a function to be called\n"
+ "@code{(@var{printer} struct port)} on the structures created.\n"
+ "It should look at @var{struct} and write to @var{port}.")
+#define FUNC_NAME s_scm_make_vtable
+{
+ if (SCM_UNBNDP (printer))
+ printer = SCM_BOOL_F;
+
+ return scm_c_make_struct (scm_standard_vtable_vtable, 0, 2,
+ SCM_UNPACK (scm_make_struct_layout (fields)),
+ SCM_UNPACK (printer));
+}
+#undef FUNC_NAME
+
+
+/* Return true if S1 and S2 are equal structures, i.e., if their vtable and
+ contents are the same. */
+SCM
+scm_i_struct_equalp (SCM s1, SCM s2)
+#define FUNC_NAME "scm_i_struct_equalp"
+{
+ size_t struct_size, field_num;
+
+ SCM_VALIDATE_STRUCT (1, s1);
+ SCM_VALIDATE_STRUCT (2, s2);
+
+ if (!scm_is_eq (SCM_STRUCT_VTABLE (s1), SCM_STRUCT_VTABLE (s2)))
+ return SCM_BOOL_F;
+
+ struct_size = SCM_STRUCT_SIZE (s1);
+
+ for (field_num = 0; field_num < struct_size; field_num++)
+ {
+ scm_t_bits field1, field2;
+
+ field1 = SCM_STRUCT_DATA_REF (s1, field_num);
+ field2 = SCM_STRUCT_DATA_REF (s2, field_num);
+
+ if (field1 != field2) {
+ 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))
+ {
+ if (scm_is_false
+ (scm_equal_p (SCM_PACK (field1), SCM_PACK (field2))))
+ return SCM_BOOL_F;
+ }
+ }
+ }
+
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+
+
+
+
+SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
+ (SCM handle, SCM pos),
+ "Access the @var{pos}th field of struct associated with\n"
+ "@var{handle}.\n"
+ "\n"
+ "If the field is of type 'p', then it can be set to an arbitrary\n"
+ "value.\n"
+ "\n"
+ "If the field is of type 'u', then it can only be set to a\n"
+ "non-negative integer value small enough to fit in one machine\n"
+ "word.")
+#define FUNC_NAME s_scm_struct_ref
+{
+ size_t nfields, p;
+
+ SCM_VALIDATE_STRUCT (1, handle);
+
+ nfields = SCM_STRUCT_SIZE (handle);
+ p = scm_to_size_t (pos);
+
+ SCM_ASSERT_RANGE (2, pos, p < nfields);
+
+ SCM_ASSERT (!SCM_STRUCT_FIELD_IS_UNBOXED (handle, p), pos, 2, FUNC_NAME);
+
+ return SCM_STRUCT_SLOT_REF (handle, p);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
+ (SCM handle, SCM pos, SCM val),
+ "Set the slot of the structure @var{handle} with index @var{pos}\n"
+ "to @var{val}. Signal an error if the slot can not be written\n"
+ "to.")
+#define FUNC_NAME s_scm_struct_set_x
+{
+ size_t nfields, p;
+
+ SCM_VALIDATE_STRUCT (1, handle);
+
+ nfields = SCM_STRUCT_SIZE (handle);
+ p = scm_to_size_t (pos);
+
+ SCM_ASSERT_RANGE (2, pos, p < nfields);
+
+ SCM_ASSERT (!SCM_STRUCT_FIELD_IS_UNBOXED (handle, p), pos, 2, FUNC_NAME);
+
+ SCM_STRUCT_SLOT_SET (handle, p, val);
+
+ return val;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_struct_ref_unboxed, "struct-ref/unboxed", 2, 0, 0,
+ (SCM handle, SCM pos),
+ "Access the @var{pos}th field of struct associated with\n"
+ "@var{handle}. The field must be of type 'u'.")
+#define FUNC_NAME s_scm_struct_ref_unboxed
+{
+ size_t nfields, p;
+
+ SCM_VALIDATE_STRUCT (1, handle);
+
+ nfields = SCM_STRUCT_SIZE (handle);
+ p = scm_to_size_t (pos);
+
+ SCM_ASSERT_RANGE (2, pos, p < nfields);
+
+ SCM_ASSERT (SCM_STRUCT_FIELD_IS_UNBOXED (handle, p), pos, 2, FUNC_NAME);
+
+ return scm_from_uintptr_t (SCM_STRUCT_DATA_REF (handle, p));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_struct_set_x_unboxed, "struct-set!/unboxed", 3, 0, 0,
+ (SCM handle, SCM pos, SCM val),
+ "Set the slot of the structure @var{handle} with index @var{pos}\n"
+ "to @var{val}. Signal an error if the slot can not be written\n"
+ "to.")
+#define FUNC_NAME s_scm_struct_set_x_unboxed
+{
+ size_t nfields, p;
+
+ SCM_VALIDATE_STRUCT (1, handle);
+
+ nfields = SCM_STRUCT_SIZE (handle);
+ p = scm_to_size_t (pos);
+
+ SCM_ASSERT_RANGE (2, pos, p < nfields);
+
+ SCM_ASSERT (SCM_STRUCT_FIELD_IS_UNBOXED (handle, p), pos, 2, FUNC_NAME);
+
+ SCM_STRUCT_DATA_SET (handle, p, scm_to_uintptr_t (val));
+
+ return val;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_struct_vtable, "struct-vtable", 1, 0, 0,
+ (SCM handle),
+ "Return the vtable structure that describes the type of struct\n"
+ "associated with @var{handle}.")
+#define FUNC_NAME s_scm_struct_vtable
+{
+ SCM_VALIDATE_STRUCT (1, handle);
+ return SCM_STRUCT_VTABLE (handle);
+}
+#undef FUNC_NAME
+
+
+/* {Associating names and classes with vtables}
+ *
+ * The name of a vtable should probably be stored as a slot. This is
+ * a backward compatible solution until agreement has been achieved on
+ * how to associate names with vtables.
+ */
+
+unsigned long
+scm_struct_ihashq (SCM obj, unsigned long n, void *closure)
+{
+ /* The length of the hash table should be a relative prime it's not
+ necessary to shift down the address. */
+ return SCM_UNPACK (obj) % n;
+}
+
+SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0,
+ (SCM vtable),
+ "Return the name of the vtable @var{vtable}.")
+#define FUNC_NAME s_scm_struct_vtable_name
+{
+ SCM_VALIDATE_VTABLE (1, vtable);
+ return SCM_VTABLE_NAME (vtable);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0,
+ (SCM vtable, SCM name),
+ "Set the name of the vtable @var{vtable} to @var{name}.")
+#define FUNC_NAME s_scm_set_struct_vtable_name_x
+{
+ SCM_VALIDATE_VTABLE (1, vtable);
+ SCM_VALIDATE_SYMBOL (2, name);
+ SCM_SET_VTABLE_NAME (vtable, name);
+ /* FIXME: remove this, and implement proper struct classes instead.
+ (Vtables *are* classes.) */
+ scm_i_define_class_for_vtable (vtable);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+
+
+void
+scm_print_struct (SCM exp, SCM port, scm_print_state *pstate)
+{
+ if (scm_is_true (scm_procedure_p (SCM_STRUCT_PRINTER (exp))))
+ scm_printer_apply (SCM_STRUCT_PRINTER (exp), exp, port, pstate);
+ else
+ {
+ SCM vtable = SCM_STRUCT_VTABLE (exp);
+ SCM name = scm_struct_vtable_name (vtable);
+ scm_puts ("#<", port);
+ if (scm_is_true (name))
+ {
+ scm_display (name, port);
+ scm_putc (' ', port);
+ }
+ else
+ {
+ 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);
+ }
+}
+
+void
+scm_init_struct ()
+{
+ SCM name;
+
+ 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);
+ required_applicable_with_setter_fields = scm_from_latin1_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT);
+
+ scm_standard_vtable_vtable =
+ scm_i_make_vtable_vtable (required_vtable_fields);
+ name = scm_from_utf8_symbol ("<standard-vtable>");
+ scm_set_struct_vtable_name_x (scm_standard_vtable_vtable, name);
+ scm_define (name, scm_standard_vtable_vtable);
+
+ scm_applicable_struct_vtable_vtable =
+ scm_c_make_struct (scm_standard_vtable_vtable, 0, 1,
+ SCM_UNPACK (scm_make_struct_layout (required_vtable_fields)));
+ name = scm_from_utf8_symbol ("<applicable-struct-vtable>");
+ SCM_SET_VTABLE_FLAGS (scm_applicable_struct_vtable_vtable,
+ SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
+ scm_set_struct_vtable_name_x (scm_applicable_struct_vtable_vtable, name);
+ scm_define (name, scm_applicable_struct_vtable_vtable);
+
+ scm_applicable_struct_with_setter_vtable_vtable =
+ scm_c_make_struct (scm_standard_vtable_vtable, 0, 1,
+ SCM_UNPACK (scm_make_struct_layout (required_vtable_fields)));
+ name = scm_from_utf8_symbol ("<applicable-struct-with-setter-vtable>");
+ scm_set_struct_vtable_name_x (scm_applicable_struct_with_setter_vtable_vtable, name);
+ SCM_SET_VTABLE_FLAGS (scm_applicable_struct_with_setter_vtable_vtable,
+ SCM_VTABLE_FLAG_APPLICABLE_VTABLE | SCM_VTABLE_FLAG_SETTER_VTABLE);
+ scm_define (name, 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-printer",
+ scm_from_int (scm_vtable_index_instance_printer));
+ scm_c_define ("vtable-offset-user", scm_from_int (scm_vtable_offset_user));
+#include "struct.x"
+}