}
}
case scm_tcs_struct:
- if (!(SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC))
+ if (!SCM_STRUCT_APPLICABLE_P (proc))
+ break;
+ proc = SCM_STRUCT_PROCEDURE (proc);
+ if (SCM_IMP (proc))
break;
goto procprop;
case scm_tc7_smob:
: scm_i_eval_x (SCM_CAR (x), (env)))
+/* From structs.h:
+ Deprecated in Guile 1.9.5 on 2009-11-03. */
+#define scm_vtable_index_vtable scm_vtable_index_self
+#define scm_vtable_index_printer scm_vtable_index_instance_printer
+#define scm_struct_i_free scm_vtable_index_instance_finalize
+#define scm_struct_i_flags scm_vtable_index_flags
+#define SCM_STRUCTF_MASK ((scm_t_bits)-1)
+#define SCM_SET_VTABLE_DESTRUCTOR(X, D) (SCM_STRUCT_DATA(x)[scm_struct_i_free]=(scm_t_bits)(D))
+
#define scm_substring_move_left_x scm_substring_move_x
#define scm_substring_move_right_x scm_substring_move_x
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
trampoline = scm_call_generic_0;
+ else if (SCM_STRUCT_APPLICABLE_P (proc))
+ trampoline = scm_call_0;
else
return NULL;
break;
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
trampoline = scm_call_generic_1;
+ else if (SCM_STRUCT_APPLICABLE_P (proc))
+ trampoline = scm_call_1;
else
return NULL;
break;
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
trampoline = scm_call_generic_2;
+ else if (SCM_STRUCT_APPLICABLE_P (proc))
+ trampoline = scm_call_2;
else
return NULL;
break;
arg1 = SCM_EOL;
goto type_dispatch;
}
-#if 0
- else if (SCM_I_ENTITYP (proc))
+ else if (SCM_STRUCT_APPLICABLE_P (proc))
{
arg1 = proc;
- proc = SCM_ENTITY_PROCEDURE (proc);
+ proc = SCM_STRUCT_PROCEDURE (proc);
#ifdef DEVAL
debug.info->a.proc = proc;
debug.info->a.args = scm_list_1 (arg1);
#endif
goto evap1;
}
-#endif
else
goto badfun;
case scm_tc7_subr_1:
#endif
goto type_dispatch;
}
-#if 0
- else if (SCM_I_ENTITYP (proc))
+ else if (SCM_STRUCT_APPLICABLE_P (proc))
{
arg2 = arg1;
arg1 = proc;
- proc = SCM_ENTITY_PROCEDURE (proc);
+ proc = SCM_STRUCT_PROCEDURE (proc);
#ifdef DEVAL
debug.info->a.args = scm_cons (arg1, debug.info->a.args);
debug.info->a.proc = proc;
#endif
goto evap2;
}
-#endif
else
goto badfun;
case scm_tc7_subr_2:
#endif
goto type_dispatch;
}
-#if 0
- else if (SCM_I_ENTITYP (proc))
+ else if (SCM_STRUCT_APPLICABLE_P (proc))
{
operatorn:
#ifdef DEVAL
- RETURN (SCM_APPLY (SCM_ENTITY_PROCEDURE (proc),
+ RETURN (SCM_APPLY (SCM_STRUCT_PROCEDURE (proc),
scm_cons (proc, debug.info->a.args),
SCM_EOL));
#else
- RETURN (SCM_APPLY (SCM_ENTITY_PROCEDURE (proc),
+ RETURN (SCM_APPLY (SCM_STRUCT_PROCEDURE (proc),
scm_cons2 (proc, arg1,
scm_cons (arg2,
scm_ceval_args (x,
SCM_EOL));
#endif
}
-#endif
else
goto badfun;
case scm_tc7_subr_0:
x = SCM_GENERIC_METHOD_CACHE (proc);
goto type_dispatch;
}
-#if 0
- else if (SCM_I_ENTITYP (proc))
+ else if (SCM_STRUCT_APPLICABLE_P (proc))
goto operatorn;
-#endif
else
goto badfun;
case scm_tc7_subr_2:
#endif
RETURN (scm_apply_generic (proc, args));
}
-#if 0
- else if (SCM_I_ENTITYP (proc))
+ else if (SCM_STRUCT_APPLICABLE_P (proc))
{
/* operator */
#ifdef DEVAL
args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
#endif
arg1 = proc;
- proc = SCM_ENTITY_PROCEDURE (proc);
+ proc = SCM_STRUCT_PROCEDURE (proc);
#ifdef DEVAL
debug.vect[0].a.proc = proc;
debug.vect[0].a.args = scm_cons (arg1, args);
else
goto badproc;
}
-#endif
else
goto badproc;
default:
SCM scm_class_foreign_class, scm_class_foreign_object;
SCM scm_class_foreign_slot;
SCM scm_class_self, scm_class_protected;
-SCM scm_class_opaque, scm_class_read_only;
-SCM scm_class_protected_opaque, scm_class_protected_read_only;
+SCM scm_class_hidden, scm_class_opaque, scm_class_read_only;
+SCM scm_class_protected_hidden, scm_class_protected_opaque, scm_class_protected_read_only;
SCM scm_class_scm;
SCM scm_class_int, scm_class_float, scm_class_double;
if (!scm_is_symbol (name))
name = scm_string_to_symbol (scm_nullstr);
- /* FIXME APPLICABLE structs */
class =
- scm_make_extended_class_from_symbol (name, 0);
+ scm_make_extended_class_from_symbol (name,
+ SCM_STRUCT_APPLICABLE_P (x));
SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
return class;
}
a = 'o';
else if (SCM_SUBCLASSP (type, scm_class_read_only))
a = 'r';
+ else if (SCM_SUBCLASSP (type, scm_class_hidden))
+ a = 'h';
else
a = 'w';
}
inconsistent:
SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL);
}
- SCM_SET_SLOT (class, scm_si_layout, scm_string_to_symbol (layout));
+ SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
flags |= SCM_CLASS_FLAGS (SCM_CAR (ls));
ls = SCM_CDR (ls);
}
- flags &= SCM_CLASSF_INHERIT;
- if (! (flags & SCM_CLASSF_PURE_GENERIC))
- {
- long n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
-#if 0
- /*
- * We could avoid calling scm_gc_malloc in the allocation code
- * (in which case the following two lines are needed). Instead
- * we make 0-slot instances non-light, so that the light case
- * can be handled without special cases.
- */
- if (n == 0)
- SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0);
-#endif
- if (n > 0 && !(flags & SCM_CLASSF_METACLASS))
- {
- flags |= SCM_STRUCTF_LIGHT; /* use light representation */
- }
- }
- SCM_SET_CLASS_FLAGS (class, flags);
+ SCM_SET_CLASS_FLAGS (class, flags &~SCM_CLASSF_PURE_GENERIC);
prep_hashsets (class);
nfields = scm_from_int (scm_ilength (slots));
g_n_s = compute_getters_n_setters (slots);
- SCM_SET_SLOT (z, scm_si_name, name);
+ SCM_SET_SLOT (z, scm_vtable_index_name, name);
SCM_SET_SLOT (z, scm_si_direct_slots, dslots);
SCM_SET_SLOT (z, scm_si_direct_subclasses, SCM_EOL);
SCM_SET_SLOT (z, scm_si_direct_methods, SCM_EOL);
/******************************************************************************/
SCM_SYMBOL (sym_layout, "layout");
-SCM_SYMBOL (sym_vcell, "vcell");
-SCM_SYMBOL (sym_vtable, "vtable");
+SCM_SYMBOL (sym_flags, "flags");
+SCM_SYMBOL (sym_self, "%self");
+SCM_SYMBOL (sym_instance_finalizer, "instance-finalizer");
+SCM_SYMBOL (sym_reserved_0, "%reserved-0");
+SCM_SYMBOL (sym_reserved_1, "%reserved-1");
SCM_SYMBOL (sym_print, "print");
SCM_SYMBOL (sym_procedure, "procedure");
SCM_SYMBOL (sym_setter, "setter");
static SCM
build_class_class_slots ()
{
+ /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
+ SCM_CLASS_CLASS_LAYOUT */
return scm_list_n (
scm_list_3 (sym_layout, k_class, scm_class_protected_read_only),
- scm_list_3 (sym_vtable, k_class, scm_class_self),
+ scm_list_3 (sym_flags, k_class, scm_class_hidden),
+ scm_list_3 (sym_self, k_class, scm_class_self),
+ scm_list_3 (sym_instance_finalizer, k_class, scm_class_hidden),
scm_list_1 (sym_print),
- scm_list_3 (sym_procedure, k_class, scm_class_protected_opaque),
- scm_list_3 (sym_setter, k_class, scm_class_protected_opaque),
+ scm_list_3 (sym_name, k_class, scm_class_protected_hidden),
+ scm_list_3 (sym_reserved_0, k_class, scm_class_hidden),
+ scm_list_3 (sym_reserved_1, k_class, scm_class_hidden),
scm_list_1 (sym_redefined),
scm_list_3 (sym_h0, k_class, scm_class_int),
scm_list_3 (sym_h1, k_class, scm_class_int),
scm_list_3 (sym_h5, k_class, scm_class_int),
scm_list_3 (sym_h6, k_class, scm_class_int),
scm_list_3 (sym_h7, k_class, scm_class_int),
- scm_list_1 (sym_name),
scm_list_1 (sym_direct_supers),
scm_list_1 (sym_direct_slots),
scm_list_1 (sym_direct_subclasses),
{
/* SCM slots_of_class = build_class_class_slots (); */
- /**** <scm_class_class> ****/
- SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
- + 2 * scm_vtable_offset_user);
+ /**** <class> ****/
+ SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT);
SCM name = scm_from_locale_symbol ("<class>");
scm_class_class = scm_permanent_object (scm_make_vtable_vtable (cs,
SCM_INUM0,
SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_METACLASS));
- SCM_SET_SLOT (scm_class_class, scm_si_name, name);
+ SCM_SET_SLOT (scm_class_class, scm_vtable_index_name, name);
SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_EOL); /* will be changed */
/* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL);
static void clear_method_cache (SCM);
-static SCM
-wrap_init (SCM class, SCM *m, long n)
+static void
+goops_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data)
{
- long i;
- scm_t_bits slayout = SCM_STRUCT_DATA (class)[scm_vtable_index_layout];
- SCM layout = SCM_PACK (slayout);
-
- /* Set all SCM-holding slots to unbound */
- for (i = 0; i < n; i++)
- if (scm_i_symbol_ref (layout, i*2) == 'p')
- m[i] = SCM_GOOPS_UNBOUND;
- else
- m[i] = 0;
+ SCM obj = PTR2SCM (ptr);
+ scm_t_struct_finalize finalize = SCM_STRUCT_FINALIZER (obj);
- return scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (class))
- | scm_tc3_struct),
- (scm_t_bits) m, 0, 0);
+ if (finalize)
+ finalize (obj);
}
-
SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
(SCM class, SCM initargs),
"Create a new instance of class @var{class} and initialize it\n"
"from the arguments @var{initargs}.")
#define FUNC_NAME s_scm_sys_allocate_instance
{
- SCM *m;
+ SCM obj;
long n;
+ long i;
+ SCM layout;
SCM_VALIDATE_CLASS (1, class);
- /* Most instances */
- if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT)
- {
- n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
- m = (SCM *) scm_gc_malloc (n * sizeof (SCM), "struct");
- return wrap_init (class, m, n);
- }
-
- /* Foreign objects */
- if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN)
- return scm_make_foreign_object (class, initargs);
+ /* FIXME: duplicates some of scm_make_struct. */
n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
+ obj = scm_alloc_struct (SCM_STRUCT_DATA (class), n, "struct");
- /* FIXME applicable structs */
- /* Generic functions */
- if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
- {
- SCM gf;
- m = (SCM *) scm_alloc_struct (n, scm_struct_entity_n_extra_words,
- "generic function");
- m[scm_struct_i_setter] = SCM_BOOL_F;
- m[scm_struct_i_procedure] = SCM_BOOL_F;
- gf = wrap_init (class, m, n);
- clear_method_cache (gf);
- return gf;
+ layout = SCM_VTABLE_LAYOUT (class);
+
+ /* Set all SCM-holding slots to unbound */
+ for (i = 0; i < n; i++)
+ { scm_t_wchar c = scm_i_symbol_ref (layout, i*2);
+ if (c == 'p')
+ SCM_STRUCT_DATA (obj)[i] = SCM_UNPACK (SCM_GOOPS_UNBOUND);
+ else if (c == 's')
+ SCM_STRUCT_DATA (obj)[i] = SCM_UNPACK (obj);
+ else
+ SCM_STRUCT_DATA (obj)[i] = 0;
}
- /* Class objects */
- if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)
+ if (SCM_VTABLE_INSTANCE_FINALIZER (class))
{
- long i;
-
- /* allocate class object */
- SCM z = scm_make_struct (class, SCM_INUM0, SCM_EOL);
-
- SCM_SET_SLOT (z, scm_si_print, SCM_GOOPS_UNBOUND);
- for (i = scm_si_goops_fields; i < n; i++)
- SCM_SET_SLOT (z, i, SCM_GOOPS_UNBOUND);
+ /* Register a finalizer for the newly created instance. */
+ GC_finalization_proc prev_finalizer;
+ GC_PTR prev_finalizer_data;
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (obj),
+ goops_finalizer_trampoline,
+ NULL,
+ &prev_finalizer,
+ &prev_finalizer_data);
+ }
- /* FIXME propagate applicable struct flag */
+ if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
+ clear_method_cache (obj);
- return z;
- }
+ /* Class objects */
+ /* if ((SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)
+ && (SCM_SUBCLASSP (class, scm_class_entity_class)))
+ SCM_SET_CLASS_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE); */
- /* Non-light instances */
- {
- m = (SCM *) scm_alloc_struct (n, scm_struct_n_extra_words, "heavy struct");
- return wrap_init (class, m, n);
- }
+ return obj;
}
#undef FUNC_NAME
word1 = SCM_CELL_WORD_1 (old);
SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new));
- SCM_STRUCT_DATA (old)[scm_vtable_index_vtable] = SCM_UNPACK (old);
+ SCM_STRUCT_DATA (old)[scm_vtable_index_self] = SCM_UNPACK (old);
SCM_SET_CELL_WORD_0 (new, word0);
SCM_SET_CELL_WORD_1 (new, word1);
- SCM_STRUCT_DATA (new)[scm_vtable_index_vtable] = SCM_UNPACK (new);
+ SCM_STRUCT_DATA (new)[scm_vtable_index_self] = SCM_UNPACK (new);
}
SCM_CRITICAL_SECTION_END;
return SCM_UNSPECIFIED;
else
{
/* In all the others case, make a new class .... No instance here */
- SCM_SET_SLOT (z, scm_si_name,
+ SCM_SET_SLOT (z, scm_vtable_index_name,
scm_i_get_keyword (k_name,
args,
len - 1,
SCM_EOL,
mutex_slot),
SCM_EOL);
- SCM gf_slots = scm_list_5 (scm_from_locale_symbol ("methods"),
+ SCM gf_slots = scm_list_n (scm_from_locale_symbol ("methods"),
scm_list_3 (scm_from_locale_symbol ("n-specialized"),
k_init_value,
SCM_INUM0),
mutex_closure),
scm_list_3 (scm_from_locale_symbol ("extended-by"),
k_init_value,
- SCM_EOL));
+ SCM_EOL),
+ scm_from_locale_symbol ("%cache"),
+ SCM_UNDEFINED);
+ SCM setter_slots = scm_list_1 (scm_from_locale_symbol ("%setter-cache"));
SCM egf_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
k_init_value,
SCM_EOL));
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_protected, "<protected-slot>",
scm_class_class, scm_class_foreign_slot, SCM_EOL);
+ make_stdcls (&scm_class_hidden, "<hidden-slot>",
+ scm_class_class, scm_class_foreign_slot, SCM_EOL);
make_stdcls (&scm_class_opaque, "<opaque-slot>",
scm_class_class, scm_class_foreign_slot, SCM_EOL);
make_stdcls (&scm_class_read_only, "<read-only-slot>",
scm_class_class, scm_class_foreign_slot, SCM_EOL);
make_stdcls (&scm_class_self, "<self-slot>",
- scm_class_class,
- scm_class_read_only,
- SCM_EOL);
+ scm_class_class, scm_class_read_only, SCM_EOL);
make_stdcls (&scm_class_protected_opaque, "<protected-opaque-slot>",
scm_class_class,
scm_list_2 (scm_class_protected, scm_class_opaque),
SCM_EOL);
+ make_stdcls (&scm_class_protected_hidden, "<protected-hidden-slot>",
+ scm_class_class,
+ scm_list_2 (scm_class_protected, scm_class_hidden),
+ SCM_EOL);
make_stdcls (&scm_class_protected_read_only, "<protected-read-only-slot>",
scm_class_class,
scm_list_2 (scm_class_protected, scm_class_read_only),
scm_class_entity_class,
scm_list_2 (scm_class_object, scm_class_applicable),
SCM_EOL);
- SCM_CLEAR_CLASS_FLAGS (scm_class_entity, SCM_STRUCTF_LIGHT);
make_stdcls (&scm_class_entity_with_setter, "<entity-with-setter>",
scm_class_entity_class, scm_class_entity, SCM_EOL);
- SCM_CLEAR_CLASS_FLAGS (scm_class_entity_with_setter, SCM_STRUCTF_LIGHT);
make_stdcls (&scm_class_generic, "<generic>",
scm_class_entity_class, scm_class_entity, gf_slots);
- SCM_CLEAR_CLASS_FLAGS (scm_class_generic, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_generic, "<extended-generic>",
scm_class_entity_class, scm_class_generic, egf_slots);
- SCM_CLEAR_CLASS_FLAGS (scm_class_extended_generic, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_extended_generic, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_generic_with_setter, "<generic-with-setter>",
scm_class_entity_class,
scm_list_2 (scm_class_generic, scm_class_entity_with_setter),
- SCM_EOL);
- SCM_CLEAR_CLASS_FLAGS (scm_class_generic_with_setter, SCM_STRUCTF_LIGHT);
+ setter_slots);
SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_accessor, "<accessor>",
scm_class_entity_class, scm_class_generic_with_setter, SCM_EOL);
- SCM_CLEAR_CLASS_FLAGS (scm_class_accessor, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_generic_with_setter,
"<extended-generic-with-setter>",
scm_list_2 (scm_class_generic_with_setter,
scm_class_extended_generic),
SCM_EOL);
- SCM_CLEAR_CLASS_FLAGS (scm_class_extended_generic_with_setter, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_accessor, "<extended-accessor>",
SCM_EOL);
fix_cpl (scm_class_extended_accessor,
scm_class_extended_generic, scm_class_generic);
- SCM_CLEAR_CLASS_FLAGS (scm_class_extended_accessor, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
/* Primitive types classes */
SCM sym = SCM_STRUCT_TABLE_NAME (data);
if (scm_is_true (sym))
{
- int applicablep = 0; /* FIXME SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_ENTITY */
+ int applicablep = SCM_CLASS_FLAGS (vtable) & SCM_VTABLE_FLAG_APPLICABLE;
SCM_SET_STRUCT_TABLE_CLASS (data,
scm_make_extended_class_from_symbol (sym, applicablep));
}
-SCM
-scm_make_foreign_object (SCM class, SCM initargs)
-#define FUNC_NAME s_scm_make
-{
- void * (*constructor) (SCM)
- = (void * (*) (SCM)) SCM_SLOT (class, scm_si_constructor);
- if (constructor == 0)
- SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
- return scm_wrap_object (class, constructor (initargs));
-}
-#undef FUNC_NAME
-
-
-static size_t
-scm_free_foreign_object (SCM *class, SCM *data)
-{
- size_t (*destructor) (void *)
- = (size_t (*) (void *)) class[scm_si_destructor];
- return destructor (data);
-}
-
-SCM
-scm_make_class (SCM meta, char *s_name, SCM supers, size_t size,
- void * (*constructor) (SCM initargs),
- size_t (*destructor) (void *))
-{
- SCM name, class;
- name = scm_from_locale_symbol (s_name);
- if (scm_is_null (supers))
- supers = scm_list_1 (scm_class_foreign_object);
- class = scm_basic_basic_make_class (meta, name, supers, SCM_EOL);
- scm_sys_inherit_magic_x (class, supers);
-
- if (destructor != 0)
- {
- SCM_SET_SLOT (class, scm_si_destructor, (SCM) destructor);
- SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object);
- }
-
- SCM_SET_SLOT (class, scm_si_layout, scm_from_locale_symbol (""));
- SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor);
-
- return class;
-}
-
SCM_SYMBOL (sym_o, "o");
SCM_SYMBOL (sym_x, "x");
SCM_KEYWORD (k_accessor, "accessor");
SCM_KEYWORD (k_getter, "getter");
-static SCM
-default_setter (SCM obj SCM_UNUSED, SCM c SCM_UNUSED)
-{
- scm_misc_error ("slot-set!", "read-only slot", SCM_EOL);
- return 0;
-}
-
-void
-scm_add_slot (SCM class, char *slot_name, SCM slot_class,
- SCM (*getter) (SCM obj),
- SCM (*setter) (SCM obj, SCM x),
- char *accessor_name)
-{
- {
- SCM get = scm_c_make_subr ("goops:get", scm_tc7_subr_1, getter);
- SCM set = scm_c_make_subr ("goops:set", scm_tc7_subr_2,
- setter ? setter : default_setter);
-
- /* Dirk:FIXME:: The following two expressions make use of the fact that
- * the memoizer will accept a subr-object in the place of a function.
- * This is not guaranteed to stay this way. */
- SCM getm = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
- scm_list_1 (sym_o),
- scm_list_2 (get, sym_o)),
- SCM_EOL);
- SCM setm = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
- scm_list_2 (sym_o, sym_x),
- scm_list_3 (set, sym_o, sym_x)),
- SCM_EOL);
-
- {
- SCM name = scm_from_locale_symbol (slot_name);
- SCM aname = scm_from_locale_symbol (accessor_name);
- SCM gf = scm_ensure_accessor (aname);
- SCM slot = scm_list_5 (name,
- k_class,
- slot_class,
- setter ? k_accessor : k_getter,
- gf);
- scm_add_method (gf, scm_make (scm_list_5 (scm_class_accessor_method,
- k_specializers,
- scm_list_1 (class),
- k_procedure,
- getm)));
- scm_add_method (scm_setter (gf),
- scm_make (scm_list_5 (scm_class_accessor_method,
- k_specializers,
- scm_list_2 (class, scm_class_top),
- k_procedure,
- setm)));
- DEFVAR (aname, gf);
-
- SCM_SET_SLOT (class, scm_si_slots,
- scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots),
- scm_list_1 (slot))));
- {
- SCM n = SCM_SLOT (class, scm_si_nfields);
- SCM gns = scm_list_n (name, SCM_BOOL_F, get, set, n, scm_from_int (1),
- SCM_UNDEFINED);
- SCM_SET_SLOT (class, scm_si_getters_n_setters,
- scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters),
- scm_list_1 (gns))));
- SCM_SET_SLOT (class, scm_si_nfields, scm_sum (n, scm_from_int (1)));
- }
- }
- }
-}
-
-SCM
-scm_wrap_object (SCM class, void *data)
-{
- return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct,
- (scm_t_bits) data,
- 0, 0);
-}
-
-SCM scm_components;
-
-SCM
-scm_wrap_component (SCM class, SCM container, void *data)
-{
- SCM obj = scm_wrap_object (class, data);
- SCM handle = scm_hash_fn_create_handle_x (scm_components,
- obj,
- SCM_BOOL_F,
- scm_struct_ihashq,
- (scm_t_assoc_fn) scm_sloppy_assq,
- 0);
- SCM_SETCDR (handle, container);
- return obj;
-}
-
SCM
scm_ensure_accessor (SCM name)
{
*/
scm_permanent_object (scm_module_goops);
- scm_components = scm_permanent_object (scm_make_weak_key_hash_table
- (scm_from_int (37)));
-
goops_rstate = scm_c_make_rstate ("GOOPS", 5);
#include "libguile/goops.x"
#include "libguile/validate.h"
+/* {Class flags}
+ *
+ * These are used for efficient identification of instances of a
+ * certain class or its subclasses when traversal of the inheritance
+ * graph would be too costly.
+ */
+#define SCM_VTABLE_FLAG_GOOPS_CLASS SCM_VTABLE_FLAG_GOOPS_0
+#define SCM_VTABLE_FLAG_GOOPS_VALID SCM_VTABLE_FLAG_GOOPS_1
+#define SCM_VTABLE_FLAG_GOOPS_METACLASS SCM_VTABLE_FLAG_GOOPS_2
+#define SCM_VTABLE_FLAG_GOOPS_FOREIGN SCM_VTABLE_FLAG_GOOPS_3
+#define SCM_VTABLE_FLAG_GOOPS_PURE_GENERIC SCM_VTABLE_FLAG_GOOPS_4
+#define SCM_VTABLE_FLAG_GOOPS_SIMPLE_METHOD SCM_VTABLE_FLAG_GOOPS_5
+#define SCM_VTABLE_FLAG_GOOPS_ACCESSOR_METHOD SCM_VTABLE_FLAG_GOOPS_6
+
+#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
+#define SCM_CLASS_FLAGS(class) (SCM_VTABLE_FLAGS (class))
+#define SCM_OBJ_CLASS_FLAGS(obj) (SCM_STRUCT_VTABLE_FLAGS (obj))
+#define SCM_SET_CLASS_FLAGS(c, f) (SCM_SET_VTABLE_FLAGS (c, f))
+#define SCM_CLEAR_CLASS_FLAGS(c, f) (SCM_CLEAR_VTABLE_FLAGS (c, f))
+
+#define SCM_CLASSF_FOREIGN SCM_VTABLE_FLAG_GOOPS_FOREIGN
+#define SCM_CLASSF_METACLASS SCM_VTABLE_FLAG_GOOPS_METACLASS
+#define SCM_CLASSF_PURE_GENERIC SCM_VTABLE_FLAG_GOOPS_PURE_GENERIC
+#define SCM_CLASSF_GOOPS_VALID SCM_VTABLE_FLAG_GOOPS_VALID
+#define SCM_CLASSF_GOOPS SCM_VTABLE_FLAG_GOOPS_CLASS
+#define SCM_CLASSF_SIMPLE_METHOD SCM_VTABLE_FLAG_GOOPS_SIMPLE_METHOD
+#define SCM_CLASSF_ACCESSOR_METHOD SCM_VTABLE_FLAG_GOOPS_ACCESSOR_METHOD
+#define SCM_CLASSF_GOOPS_OR_VALID (SCM_CLASSF_GOOPS | SCM_CLASSF_GOOPS_VALID)
+
/*
* scm_class_class
*/
-#define SCM_CLASS_CLASS_LAYOUT "prsrpwpopopwururururururururpwpwpwpwpwpwpwpwpwpwpwpw"
-
-#define scm_si_layout 0 /* the struct layout */
-#define scm_si_vtable 1
-#define scm_si_print 2 /* the struct print closure */
-#define scm_si_proc 3
-#define scm_si_setter 4
-
-#define scm_si_goops_fields 5
-#define scm_si_redefined 5 /* The class to which class was redefined. */
-#define scm_si_hashsets 6
-
-#define scm_si_name 14 /* a symbol */
-#define scm_si_direct_supers 15 /* (class ...) */
-#define scm_si_direct_slots 16 /* ((name . options) ...) */
-#define scm_si_direct_subclasses 17 /* (class ...) */
-#define scm_si_direct_methods 18 /* (methods ...) */
-#define scm_si_cpl 19 /* (class ...) */
-#define scm_si_slotdef_class 20
-#define scm_si_slots 21 /* ((name . options) ...) */
-#define scm_si_name_access 22
+/* see also, SCM_VTABLE_BASE_LAYOUT, and build_class_class_slots */
+#define SCM_CLASS_CLASS_LAYOUT \
+ "pw" /* redefined */ \
+ "ur" /* h0 */ \
+ "ur" /* h1 */ \
+ "ur" /* h2 */ \
+ "ur" /* h3 */ \
+ "ur" /* h4 */ \
+ "ur" /* h5 */ \
+ "ur" /* h6 */ \
+ "ur" /* h7 */ \
+ "pw" /* direct supers */ \
+ "pw" /* direct slots */ \
+ "pw" /* direct subclasses */ \
+ "pw" /* direct methods */ \
+ "pw" /* cpl */ \
+ "pw" /* default-slot-definition-class */ \
+ "pw" /* slots */ \
+ "pw" /* getters-n-setters */ \
+ "pw" /* keyword access */ \
+ "pw" /* nfields */ \
+ "pw" /* environment */
+
+#define scm_si_redefined (scm_vtable_offset_user + 0)
+#define scm_si_h0 (scm_vtable_offset_user + 1)
+#define scm_si_hashsets scm_si_h0
+#define scm_si_h1 (scm_vtable_offset_user + 2)
+#define scm_si_h2 (scm_vtable_offset_user + 3)
+#define scm_si_h3 (scm_vtable_offset_user + 4)
+#define scm_si_h4 (scm_vtable_offset_user + 5)
+#define scm_si_h5 (scm_vtable_offset_user + 6)
+#define scm_si_h6 (scm_vtable_offset_user + 7)
+#define scm_si_h7 (scm_vtable_offset_user + 8)
+#define scm_si_direct_supers (scm_vtable_offset_user + 9) /* (class ...) */
+#define scm_si_direct_slots (scm_vtable_offset_user + 10) /* ((name . options) ...) */
+#define scm_si_direct_subclasses (scm_vtable_offset_user + 11) /* (class ...) */
+#define scm_si_direct_methods (scm_vtable_offset_user + 12) /* (methods ...) */
+#define scm_si_cpl (scm_vtable_offset_user + 13) /* (class ...) */
+#define scm_si_slotdef_class (scm_vtable_offset_user + 14)
+#define scm_si_slots (scm_vtable_offset_user + 15) /* ((name . options) ...) */
+#define scm_si_name_access (scm_vtable_offset_user + 16)
#define scm_si_getters_n_setters scm_si_name_access
-#define scm_si_keyword_access 23
-#define scm_si_nfields 24 /* an integer */
-#define scm_si_environment 25 /* The environment in which class is built */
-#define SCM_N_CLASS_SLOTS 26
+#define scm_si_keyword_access (scm_vtable_offset_user + 17)
+#define scm_si_nfields (scm_vtable_offset_user + 18) /* an integer */
+#define scm_si_environment (scm_vtable_offset_user + 19) /* The environment in which class is built */
+#define SCM_N_CLASS_SLOTS (scm_vtable_offset_user + 20)
typedef struct scm_t_method {
SCM generic_function;
#define SCM_METHOD(obj) ((scm_t_method *) SCM_STRUCT_DATA (obj))
-/* {Class flags}
- *
- * These are used for efficient identification of instances of a
- * certain class or its subclasses when traversal of the inheritance
- * graph would be too costly.
- */
-#define SCM_CLASS_FLAGS(class) (SCM_STRUCT_DATA (class) [scm_struct_i_flags])
-#define SCM_OBJ_CLASS_FLAGS(obj) (SCM_STRUCT_VTABLE_DATA (obj) [scm_struct_i_flags])
-#define SCM_SET_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) |= (f))
-#define SCM_CLEAR_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) &= ~(f))
-#define SCM_CLASSF_MASK SCM_STRUCTF_MASK
-
-#define SCM_CLASSF_SIMPLE_METHOD (0x004 << 20)
-#define SCM_CLASSF_ACCESSOR_METHOD (0x008 << 20)
-#define SCM_CLASSF_PURE_GENERIC SCM_STRUCTF_GOOPS_HACK
-#define SCM_CLASSF_FOREIGN (0x020 << 20)
-#define SCM_CLASSF_METACLASS (0x040 << 20)
-#define SCM_CLASSF_GOOPS_VALID (0x080 << 20)
-#define SCM_CLASSF_GOOPS (0x100 << 20)
-#define SCM_CLASSF_GOOPS_OR_VALID (SCM_CLASSF_GOOPS | SCM_CLASSF_GOOPS_VALID)
-
-#define SCM_CLASSF_INHERIT (~(SCM_CLASSF_PURE_GENERIC \
- | SCM_CLASSF_SIMPLE_METHOD \
- | SCM_CLASSF_ACCESSOR_METHOD \
- | SCM_STRUCTF_LIGHT) \
- & SCM_CLASSF_MASK)
-
-#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
#define SCM_OBJ_CLASS_REDEF(x) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (x) [scm_si_redefined]))
#define SCM_INST(x) SCM_STRUCT_DATA (x)
(SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_ACCESSOR_METHOD))
#define SCM_VALIDATE_ACCESSOR(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, ACCESSORP, "accessor")
-#define SCM_SLOT(x, i) (SCM_PACK (SCM_INST (x) [i]))
-#define SCM_SET_SLOT(x, i, v) (SCM_INST (x) [i] = SCM_UNPACK (v))
+#define SCM_SLOT(x, i) (SCM_STRUCT_SLOT_REF (x, i))
+#define SCM_SET_SLOT(x, i, v) (SCM_STRUCT_SLOT_SET (x, i, v))
#define SCM_INSTANCE_HASH(c, i) (SCM_INST (c) [scm_si_hashsets + (i)])
#define SCM_SET_HASHSET(c, i, h) (SCM_INST (c) [scm_si_hashsets + (i)] = (h))
#define SCM_SET_CLASS_DESTRUCTOR(c, d) SCM_SET_VTABLE_DESTRUCTOR (c, d)
-#define SCM_GENERIC_METHOD_CACHE(G) (SCM_PACK (SCM_STRUCT_DATA (G) [scm_struct_i_procedure]))
-#define SCM_SET_GENERIC_METHOD_CACHE(G,C) (SCM_STRUCT_DATA (G) [scm_struct_i_procedure] = SCM_UNPACK (C))
-#define SCM_GENERIC_SETTER(G) (SCM_PACK (SCM_STRUCT_DATA (G) [scm_struct_i_setter]))
-#define SCM_SET_GENERIC_SETTER(G,C) (SCM_STRUCT_DATA (G) [scm_struct_i_setter] = SCM_UNPACK (C))
+#define SCM_GENERIC_METHOD_CACHE(G) (SCM_PACK (SCM_STRUCT_DATA (G) [scm_si_generic_cache]))
+#define SCM_SET_GENERIC_METHOD_CACHE(G,C) (SCM_STRUCT_DATA (G) [scm_si_generic_cache] = SCM_UNPACK (C))
+#define SCM_GENERIC_SETTER(G) (SCM_PACK (SCM_STRUCT_DATA (G) [scm_si_generic_setter_cache]))
+#define SCM_SET_GENERIC_SETTER(G,C) (SCM_STRUCT_DATA (G) [scm_si_generic_setter_cache] = SCM_UNPACK (C))
#define SCM_MCACHE_N_SPECIALIZED(C) SCM_CADDR (C)
#define SCM_SET_MCACHE_N_SPECIALIZED(C, X) SCM_SETCAR (SCM_CDDR (C), X)
#define SCM_INITIAL_MCACHE_SIZE 1
-#define scm_si_constructor SCM_N_CLASS_SLOTS
-#define scm_si_destructor SCM_N_CLASS_SLOTS + 1
-
#define scm_si_methods 0 /* offset of methods slot in a <generic> */
#define scm_si_n_specialized 1
#define scm_si_used_by 2
#define scm_si_cache_mutex 3
+#define scm_si_extended_by 4
+#define scm_si_generic_cache 5
+#define scm_si_generic_setter_cache 6
#define scm_si_generic_function 0 /* offset of gf slot in a <method> */
#define scm_si_specializers 1 /* offset of spec. slot in a <method> */
SCM_API SCM scm_class_foreign_slot;
SCM_API SCM scm_class_self;
SCM_API SCM scm_class_protected;
+SCM_API SCM scm_class_hidden;
SCM_API SCM scm_class_opaque;
SCM_API SCM scm_class_read_only;
+SCM_API SCM scm_class_protected_hidden;
SCM_API SCM scm_class_protected_opaque;
SCM_API SCM scm_class_protected_read_only;
SCM_API SCM scm_class_scm;
SCM_API char *scm_c_oldfmt0 (char *);
SCM_API char *scm_c_oldfmt (char *, int n);
SCM_API void scm_load_goops (void);
-SCM_API SCM scm_make_foreign_object (SCM cls, SCM initargs);
-SCM_API SCM scm_make_class (SCM meta, char *s_name, SCM supers, size_t size,
- void * (*constructor) (SCM initargs),
- size_t (*destructor) (void *));
SCM_API SCM scm_make_extended_class (char const *type_name, int applicablep);
SCM_API void scm_make_port_classes (long ptobnum, char *type_name);
-SCM_API void scm_add_slot (SCM c, char *slot, SCM slot_class,
- SCM (*getter) (SCM obj),
- SCM (*setter) (SCM obj, SCM x),
- char *accessor_name);
-SCM_API SCM scm_wrap_object (SCM c, void *);
-SCM_API SCM scm_wrap_component (SCM c, SCM obj, void *);
SCM_API SCM scm_ensure_accessor (SCM name);
SCM_API void scm_add_method (SCM gf, SCM m);
SCM_API SCM scm_class_of (SCM obj);
SCM_INTERNAL SCM scm_init_goops_builtins (void);
SCM_INTERNAL void scm_init_goops (void);
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-#define SCM_INST_TYPE(x) SCM_OBJ_CLASS_FLAGS (x)
-#define SCM_SIMPLEMETHODP(x) \
- (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_SIMPLE_METHOD))
-#define SCM_FASTMETHODP(x) \
- (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) \
- & (SCM_CLASSF_ACCESSOR_METHOD \
- | SCM_CLASSF_SIMPLE_METHOD)))
-
-
-#endif
-
#endif /* SCM_GOOPS_H */
/*
r = 1;
break;
}
- /* FIXME applicable structs */
- return SCM_BOOL_F;
-#if 0
- proc = SCM_ENTITY_PROCEDURE (proc);
- a -= 1;
+ else if (!SCM_STRUCT_APPLICABLE_P (proc))
+ return SCM_BOOL_F;
+ proc = SCM_STRUCT_PROCEDURE (proc);
goto loop;
-#endif
default:
return SCM_BOOL_F;
}
switch (SCM_TYP7 (obj))
{
case scm_tcs_struct:
- if (!(SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC))
+ if (!((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC)
+ || SCM_STRUCT_APPLICABLE_P (obj)))
break;
case scm_tcs_closures:
case scm_tcs_subrs:
SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0,
(SCM proc),
"Return the procedure of @var{proc}, which must be either a\n"
- "procedure with setter, or an operator struct.")
+ "procedure with setter, or an applicable struct.")
#define FUNC_NAME s_scm_procedure
{
SCM_VALIDATE_NIM (1, proc);
return SCM_PROCEDURE (proc);
else if (SCM_STRUCTP (proc))
{
- SCM_ASSERT (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC,
+ SCM_ASSERT (SCM_PUREGENERICP (proc) || SCM_STRUCT_APPLICABLE_P (proc),
proc, SCM_ARG1, FUNC_NAME);
return proc;
}
return SCM_SETTER (proc);
else if (SCM_STRUCTP (proc))
{
- SCM setter;
- SCM_GASSERT1 (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC,
- g_setter, proc, SCM_ARG1, s_setter);
- setter = SCM_GENERIC_SETTER (proc);
+ SCM setter = SCM_BOOL_F;
+ if (SCM_PUREGENERICP (proc))
+ setter = SCM_GENERIC_SETTER (proc);
+ else if (SCM_STRUCT_SETTER_P (proc))
+ setter = SCM_STRUCT_SETTER (proc);
if (SCM_NIMP (setter))
return setter;
/* fall through */
\f
+/* A needlessly obscure test. */
+#define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */
+
static SCM required_vtable_fields = SCM_BOOL_F;
-SCM scm_struct_table;
+static SCM required_applicable_fields = SCM_BOOL_F;
+static SCM required_applicable_with_setter_fields = SCM_BOOL_F;
+SCM scm_struct_table = SCM_BOOL_F;
\f
SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
"type, the second a field protection. Allowed types are 'p' for\n"
"GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n"
"a field that points to the structure itself. Allowed protections\n"
- "are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque\n"
- "fields. The last field protection specification may be capitalized to\n"
- "indicate that the field is a tail-array.")
+ "are 'w' for mutable fields, 'h' for hidden fields, 'r' for read-only\n"
+ "fields, and 'o' for opaque 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.\n\n"
+ "The last field protection specification may be capitalized to indicate\n"
+ "that the field is a tail-array.")
#define FUNC_NAME s_scm_make_struct_layout
{
SCM new_sym;
switch (c = scm_i_string_ref (fields, x + 1))
{
case 'w':
+ case 'h':
if (scm_i_string_ref (fields, x) == 's')
SCM_MISC_ERROR ("self fields not writable", SCM_EOL);
case 'r':
static void
-scm_struct_init (SCM handle, SCM layout, scm_t_bits * mem, int tail_elts, SCM inits)
+scm_struct_init (SCM handle, SCM layout, int tail_elts, SCM inits)
{
scm_t_wchar prot = 0;
int n_fields = scm_i_symbol_length (layout) / 2;
int tailp = 0;
int i;
+ scm_t_bits *mem = SCM_STRUCT_DATA (handle);
i = -2;
while (n_fields)
"Return @code{#t} iff @var{x} is a vtable structure.")
#define FUNC_NAME s_scm_struct_vtable_p
{
- SCM layout;
- scm_t_bits * mem;
- SCM tmp;
- size_t len;
-
- if (!SCM_STRUCTP (x))
- return SCM_BOOL_F;
-
- layout = SCM_STRUCT_LAYOUT (x);
-
- if (scm_i_symbol_length (layout)
- < scm_i_string_length (required_vtable_fields))
- return SCM_BOOL_F;
-
- len = scm_i_string_length (required_vtable_fields);
- tmp = scm_string_eq (scm_symbol_to_string (layout),
- required_vtable_fields,
- scm_from_size_t (0),
- scm_from_size_t (len),
- scm_from_size_t (0),
- scm_from_size_t (len));
- if (scm_is_false (tmp))
- return SCM_BOOL_F;
-
- mem = SCM_STRUCT_DATA (x);
-
- return scm_from_bool (scm_is_symbol (SCM_PACK (mem[scm_vtable_index_layout])));
+ return scm_from_bool
+ (SCM_STRUCTP (x)
+ && SCM_STRUCT_VTABLE_FLAG_IS_SET (x, SCM_VTABLE_FLAG_VTABLE));
}
#undef FUNC_NAME
address of that data doesn't end in three zeros, tagging it will
destroy the pointer.
- This function allocates a block of memory, and returns a pointer at
- least scm_struct_n_extra_words words into the block. Furthermore,
- it guarantees that that pointer's least three significant bits are
- all zero.
-
- The argument n_words should be the number of words that should
- appear after the returned address. (That is, it shouldn't include
- scm_struct_n_extra_words.)
-
- This function initializes the following fields of the struct:
-
- scm_struct_i_ptr --- the actual start of the block of memory; the
- address you should pass to 'free' to dispose of the block.
- This field allows us to both guarantee that the returned
- address is divisible by eight, and allow the GC to free the
- block.
+ 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.
- scm_struct_i_n_words --- the number of words allocated to the
- block, including the extra fields. This is used by the GC.
-
- Ugh. */
-
-
-scm_t_bits *
-scm_alloc_struct (int n_words, int n_extra, const char *what)
+ 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_alloc_struct (scm_t_bits *vtable_data, int n_words, const char *what)
{
- int size = sizeof (scm_t_bits) * (n_words + n_extra) + 7;
- void * block = scm_gc_malloc (size, what);
-
- /* Adjust the pointer to hide the extra words. */
- scm_t_bits * p = (scm_t_bits *) block + n_extra;
-
- /* Adjust it even further so it's aligned on an eight-byte boundary. */
- p = (scm_t_bits *) (((scm_t_bits) p + 7) & ~7);
-
- /* Initialize a few fields as described above. */
- p[scm_struct_i_free] = (scm_t_bits) 0;
- p[scm_struct_i_ptr] = (scm_t_bits) block;
- p[scm_struct_i_n_words] = n_words;
- p[scm_struct_i_flags] = 0;
-
- /* Since `SCM' objects will record either P or P + SCM_TC3_STRUCT, we need
- to register them as valid displacements. Fortunately, only a handful of
- N_EXTRA values are used in core Guile. */
- GC_REGISTER_DISPLACEMENT ((char *)p - (char *)block);
- GC_REGISTER_DISPLACEMENT ((char *)p - (char *)block + scm_tc3_struct);
-
- return p;
+ scm_t_bits ret;
+ ret = (scm_t_bits)scm_gc_malloc (sizeof (scm_t_bits) * (n_words + 2), "struct");
+ /* Now that all platforms support scm_t_uint64, I would think that malloc on
+ all platforms is required to return 8-byte-aligned blocks. This test will
+ let us find out quickly though ;-) */
+ if (ret & 7)
+ abort ();
+ 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));
+ return SCM_PACK (ret);
}
\f
struct_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data)
{
SCM obj = PTR2SCM (ptr);
+ scm_t_struct_finalize finalize = SCM_STRUCT_FINALIZER (obj);
- /* XXX - use less explicit code. */
- scm_t_bits word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_struct;
- scm_t_bits *vtable_data = (scm_t_bits *) word0;
- scm_t_bits *data = SCM_STRUCT_DATA (obj);
- scm_t_struct_free free_struct_data
- = ((scm_t_struct_free) vtable_data[scm_struct_i_free]);
-
- SCM_SET_CELL_TYPE (obj, scm_tc3_struct);
-
-#if 0
- /* A sanity check. However, this check can fail if the free function
- changed between the `make-struct' time and now. */
- if (free_struct_data != (scm_t_struct_free)unused_data)
- abort ();
-#endif
-
- if (free_struct_data)
- free_struct_data (vtable_data, data);
+ if (finalize)
+ finalize (obj);
}
"successive fields of the structure should be initialized. Only fields\n"
"with protection 'r' or 'w' can be initialized, except for fields of\n"
"type 's', which are automatically initialized to point to the new\n"
- "structure itself; fields with protection 'o' can not be initialized by\n"
+ "structure itself. Fields with protection 'o' can not be initialized by\n"
"Scheme programs.\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.\n\n"
- "Structs are currently the basic representation for record-like data\n"
- "structures in Guile. The plan is to eventually replace them with a\n"
- "new representation which will at the same time be easier to use and\n"
- "more powerful.\n\n"
"For more information, see the documentation for @code{make-vtable-vtable}.")
#define FUNC_NAME s_scm_make_struct
{
SCM layout;
size_t basic_size;
size_t tail_elts;
- scm_t_bits *data, *c_vtable;
- SCM handle;
+ SCM obj;
SCM_VALIDATE_VTABLE (1, vtable);
SCM_VALIDATE_REST_ARGUMENT (init);
- c_vtable = SCM_STRUCT_DATA (vtable);
-
- layout = SCM_PACK (c_vtable [scm_vtable_index_layout]);
+ layout = SCM_VTABLE_LAYOUT (vtable);
basic_size = scm_i_symbol_length (layout) / 2;
tail_elts = scm_to_size_t (tail_array_size);
goto bad_tail;
}
- /* In guile 1.8.5 and earlier, everything below was covered by a
- CRITICAL_SECTION lock. This can lead to deadlocks in garbage
- collection, since other threads might be holding the heap_mutex, while
- sleeping on the CRITICAL_SECTION lock. There does not seem to be any
- need for a lock on the section below, as it does not access or update
- any globals, so the critical section has been removed. */
+ obj = scm_alloc_struct (SCM_STRUCT_DATA (vtable), basic_size + tail_elts,
+ "struct");
- if (c_vtable[scm_struct_i_flags] & SCM_STRUCTF_GOOPS_HACK)
- {
- data = scm_alloc_struct (basic_size + tail_elts,
- scm_struct_entity_n_extra_words,
- "entity struct");
- data[scm_struct_i_procedure] = SCM_UNPACK (SCM_BOOL_F);
- data[scm_struct_i_setter] = SCM_UNPACK (SCM_BOOL_F);
- }
- else
- data = scm_alloc_struct (basic_size + tail_elts,
- scm_struct_n_extra_words,
- "struct");
- handle = scm_double_cell ((((scm_t_bits) c_vtable)
- + scm_tc3_struct),
- (scm_t_bits) data, 0, 0);
-
- if (c_vtable[scm_struct_i_free])
+ if (SCM_VTABLE_INSTANCE_FINALIZER (vtable))
{
/* Register a finalizer for the newly created instance. */
GC_finalization_proc prev_finalizer;
GC_PTR prev_finalizer_data;
- scm_t_struct_free free_struct =
- (scm_t_struct_free)c_vtable[scm_struct_i_free];
-
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (handle),
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (obj),
struct_finalizer_trampoline,
- free_struct,
+ NULL,
&prev_finalizer,
&prev_finalizer_data);
}
- scm_struct_init (handle, layout, data, tail_elts, init);
+ scm_struct_init (obj, layout, tail_elts, init);
+
+ /* 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.
+ */
+ if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE)
+ /* only do these checks if the layout was passed as an initarg.
+ something of a hack, but it's for back-compatibility. */
+ && scm_is_true (SCM_VTABLE_LAYOUT (obj)))
+ {
+ /* scm_struct_init will have initialized our layout */
+ 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 is a metaclass, verify that its vtable is compatible with the
+ required vtable (class) layout */
+ olayout = scm_symbol_to_string (SCM_VTABLE_LAYOUT (obj));
+ if (scm_is_true (scm_string_eq (olayout, required_vtable_fields,
+ scm_from_size_t (0),
+ scm_string_length (olayout),
+ 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);
+ }
+ }
- return handle;
+ return obj;
}
#undef FUNC_NAME
SCM layout;
size_t basic_size;
size_t tail_elts;
- scm_t_bits *data;
- SCM handle;
+ SCM obj;
SCM_VALIDATE_STRING (1, user_fields);
SCM_VALIDATE_REST_ARGUMENT (init);
basic_size = scm_i_symbol_length (layout) / 2;
tail_elts = scm_to_size_t (tail_array_size);
SCM_CRITICAL_SECTION_START;
- data = scm_alloc_struct (basic_size + tail_elts,
- scm_struct_n_extra_words,
- "struct");
- handle = scm_double_cell ((scm_t_bits) data + scm_tc3_struct,
- (scm_t_bits) data, 0, 0);
- data [scm_vtable_index_layout] = SCM_UNPACK (layout);
- scm_struct_init (handle, layout, data, tail_elts, scm_cons (layout, init));
+ obj = scm_alloc_struct (NULL, basic_size + tail_elts, "struct");
+ /* magic magic magic */
+ SCM_SET_CELL_WORD_0 (obj, (scm_t_bits)SCM_STRUCT_DATA (obj) | scm_tc3_struct);
SCM_CRITICAL_SECTION_END;
- return handle;
+ scm_struct_init (obj, layout, tail_elts, scm_cons (layout, init));
+ SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);
+ return obj;
}
#undef FUNC_NAME
SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
(SCM handle, SCM pos),
- "@deffnx {Scheme Procedure} struct-set! struct n value\n"
- "Access (or modify) the @var{n}th field of @var{struct}.\n\n"
+ "Access the @var{n}th field of @var{struct}.\n\n"
"If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
"If the field is of type 'u', then it can only be set to a non-negative\n"
"integer value small enough to fit in one machine word.")
p = scm_to_size_t (pos);
layout_len = scm_i_symbol_length (layout);
- if (SCM_STRUCT_VTABLE_FLAGS (handle) & SCM_STRUCTF_LIGHT)
- /* no extra words */
- n_fields = layout_len / 2;
- else
- n_fields = data[scm_struct_i_n_words];
+ 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(1, pos, p < n_fields);
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'))
+ if ((ref != 'r') && (ref != 'w') && (ref != 'h'))
{
if ((ref == 'R') || (ref == 'W'))
field_type = 'u';
p = scm_to_size_t (pos);
layout_len = scm_i_symbol_length (layout);
- if (SCM_STRUCT_VTABLE_FLAGS (handle) & SCM_STRUCTF_LIGHT)
- /* no extra words */
- n_fields = layout_len / 2;
- else
- n_fields = data[scm_struct_i_n_words];
+ 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 (1, pos, p < n_fields);
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')
+ 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')
SCM name = scm_struct_vtable_name (vtable);
scm_puts ("#<", port);
if (scm_is_true (name))
- scm_display (name, port);
+ {
+ scm_display (name, port);
+ scm_putc (' ', port);
+ }
else
- scm_puts ("struct", port);
- scm_putc (' ', port);
- scm_uintprint (SCM_UNPACK (vtable), 16, port);
- scm_putc (':', port);
+ {
+ 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_struct_table
- = scm_permanent_object (scm_make_weak_key_hash_table (scm_from_int (31)));
- required_vtable_fields = scm_from_locale_string ("prsrpw");
- scm_permanent_object (required_vtable_fields);
+ SCM scm_applicable_struct_vtable_vtable;
+ SCM scm_applicable_struct_with_setter_vtable_vtable;
+
+ GC_REGISTER_DISPLACEMENT (2*sizeof(scm_t_bits)); /* for the self data pointer */
+ GC_REGISTER_DISPLACEMENT (2*sizeof(scm_t_bits)
+ + scm_tc3_struct); /* for the vtable data pointer */
+
+ scm_struct_table = scm_make_weak_key_hash_table (scm_from_int (31));
+ required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT);
+ required_applicable_fields = scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT);
+ required_applicable_with_setter_fields = scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT);
scm_i_vtable_vtable_no_extra_fields =
- scm_permanent_object
- (scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL));
+ scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
+
+ scm_applicable_struct_vtable_vtable =
+ scm_make_struct (scm_i_vtable_vtable_no_extra_fields, SCM_INUM0,
+ scm_list_1 (scm_make_struct_layout (required_vtable_fields)));
+ SCM_SET_VTABLE_FLAGS (scm_applicable_struct_vtable_vtable,
+ SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
+ scm_c_define ("<applicable-struct-vtable>", scm_applicable_struct_vtable_vtable);
+
+ scm_applicable_struct_with_setter_vtable_vtable =
+ scm_make_struct (scm_i_vtable_vtable_no_extra_fields, SCM_INUM0,
+ scm_list_1 (scm_make_struct_layout (required_vtable_fields)));
+ SCM_SET_VTABLE_FLAGS (scm_applicable_struct_with_setter_vtable_vtable,
+ SCM_VTABLE_FLAG_APPLICABLE_VTABLE | SCM_VTABLE_FLAG_SETTER_VTABLE);
+ scm_c_define ("<applicable-struct-with-setter-vtable>", 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-vtable", scm_from_int (scm_vtable_index_vtable));
scm_c_define ("vtable-index-printer",
- scm_from_int (scm_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"
}
\f
-/* Number of words with negative index */
-#define scm_struct_n_extra_words 4
-#define scm_struct_entity_n_extra_words 6
-
-/* These are how the initial words of a vtable are allocated. */
-#define scm_struct_i_setter -6 /* Setter */
-#define scm_struct_i_procedure -5 /* Optional procedure slot */
-#define scm_struct_i_free -4 /* Destructor */
-#define scm_struct_i_ptr -3 /* Start of block (see alloc_struct) */
-#define scm_struct_i_n_words -2 /* How many words allocated to this struct? */
-#define scm_struct_i_flags -1 /* Upper 12 bits used as flags */
-
-/* These indices must correspond to required_vtable_fields in
- struct.c. */
-#define scm_vtable_index_layout 0 /* A symbol describing the physical arrangement of this type. */
-#define scm_vtable_index_vtable 1 /* A pointer to the handle for this vtable. */
-#define scm_vtable_index_printer 2 /* A printer for this struct type. */
-#define scm_vtable_offset_user 3 /* Where do user fields start? */
-
-typedef void (*scm_t_struct_free) (scm_t_bits * vtable, scm_t_bits * data);
-
-#define SCM_STRUCTF_MASK (0xFFF << 20)
-#define SCM_STRUCTF_GOOPS_HACK (0x010 << 20) /* FIXME -- PURE_GENERIC */
-#define SCM_STRUCTF_LIGHT (1L << 31) /* Light representation
- (no hidden words) */
+/* The relationship between a struct and its vtable is a bit complicated,
+ because we want structs to be used as GOOPS' native representation -- which
+ in turn means we need support for changing the "class" (vtable) of an
+ "instance" (struct). This necessitates some indirection and trickery.
+
+ I would like to write this all up here, but for now:
+
+ http://wingolog.org/pub/goops-class-redefinition-3.png
+ */
+
+/* All vtables have the following fields. */
+#define SCM_VTABLE_BASE_LAYOUT \
+ "pr" /* layout */ \
+ "uh" /* flags */ \
+ "sr" /* self */ \
+ "uh" /* finalizer */ \
+ "pw" /* printer */ \
+ "ph" /* name (hidden from make-struct for back-compat reasons) */ \
+ "uh" /* reserved */ \
+ "uh" /* reserved */
+
+#define scm_vtable_index_layout 0 /* A symbol describing the physical arrangement of this type. */
+#define scm_vtable_index_flags 1 /* Class flags */
+#define scm_vtable_index_self 2 /* A pointer to the vtable itself */
+#define scm_vtable_index_instance_finalize 3 /* Finalizer for instances of this struct type. */
+#define scm_vtable_index_instance_printer 4 /* A printer for this struct type. */
+#define scm_vtable_index_name 5 /* Name of this vtable. */
+#define scm_vtable_index_reserved_6 6
+#define scm_vtable_index_reserved_7 7
+#define scm_vtable_offset_user 8 /* Where do user fields start in the vtable? */
+
+/* All applicable structs have the following fields. */
+#define SCM_APPLICABLE_BASE_LAYOUT \
+ "pw" /* procedure */
+#define SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT \
+ "pw" /* procedure */ \
+ "pw" /* setter */
+#define scm_applicable_struct_index_procedure 0 /* The procedure of an applicable
+ struct. Only valid if the
+ struct's vtable has the
+ applicable flag set. */
+#define scm_applicable_struct_index_setter 1 /* The setter of an applicable
+ struct. Only valid if the
+ struct's vtable has the
+ setter flag set. */
+
+#define SCM_VTABLE_FLAG_VTABLE (1L << 0) /* instances of this vtable are themselves vtables? */
+#define SCM_VTABLE_FLAG_APPLICABLE_VTABLE (1L << 1) /* instances of this vtable are applicable vtables? */
+#define SCM_VTABLE_FLAG_APPLICABLE (1L << 2) /* instances of this vtable are applicable? */
+#define SCM_VTABLE_FLAG_SETTER_VTABLE (1L << 3) /* instances of this vtable are applicable-with-setter vtables? */
+#define SCM_VTABLE_FLAG_SETTER (1L << 4) /* instances of this vtable are applicable-with-setters? */
+#define SCM_VTABLE_FLAG_RESERVED_0 (1L << 5)
+#define SCM_VTABLE_FLAG_RESERVED_1 (1L << 6)
+#define SCM_VTABLE_FLAG_RESERVED_2 (1L << 7)
+#define SCM_VTABLE_FLAG_GOOPS_0 (1L << 8)
+#define SCM_VTABLE_FLAG_GOOPS_1 (1L << 9)
+#define SCM_VTABLE_FLAG_GOOPS_2 (1L << 10)
+#define SCM_VTABLE_FLAG_GOOPS_3 (1L << 11)
+#define SCM_VTABLE_FLAG_GOOPS_4 (1L << 12)
+#define SCM_VTABLE_FLAG_GOOPS_5 (1L << 13)
+#define SCM_VTABLE_FLAG_GOOPS_6 (1L << 14)
+#define SCM_VTABLE_FLAG_GOOPS_7 (1L << 15)
+#define SCM_VTABLE_USER_FLAG_SHIFT 16
+
+typedef void (*scm_t_struct_finalize) (SCM obj);
#define SCM_STRUCTP(X) (!SCM_IMP(X) && (SCM_TYP3(X) == scm_tc3_struct))
-#define SCM_STRUCT_DATA(X) ((scm_t_bits *) SCM_CELL_WORD_1 (X))
-#define SCM_STRUCT_VTABLE_DATA(X) ((scm_t_bits *) (SCM_CELL_WORD_0 (X) - scm_tc3_struct))
-
-#define SCM_STRUCT_LAYOUT(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout]))
-#define SCM_SET_STRUCT_LAYOUT(X, v) (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout] = SCM_UNPACK (v))
-
-#define SCM_STRUCT_VTABLE(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_vtable]))
-#define SCM_STRUCT_VTABLE_FLAGS(X) \
- (SCM_STRUCT_VTABLE_DATA (X) [scm_struct_i_flags])
-#define SCM_STRUCT_PRINTER(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_printer]))
-#define SCM_SET_STRUCT_PRINTER(x, v)\
- (SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_printer] = SCM_UNPACK (v))
-#define SCM_SET_VTABLE_DESTRUCTOR(X, D) (SCM_STRUCT_DATA (X) [scm_struct_i_free] = (scm_t_bits) (D))
-/* Efficiency is important in the following macro, since it's used in GC */
-#define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */
+#define SCM_STRUCT_SLOTS(X) ((SCM*)SCM_CELL_WORD_1 ((X)))
+#define SCM_STRUCT_SLOT_REF(X,I) (SCM_STRUCT_SLOTS (X)[(I)])
+#define SCM_STRUCT_SLOT_SET(X,I,V) SCM_STRUCT_SLOTS (X)[(I)]=(V)
+#define SCM_STRUCT_DATA(X) ((scm_t_bits*)SCM_CELL_WORD_1 (X))
+#define SCM_STRUCT_DATA_REF(X,I) (SCM_STRUCT_DATA (X)[(I)])
+#define SCM_STRUCT_DATA_SET(X,I,V) SCM_STRUCT_DATA (X)[(I)]=(V)
+
+/* The SCM_VTABLE_* macros assume that you're passing them a struct which is a
+ valid vtable. */
+#define SCM_VTABLE_LAYOUT(X) (SCM_STRUCT_SLOT_REF ((X), scm_vtable_index_layout))
+#define SCM_SET_VTABLE_LAYOUT(X,L) (SCM_STRUCT_SLOT_SET ((X), scm_vtable_index_layout, L))
+#define SCM_VTABLE_FLAGS(X) (SCM_STRUCT_DATA_REF (X, scm_vtable_index_flags))
+#define SCM_SET_VTABLE_FLAGS(X,F) (SCM_STRUCT_DATA_REF (X, scm_vtable_index_flags) |= (F))
+#define SCM_CLEAR_VTABLE_FLAGS(X,F) (SCM_STRUCT_DATA_REF (X, scm_vtable_index_flags) &= (~(F)))
+#define SCM_VTABLE_FLAG_IS_SET(X,F) (SCM_STRUCT_DATA_REF (X, scm_vtable_index_flags) & (F))
+#define SCM_VTABLE_INSTANCE_FINALIZER(X) ((scm_t_struct_finalize)SCM_STRUCT_SLOT_REF (X, scm_vtable_index_instance_finalize))
+#define SCM_VTABLE_INSTANCE_PRINTER(X) (SCM_STRUCT_SLOT_REF (X, scm_vtable_index_instance_printer))
+#define SCM_VTABLE_NAME(X) (SCM_STRUCT_SLOT_REF (X, scm_vtable_index_name))
+#define SCM_SET_VTABLE_NAME(X,V) (SCM_STRUCT_SLOT_SET (X, scm_vtable_index_name, V))
+
+/* Structs hold a pointer to their vtable's data, not the vtable itself. To get
+ the vtable we have to do an indirection through the self slot. */
+#define SCM_STRUCT_VTABLE_DATA(X) ((scm_t_bits*)(SCM_CELL_WORD_0 (X) - scm_tc3_struct))
+#define SCM_STRUCT_VTABLE_SLOTS(X) ((SCM*)(SCM_CELL_WORD_0 (X) - scm_tc3_struct))
+#define SCM_STRUCT_VTABLE(X) (SCM_STRUCT_VTABLE_SLOTS(X)[scm_vtable_index_self])
+/* But often we just need to access the vtable's data; we can do that without
+ the data->self->data indirection. */
+#define SCM_STRUCT_LAYOUT(X) (SCM_STRUCT_VTABLE_SLOTS (X)[scm_vtable_index_layout])
+#define SCM_STRUCT_PRINTER(X) (SCM_STRUCT_VTABLE_SLOTS (X)[scm_vtable_index_instance_printer])
+#define SCM_STRUCT_FINALIZER(X) ((scm_t_struct_finalize)SCM_STRUCT_VTABLE_DATA (X)[scm_vtable_index_instance_finalize])
+#define SCM_STRUCT_VTABLE_FLAGS(X) (SCM_STRUCT_VTABLE_DATA (X)[scm_vtable_index_flags])
+#define SCM_STRUCT_VTABLE_FLAG_IS_SET(X,F) (SCM_STRUCT_VTABLE_DATA (X)[scm_vtable_index_flags]&(F))
+
+#define SCM_STRUCT_APPLICABLE_P(X) (SCM_STRUCT_VTABLE_FLAG_IS_SET ((X), SCM_VTABLE_FLAG_APPLICABLE))
+#define SCM_STRUCT_SETTER_P(X) (SCM_STRUCT_VTABLE_FLAG_IS_SET ((X), SCM_VTABLE_FLAG_SETTER))
+#define SCM_STRUCT_PROCEDURE(X) (SCM_STRUCT_SLOT_REF (X, scm_applicable_struct_index_procedure))
+#define SCM_SET_STRUCT_PROCEDURE(X,P) (SCM_STRUCT_SLOT_SET (X, scm_applicable_struct_index_procedure, P))
+#define SCM_STRUCT_SETTER(X) (SCM_STRUCT_SLOT_REF (X, scm_applicable_struct_index_setter))
+#define SCM_SET_STRUCT_SETTER(X,P) (SCM_STRUCT_SLOT_SET (X, scm_applicable_struct_index_setter, P))
#define SCM_STRUCT_TABLE_NAME(X) SCM_CAR (X)
#define SCM_SET_STRUCT_TABLE_NAME(X, NAME) SCM_SETCAR (X, NAME)
\f
-SCM_API scm_t_bits * scm_alloc_struct (int n_words, int n_extra,
- const char *what);
+SCM_API SCM scm_alloc_struct (scm_t_bits *vtable_data, int n_words, const char *what);
SCM_API SCM scm_make_struct_layout (SCM fields);
SCM_API SCM scm_struct_p (SCM x);
SCM_API SCM scm_struct_vtable_p (SCM x);
;;;
(define hashsets 8)
-(define hashset-index 6)
+(define hashset-index 9)
(define hash-threshold 3)
(define initial-hash-size 4) ;must be a power of 2 and >= hash-threshold
HCoop / bpt / guile.git / commitdiff