summaryrefslogtreecommitdiff
path: root/libguile/goops.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-11-03 23:59:51 +0100
committerAndy Wingo <wingo@pobox.com>2009-11-26 00:24:58 +0100
commitb6cf4d026506b8e5042671f7503d4d9e9a810d49 (patch)
tree23fc026ced45b0ae756c4d0de111e9521711c7a8 /libguile/goops.c
parent9bd48cb17b4ce685f94f974442d452485a1017d6 (diff)
downloadguile-b6cf4d026506b8e5042671f7503d4d9e9a810d49.tar.gz
a very big commit cleaning up structs & goops. also applicable structs.
I tried to split this one, and I know it's a bit disruptive, but this stuff really is one big cobweb. So instead we'll pretend like these are separate commits, by separating the changelog. Applicable struct runtime support. * libguile/debug.c (scm_procedure_source): * libguile/eval.c (scm_trampoline_0, scm_trampoline_1) (scm_trampoline_2): * libguile/eval.i.c (CEVAL): * libguile/goops.c (scm_class_of): * libguile/procprop.c (scm_i_procedure_arity): * libguile/procs.c (scm_procedure_p, scm_procedure, scm_setter): Allow for applicable structs. Whee! * libguile/deprecated.h (scm_vtable_index_vtable): Define as a synonym for scm_vtable_index_self. (scm_vtable_index_printer): Alias scm_vtable_index_instance_printer. (scm_struct_i_free): Alias scm_vtable_index_instance_finalize. (scm_struct_i_flags): Alias scm_vtable_index_flags. (SCM_STRUCTF_FLAGS): Be a -1 mask, we have a whole word now. (SCM_SET_VTABLE_DESTRUCTOR): Implement by hand. Hidden slots. * libguile/struct.c (scm_make_struct_layout): Add support for "hidden" fields, writable fields that are not visible to make-struct. This allows us to add fields to vtables and not break existing make-struct invocations. (scm_struct_ref, scm_struct_set_x): Always get struct length from the vtable. Support hidden fields. * libguile/goops.c (scm_class_hidden, scm_class_protected_hidden): New slot classes, to correspond to the new vtable slots. (scm_sys_prep_layout_x): Turn hidden slots into 'h'. (build_class_class_slots): Reorder the class slots to account for vtable fields coming out of negative-land, for name as a vtable slot, and for hidden fields. (create_standard_classes): Define <hidden-slot> and <protected-hidden-slot>. Clean up struct.h. * libguile/struct.h: Lay things out cleaner. There are no more hidden (negative) words. Names are nicer. The exposition is nicer. But the basics are the same. The incompatibilities are that <vtable> has more slots now, and that scm_alloc_struct's signature has changed. The former is ameliorated by the "hidden" slots mentioned before, and the latter, well, it was always a very internal thing... (scm_t_struct_finalize): New type, a finalizer function to be run when instances of a vtable are collected. (scm_t_struct_free): Removed, structs' data is managed by the GC now, and not freed by vtable functions. * libguile/struct.c: (scm_vtable_p): Now we keep flags on vtable-vtables, so this check is cheaper. (scm_alloc_struct): No hidden words. Yippee. (struct_finalizer_trampoline): Entersify. (scm_make_struct): No need to babysit extra words, though now we have to babysit flags. Propagate the vtable, applicable, and setter flags appropriately. (scm_make_vtable_vtable): Update for new simplicity. (scm_print_struct): A better printer. (scm_init_struct): Define <applicable-struct-vtable>, a magical vtable like CL's funcallable-standard-class. Also define <applicable-struct-with-setter-vtable>. Remove foreign object implementation. * libguile/goops.h: * libguile/goops.c (scm_make_foreign_object, scm_make_class) (scm_add_slot, scm_wrap_object, scm_wrap_component): Remove, these were undocumented and unworking. Clean up goops.h, a little. * libguile/goops.h: * libguile/goops.c: Also clean up. * module/oop/goops/dispatch.scm (hashset-index): Adapt for new hashset index.
Diffstat (limited to 'libguile/goops.c')
-rw-r--r--libguile/goops.c333
1 files changed, 81 insertions, 252 deletions
diff --git a/libguile/goops.c b/libguile/goops.c
index e3f403d5f..ef0703561 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -160,8 +160,8 @@ SCM scm_class_input_port, scm_class_output_port;
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;
@@ -294,9 +294,9 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
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;
}
@@ -704,6 +704,8 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0,
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';
}
@@ -733,7 +735,7 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0,
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
@@ -758,27 +760,8 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0,
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);
@@ -812,7 +795,7 @@ scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
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);
@@ -851,8 +834,11 @@ scm_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
/******************************************************************************/
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");
@@ -882,12 +868,17 @@ SCM_SYMBOL (sym_environment, "environment");
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),
@@ -897,7 +888,6 @@ build_class_class_slots ()
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),
@@ -917,9 +907,8 @@ create_basic_classes (void)
{
/* 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,
@@ -927,7 +916,7 @@ create_basic_classes (void)
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);
@@ -1516,86 +1505,67 @@ SCM_DEFINE (scm_slot_exists_p, "slot-exists?", 2, 0, 0,
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
@@ -1662,10 +1632,10 @@ SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0,
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;
@@ -2459,7 +2429,7 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
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,
@@ -2610,7 +2580,7 @@ create_standard_classes (void)
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),
@@ -2622,7 +2592,10 @@ create_standard_classes (void)
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));
@@ -2631,18 +2604,22 @@ create_standard_classes (void)
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),
@@ -2695,27 +2672,21 @@ create_standard_classes (void)
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>",
@@ -2723,7 +2694,6 @@ create_standard_classes (void)
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>",
@@ -2733,7 +2703,6 @@ create_standard_classes (void)
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 */
@@ -2962,7 +2931,7 @@ make_struct_class (void *closure SCM_UNUSED,
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));
@@ -2992,149 +2961,12 @@ scm_load_goops ()
}
-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)
{
@@ -3217,9 +3049,6 @@ scm_init_goops_builtins (void)
*/
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"