+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_false (scm_symbol_p (SCM_VTABLE_LAYOUT (obj))))
+ scm_misc_error (FUNC_NAME, "invalid layout for new vtable",
+ scm_list_1 (SCM_VTABLE_LAYOUT (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 (FUNC_NAME, "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 (FUNC_NAME, "invalid applicable struct layout",
+ scm_list_1 (olayout));
+ SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE);
+ }
+}
+#undef FUNC_NAME