mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-17 01:00:20 +02:00
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.
This commit is contained in:
Andy Wingo
parent
9bd48cb17b
commit
b6cf4d0265
11 changed files with 491 additions and 582 deletions
|
|
@ -355,7 +355,10 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
|
|||
}
|
||||
}
|
||||
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:
|
||||
|
|
|
|||
|
|
@ -92,6 +92,15 @@ SCM_DEPRECATED const char scm_s_formals[];
|
|||
: 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
|
||||
|
||||
|
|
|
|||
|
|
@ -3269,6 +3269,8 @@ scm_trampoline_0 (SCM proc)
|
|||
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;
|
||||
|
|
@ -3393,6 +3395,8 @@ scm_trampoline_1 (SCM proc)
|
|||
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;
|
||||
|
|
@ -3488,6 +3492,8 @@ scm_trampoline_2 (SCM proc)
|
|||
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;
|
||||
|
|
|
|||
|
|
@ -1032,18 +1032,16 @@ dispatch:
|
|||
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:
|
||||
|
|
@ -1165,19 +1163,17 @@ dispatch:
|
|||
#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:
|
||||
|
|
@ -1246,16 +1242,15 @@ dispatch:
|
|||
#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,
|
||||
|
|
@ -1264,7 +1259,6 @@ dispatch:
|
|||
SCM_EOL));
|
||||
#endif
|
||||
}
|
||||
#endif
|
||||
else
|
||||
goto badfun;
|
||||
case scm_tc7_subr_0:
|
||||
|
|
@ -1474,10 +1468,8 @@ dispatch:
|
|||
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:
|
||||
|
|
@ -1781,8 +1773,7 @@ tail:
|
|||
#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
|
||||
|
|
@ -1791,7 +1782,7 @@ tail:
|
|||
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);
|
||||
|
|
@ -1801,7 +1792,6 @@ tail:
|
|||
else
|
||||
goto badproc;
|
||||
}
|
||||
#endif
|
||||
else
|
||||
goto badproc;
|
||||
default:
|
||||
|
|
|
|||
335
libguile/goops.c
335
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);
|
||||
SCM obj = PTR2SCM (ptr);
|
||||
scm_t_struct_finalize finalize = SCM_STRUCT_FINALIZER (obj);
|
||||
|
||||
/* 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;
|
||||
|
||||
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)
|
||||
{
|
||||
/* FIXME: duplicates some of scm_make_struct. */
|
||||
|
||||
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);
|
||||
obj = scm_alloc_struct (SCM_STRUCT_DATA (class), n, "struct");
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
/* Foreign objects */
|
||||
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN)
|
||||
return scm_make_foreign_object (class, initargs);
|
||||
if (SCM_VTABLE_INSTANCE_FINALIZER (class))
|
||||
{
|
||||
/* 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);
|
||||
}
|
||||
|
||||
n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
|
||||
|
||||
/* 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;
|
||||
}
|
||||
clear_method_cache (obj);
|
||||
|
||||
/* Class objects */
|
||||
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)
|
||||
{
|
||||
long i;
|
||||
/* if ((SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)
|
||||
&& (SCM_SUBCLASSP (class, scm_class_entity_class)))
|
||||
SCM_SET_CLASS_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE); */
|
||||
|
||||
/* 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);
|
||||
|
||||
/* FIXME propagate applicable struct flag */
|
||||
|
||||
return z;
|
||||
}
|
||||
|
||||
/* 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"
|
||||
|
|
|
|||
168
libguile/goops.h
168
libguile/goops.h
|
|
@ -34,36 +34,85 @@
|
|||
|
||||
#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"
|
||||
/* 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_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
|
||||
#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;
|
||||
|
|
@ -73,34 +122,6 @@ typedef struct scm_t_method {
|
|||
|
||||
#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)
|
||||
|
||||
|
|
@ -123,8 +144,8 @@ typedef struct scm_t_method {
|
|||
(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))
|
||||
|
||||
|
|
@ -142,22 +163,22 @@ typedef struct scm_t_method {
|
|||
|
||||
#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> */
|
||||
|
|
@ -213,8 +234,10 @@ SCM_API SCM scm_class_foreign_object;
|
|||
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;
|
||||
|
|
@ -232,18 +255,8 @@ SCM_API SCM scm_oldfmt (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);
|
||||
|
|
@ -326,19 +339,6 @@ SCM_API SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3);
|
|||
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 */
|
||||
|
||||
/*
|
||||
|
|
|
|||
|
|
@ -126,13 +126,10 @@ scm_i_procedure_arity (SCM proc)
|
|||
r = 1;
|
||||
break;
|
||||
}
|
||||
/* FIXME applicable structs */
|
||||
else if (!SCM_STRUCT_APPLICABLE_P (proc))
|
||||
return SCM_BOOL_F;
|
||||
#if 0
|
||||
proc = SCM_ENTITY_PROCEDURE (proc);
|
||||
a -= 1;
|
||||
proc = SCM_STRUCT_PROCEDURE (proc);
|
||||
goto loop;
|
||||
#endif
|
||||
default:
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -97,7 +97,8 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
|
|||
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:
|
||||
|
|
@ -253,7 +254,7 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0,
|
|||
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);
|
||||
|
|
@ -261,7 +262,7 @@ SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0,
|
|||
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;
|
||||
}
|
||||
|
|
@ -280,10 +281,11 @@ scm_setter (SCM 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);
|
||||
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 */
|
||||
|
|
|
|||
|
|
@ -45,8 +45,13 @@
|
|||
|
||||
|
||||
|
||||
/* 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;
|
||||
|
||||
|
||||
SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
|
||||
|
|
@ -57,9 +62,14 @@ 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;
|
||||
|
|
@ -96,6 +106,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
|
|||
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':
|
||||
|
|
@ -138,12 +149,13 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
|
|||
|
||||
|
||||
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)
|
||||
|
|
@ -236,33 +248,9 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
|
|||
"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
|
||||
|
||||
|
|
@ -274,54 +262,27 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
|
|||
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.
|
||||
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.
|
||||
|
||||
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.
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -333,25 +294,10 @@ static void
|
|||
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);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -368,30 +314,23 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
|
|||
"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);
|
||||
|
||||
|
|
@ -414,47 +353,81 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
|
|||
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. */
|
||||
|
||||
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,
|
||||
obj = scm_alloc_struct (SCM_STRUCT_DATA (vtable), basic_size + tail_elts,
|
||||
"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);
|
||||
|
||||
return handle;
|
||||
/* 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 obj;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -512,8 +485,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
|
|||
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);
|
||||
|
|
@ -524,15 +496,13 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
|
|||
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
|
||||
|
||||
|
|
@ -611,8 +581,7 @@ scm_i_struct_equalp (SCM s1, SCM s2)
|
|||
|
||||
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.")
|
||||
|
|
@ -634,11 +603,9 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
|
|||
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];
|
||||
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);
|
||||
|
||||
|
|
@ -647,7 +614,7 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
|
|||
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';
|
||||
|
|
@ -713,11 +680,9 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
|
|||
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];
|
||||
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);
|
||||
|
||||
|
|
@ -726,7 +691,7 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
|
|||
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')
|
||||
|
|
@ -854,13 +819,39 @@ scm_print_struct (SCM exp, SCM port, scm_print_state *pstate)
|
|||
SCM name = scm_struct_vtable_name (vtable);
|
||||
scm_puts ("#<", port);
|
||||
if (scm_is_true (name))
|
||||
{
|
||||
scm_display (name, port);
|
||||
else
|
||||
scm_puts ("struct", port);
|
||||
scm_putc (' ', port);
|
||||
}
|
||||
else
|
||||
{
|
||||
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_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);
|
||||
}
|
||||
}
|
||||
|
|
@ -874,19 +865,38 @@ scm_struct_prehistory ()
|
|||
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"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -28,48 +28,112 @@
|
|||
|
||||
|
||||
|
||||
/* Number of words with negative index */
|
||||
#define scm_struct_n_extra_words 4
|
||||
#define scm_struct_entity_n_extra_words 6
|
||||
/* 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.
|
||||
|
||||
/* 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 */
|
||||
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 */
|
||||
|
||||
/* 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? */
|
||||
#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? */
|
||||
|
||||
typedef void (*scm_t_struct_free) (scm_t_bits * vtable, scm_t_bits * data);
|
||||
/* 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_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) */
|
||||
#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_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_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_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)
|
||||
|
|
@ -79,8 +143,7 @@ SCM_API SCM scm_struct_table;
|
|||
|
||||
|
||||
|
||||
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);
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@
|
|||
;;;
|
||||
|
||||
(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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue