summaryrefslogtreecommitdiff
path: root/libguile/struct.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2017-09-25 22:18:02 +0200
committerAndy Wingo <wingo@pobox.com>2017-09-25 22:18:13 +0200
commit84259f54e31064851c82031080f894e2099584a6 (patch)
tree76f3c8788046faaad39525330ff77d22e63f345d /libguile/struct.c
parent9211981524df0d263c64fc33d3ea0711fc8b9112 (diff)
parenta74d4ee4f6e062ff640f2532c9cfc9977bb68a49 (diff)
downloadguile-84259f54e31064851c82031080f894e2099584a6.tar.gz
Merge 'stable-2.2'
Resolve conflicts by removing capability of struct-ref / struct-set! to access unboxed slots.
Diffstat (limited to 'libguile/struct.c')
-rw-r--r--libguile/struct.c129
1 files changed, 83 insertions, 46 deletions
diff --git a/libguile/struct.c b/libguile/struct.c
index eb2bfbb56..57195bcb3 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -587,20 +587,25 @@ scm_i_struct_equalp (SCM s1, SCM s2)
for (field_num = 0; field_num < struct_size; field_num++)
{
- SCM s_field_num;
- SCM field1, field2;
-
- /* We have to use `scm_struct_ref ()' here so that fields are accessed
- consistently, notably wrt. field types and access rights. */
- s_field_num = scm_from_size_t (field_num);
- field1 = scm_struct_ref (s1, s_field_num);
- field2 = scm_struct_ref (s2, s_field_num);
-
- /* Self-referencing fields (type `s') must be skipped to avoid infinite
- recursion. */
- if (!(scm_is_eq (field1, s1) && (scm_is_eq (field2, s2))))
- if (scm_is_false (scm_equal_p (field1, field2)))
- return SCM_BOOL_F;
+ 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_i_symbol_ref (layout, field_num * 2) == 'u')
+ 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;
@@ -624,34 +629,22 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
"word.")
#define FUNC_NAME s_scm_struct_ref
{
- SCM vtable;
- scm_t_bits data;
+ SCM vtable, layout;
size_t nfields, p;
SCM_VALIDATE_STRUCT (1, handle);
vtable = SCM_STRUCT_VTABLE (handle);
+ layout = SCM_VTABLE_LAYOUT (vtable);
nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
p = scm_to_size_t (pos);
SCM_ASSERT_RANGE (2, pos, p < nfields);
- data = SCM_STRUCT_DATA_REF (handle, p);
+ /* Only 'p' fields. */
+ SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'p', layout, 0, FUNC_NAME);
- if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)))
- /* The fast path: HANDLE is a struct with only readable "p"
- fields. */
- return SCM_PACK (data);
- else
- {
- SCM layout;
- scm_t_wchar field_type;
-
- layout = SCM_STRUCT_LAYOUT (handle);
- field_type = scm_i_symbol_ref (layout, p * 2);
-
- return (field_type == 'p') ? SCM_PACK (data) : scm_from_uintptr_t (data);
- }
+ return SCM_STRUCT_SLOT_REF (handle, p);
}
#undef FUNC_NAME
@@ -663,33 +656,77 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
"to.")
#define FUNC_NAME s_scm_struct_set_x
{
- SCM vtable;
+ SCM vtable, layout;
size_t nfields, p;
SCM_VALIDATE_STRUCT (1, handle);
vtable = SCM_STRUCT_VTABLE (handle);
+ layout = SCM_VTABLE_LAYOUT (vtable);
nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
p = scm_to_size_t (pos);
SCM_ASSERT_RANGE (2, pos, p < nfields);
- if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE_RW)))
- /* The fast path: HANDLE is a struct with only "p" fields. */
- SCM_STRUCT_SLOT_SET (handle, p, val);
- else
- {
- SCM layout;
- scm_t_wchar field_type;
+ /* Only 'p' fields. */
+ SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'p', layout, 0, FUNC_NAME);
- layout = SCM_STRUCT_LAYOUT (handle);
- field_type = scm_i_symbol_ref (layout, p * 2);
+ SCM_STRUCT_SLOT_SET (handle, p, val);
- if (field_type == 'p')
- SCM_STRUCT_SLOT_SET (handle, p, val);
- else
- SCM_STRUCT_DATA_SET (handle, p, scm_to_uintptr_t (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
+{
+ SCM vtable, layout;
+ size_t nfields, p;
+
+ SCM_VALIDATE_STRUCT (1, handle);
+
+ vtable = SCM_STRUCT_VTABLE (handle);
+ layout = SCM_VTABLE_LAYOUT (vtable);
+ nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
+ p = scm_to_size_t (pos);
+
+ SCM_ASSERT_RANGE (2, pos, p < nfields);
+
+ /* Only 'u' fields. */
+ SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'u', layout, 0, 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
+{
+ SCM vtable, layout;
+ size_t nfields, p;
+
+ SCM_VALIDATE_STRUCT (1, handle);
+
+ vtable = SCM_STRUCT_VTABLE (handle);
+ layout = SCM_VTABLE_LAYOUT (vtable);
+ nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
+ p = scm_to_size_t (pos);
+
+ SCM_ASSERT_RANGE (2, pos, p < nfields);
+
+ /* Only 'u' fields. */
+ SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'u', layout, 0, FUNC_NAME);
+
+ SCM_STRUCT_DATA_SET (handle, p, scm_to_uintptr_t (val));
return val;
}