{
case 'w':
case 'W':
- if (!(flags & SCM_VTABLE_FLAG_SIMPLE_RW) && field > 0)
- /* There's a mixture of `w' and `r' flags. */
- flags = 0;
- else
+ if (field == 0)
flags |= SCM_VTABLE_FLAG_SIMPLE_RW;
break;
case 'r':
case 'R':
- if (flags & SCM_VTABLE_FLAG_SIMPLE_RW)
- /* There's a mixture of `w' and `r' flags. */
- flags = 0;
+ flags &= ~SCM_VTABLE_FLAG_SIMPLE_RW;
break;
default:
}
}
+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':
+ case 's':
+ switch (c_layout[n+1])
+ {
+ case 'W':
+ case 'R':
+ case 'O':
+ if (n + 2 != len)
+ return 0;
+ case 'w':
+ case 'h':
+ case 'r':
+ case 'o':
+ 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 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",
+ 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_layout_flags (obj);
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_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);
}
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_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
"Return @code{#t} iff @var{x} is a vtable structure.")
#define FUNC_NAME s_scm_struct_vtable_p
{
- return scm_from_bool
- (SCM_STRUCTP (x)
- && SCM_STRUCT_VTABLE_FLAG_IS_SET (x, SCM_VTABLE_FLAG_VTABLE));
+ 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
SCM
scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words)
{
- scm_t_bits ret;
- ret = (scm_t_bits)scm_gc_malloc (sizeof (scm_t_bits) * (n_words + 2), "struct");
- 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));
+ 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));
/* vtable_data can be null when making a vtable vtable */
if (vtable_data && vtable_data[scm_vtable_index_instance_finalize])
/* Register a finalizer for the newly created instance. */
GC_finalization_proc prev_finalizer;
GC_PTR prev_finalizer_data;
- GC_REGISTER_FINALIZER_NO_ORDER ((void*)ret,
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
struct_finalizer_trampoline,
NULL,
&prev_finalizer,
&prev_finalizer_data);
}
- return SCM_PACK (ret);
+ return ret;
}
\f
scm_struct_init (obj, layout, n_tail, n_init, init);
- /* only check things and inherit magic if the layout was passed as an initarg.
- something of a hack, but it's for back-compatibility. */
+ /* 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);
fields = scm_string_append (scm_list_2 (required_vtable_fields,
user_fields));
layout = scm_make_struct_layout (fields);
+ if (!scm_is_valid_vtable_layout (layout))
+ SCM_MISC_ERROR ("invalid user fields", scm_list_1 (user_fields));
+
basic_size = scm_i_symbol_length (layout) / 2;
n_tail = scm_to_size_t (tail_array_size);
SCM_CRITICAL_SECTION_END;
scm_struct_init (obj, layout, n_tail, n_init, v);
- SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);
+ SCM_SET_VTABLE_FLAGS (obj,
+ SCM_VTABLE_FLAG_VTABLE | SCM_VTABLE_FLAG_VALIDATED);
return obj;
}
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]);
- }
+ /* The fast path: HANDLE is a struct with only "p" fields. */
+ answer = SCM_PACK (data[p]);
else
{
SCM layout;
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 "p" fields. */
+ /* The fast path: HANDLE is a struct with only "pw" fields. */
data[p] = SCM_UNPACK (val);
else
{
HCoop / bpt / guile.git / blobdiff