mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 20:30:28 +02:00
Code Activity

limn goops flags, remove foreign objs, rename entity to applicable-struct

Browse source 
* libguile/goops.c (scm_class_applicable_struct)
  (scm_class_applicable_struct_with_setter)
  (scm_class_applicable_struct_class): Rename from
  scm_class_entity, scm_class_entity_with_setter, and
  scm_class_entity_class.
  (scm_class_simple_method): Removed; this abstraction is not used.
  (scm_class_foreign_class, scm_class_foreign_object): Remove these,
  they are undocumented and unused. They might come back later.
  (scm_sys_inherit_magic_x): Simply inherit the vtable flags from the
  class's class. Flags are about layout, and it is the class that
  determines the layout of the instance.
  (scm_basic_basic_make_class): Don't bother setting GOOPS_OR_VALID,
  inherit-magic will do that.
  (scm_basic_make_class): Inherit magic after setting the layout. Allows
  the struct magic checker to do its job.
  (scm_accessor_method_slot_definition): Move implementation to Scheme.
  Removes the need for the accessor flag.
  (scm_sys_allocate_instance): Adapt to scm_i_alloc_struct name change,
  and that alloc-struct will handle finalization.
  (scm_compute_applicable_methods): Remove accessor check, as it's
  unnecessary.
  (scm_make): Adapt to new generic slot order, and no more
  simple-method.
  (create_standard_classes): What was the GF slot "dispatch-procedure"
  is now the applicable-struct slot "procedure". No more foreign class,
  foreign object, or simple method. Rename <entity> and friends to
  <applicable-struct> and friends. No more entity-with-setter -- though
  perhaps it will come back too. Instead generic-with-setter is its own
  thing.

* libguile/goops.h (SCM_CLASSF_METACLASS): "A goops class that is a
  vtable" -- no need for a separate flag.
  (SCM_CLASSF_FOREIGN, SCM_CLASSF_SIMPLE_METHOD)
  (SCM_CLASSF_ACCESSOR_METHOD): Removed these unused flags.
  (SCM_ACCESSORP): Removed.
  Renumber generic slots, rename entity classes, and remove the foreign
  class, foreign object, and simple method classes.

* libguile/struct.c (scm_i_struct_inherit_vtable_magic): New function,
  called when making new vtables.applicable structs
  (scm_i_alloc_struct): Remove 8-bit alignment check, as libGC
  guarantees this for us. Handle finalizer registration here.
  (scm_make_struct): Factor some things to scm_i_alloc_struct and
  scm_i_struct_inherit_vtable_magic.
  (scm_make_vtable_vtable): Adapt to scm_i_alloc_struct name change.

* libguile/struct.h (scm_i_alloc_struct): Change name from
  scm_alloc_struct, and make internal.

* module/oop/goops.scm (oop): Don't declare #:replace <class> et al,
  because <class> isn't defined in the core any more.
  (accessor-method-slot-definition): Defined in Scheme now.
  Remove <foreign-object> methods.
  (initialize on <class>): Prep layout before inheriting magic, as in
  scm_basic_make_class.

* module/oop/goops/dispatch.scm (delayed-compile)
  (memoize-effective-method!): Adapt to 'procedure slot name change.
This commit is contained in:
Andy Wingo 2009-11-08 11:24:23 +01:00
parent e29db33c14
commit 51f66c9120
6 changed files with 147 additions and 248 deletions
Download patch file Download diff file Expand all files Collapse all files

123
libguile/goops.c
View file

@ -144,20 +144,19 @@ SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction;
SCM scm_class_unknown;
SCM scm_class_top, scm_class_object, scm_class_class;
SCM scm_class_applicable;
SCM scm_class_entity, scm_class_entity_with_setter;
SCM scm_class_applicable_struct, scm_class_applicable_struct_with_setter;
SCM scm_class_generic, scm_class_generic_with_setter;
SCM scm_class_accessor;
SCM scm_class_extended_generic, scm_class_extended_generic_with_setter;
SCM scm_class_extended_accessor;
SCM scm_class_method;
SCM scm_class_simple_method, scm_class_accessor_method;
SCM scm_class_accessor_method;
SCM scm_class_procedure_class;
SCM scm_class_entity_class;
SCM scm_class_applicable_struct_class;
SCM scm_class_number, scm_class_list;
SCM scm_class_keyword;
SCM scm_class_port, scm_class_input_output_port;
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_hidden, scm_class_opaque, scm_class_read_only;
@ -747,21 +746,9 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0,
"")
#define FUNC_NAME s_scm_sys_inherit_magic_x
{
SCM ls = dsupers;
long flags = 0;
SCM_VALIDATE_INSTANCE (1, class);
while (!scm_is_null (ls))
{
SCM_ASSERT (scm_is_pair (ls)
&& SCM_INSTANCEP (SCM_CAR (ls)),
dsupers,
SCM_ARG2,
FUNC_NAME);
flags |= SCM_CLASS_FLAGS (SCM_CAR (ls));
ls = SCM_CDR (ls);
}
SCM_SET_CLASS_FLAGS (class, flags &~SCM_CLASSF_PURE_GENERIC);
scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID);
prep_hashsets (class);
@ -816,9 +803,6 @@ scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
scm_si_direct_subclasses)));
}
/* Support for the underlying structs: */
/* FIXME: set entity flag on z if class == entity_class ? */
SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_GOOPS_OR_VALID);
return z;
}
@ -826,8 +810,8 @@ SCM
scm_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
{
SCM z = scm_basic_basic_make_class (class, name, dsupers, dslots);
scm_sys_inherit_magic_x (z, dsupers);
scm_sys_prep_layout_x (z);
scm_sys_inherit_magic_x (z, dsupers);
return z;
}
@ -934,7 +918,7 @@ create_basic_classes (void)
DEFVAR(name, scm_class_class);
/**** <scm_class_top> ****/
/**** <top> ****/
name = scm_from_locale_symbol ("<top>");
scm_class_top = scm_permanent_object (scm_basic_make_class (scm_class_class,
name,
@ -943,7 +927,7 @@ create_basic_classes (void)
DEFVAR(name, scm_class_top);
/**** <scm_class_object> ****/
/**** <object> ****/
name = scm_from_locale_symbol ("<object>");
scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class,
name,
@ -1145,16 +1129,6 @@ SCM_DEFINE (scm_method_procedure, "method-procedure", 1, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_accessor_method_slot_definition, "accessor-method-slot-definition", 1, 0, 0,
(SCM obj),
"Return the slot definition of the accessor @var{obj}.")
#define FUNC_NAME s_scm_accessor_method_slot_definition
{
SCM_VALIDATE_ACCESSOR (1, obj);
return scm_slot_ref (obj, scm_from_locale_symbol ("slot-definition"));
}
#undef FUNC_NAME
/******************************************************************************
*
* S l o t a c c e s s
@ -1505,15 +1479,6 @@ SCM_DEFINE (scm_slot_exists_p, "slot-exists?", 2, 0, 0,
static void clear_method_cache (SCM);
static void
goops_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data)
{
SCM obj = PTR2SCM (ptr);
scm_t_struct_finalize finalize = SCM_STRUCT_FINALIZER (obj);
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"
@ -1530,7 +1495,7 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
/* 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");
obj = scm_i_alloc_struct (SCM_STRUCT_DATA (class), n, "struct");
layout = SCM_VTABLE_LAYOUT (class);
@ -1545,26 +1510,9 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
SCM_STRUCT_DATA (obj)[i] = 0;
}
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);
}
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
clear_method_cache (obj);
/* 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); */
return obj;
}
#undef FUNC_NAME
@ -2219,10 +2167,6 @@ scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
{
fl = SPEC_OF (SCM_CAR (l));
/* Only accept accessors which match exactly in first arg. */
if (SCM_ACCESSORP (SCM_CAR (l))
&& (scm_is_null (fl) || types[0] != SCM_CAR (fl)))
continue;
for (i = 0; ; i++, fl = SCM_CDR (fl))
{
if (SCM_INSTANCEP (fl)
@ -2363,7 +2307,8 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
if (class == scm_class_generic || class == scm_class_accessor)
{
z = scm_make_struct (class, SCM_INUM0,
scm_list_4 (SCM_EOL,
scm_list_5 (SCM_BOOL_F,
SCM_EOL,
SCM_INUM0,
scm_make_mutex (),
SCM_EOL));
@ -2384,7 +2329,6 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
z = scm_sys_allocate_instance (class, args);
if (class == scm_class_method
|| class == scm_class_simple_method
|| class == scm_class_accessor_method)
{
SCM_SET_SLOT (z, scm_si_generic_function,
@ -2588,7 +2532,6 @@ create_standard_classes (void)
k_init_value,
SCM_EOL),
scm_from_locale_symbol ("%cache"),
scm_from_locale_symbol ("dispatch-procedure"),
scm_from_locale_symbol ("effective-methods"),
SCM_UNDEFINED);
SCM setter_slots = scm_list_1 (sym_setter);
@ -2637,63 +2580,45 @@ create_standard_classes (void)
SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
compute_getters_n_setters (slots));
make_stdcls (&scm_class_foreign_class, "<foreign-class>",
scm_class_class, scm_class_class,
scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
k_class,
scm_class_opaque),
scm_list_3 (scm_from_locale_symbol ("destructor"),
k_class,
scm_class_opaque)));
make_stdcls (&scm_class_foreign_object, "<foreign-object>",
scm_class_foreign_class, scm_class_object, SCM_EOL);
SCM_SET_CLASS_FLAGS (scm_class_foreign_object, SCM_CLASSF_FOREIGN);
/* scm_class_generic functions classes */
make_stdcls (&scm_class_procedure_class, "<procedure-class>",
scm_class_class, scm_class_class, SCM_EOL);
make_stdcls (&scm_class_entity_class, "<entity-class>",
make_stdcls (&scm_class_applicable_struct_class, "<applicable-struct-class>",
scm_class_class, scm_class_procedure_class, SCM_EOL);
/* SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class,
SCM_VTABLE_FLAG_APPLICABLE_VTABLE); */
make_stdcls (&scm_class_method, "<method>",
scm_class_class, scm_class_object, method_slots);
make_stdcls (&scm_class_simple_method, "<simple-method>",
scm_class_class, scm_class_method, SCM_EOL);
SCM_SET_CLASS_FLAGS (scm_class_simple_method, SCM_CLASSF_SIMPLE_METHOD);
make_stdcls (&scm_class_accessor_method, "<accessor-method>",
scm_class_class, scm_class_simple_method, amethod_slots);
SCM_SET_CLASS_FLAGS (scm_class_accessor_method, SCM_CLASSF_ACCESSOR_METHOD);
scm_class_class, scm_class_method, amethod_slots);
make_stdcls (&scm_class_applicable, "<applicable>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_entity, "<entity>",
scm_class_entity_class,
make_stdcls (&scm_class_applicable_struct, "<applicable-struct>",
scm_class_applicable_struct_class,
scm_list_2 (scm_class_object, scm_class_applicable),
SCM_EOL);
make_stdcls (&scm_class_entity_with_setter, "<entity-with-setter>",
scm_class_entity_class, scm_class_entity, SCM_EOL);
scm_list_1 (sym_procedure));
make_stdcls (&scm_class_generic, "<generic>",
scm_class_entity_class, scm_class_entity, gf_slots);
scm_class_applicable_struct_class, scm_class_applicable_struct, gf_slots);
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_class_applicable_struct_class, scm_class_generic, egf_slots);
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),
setter_slots);
scm_class_applicable_struct_class, scm_class_generic, 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_class_applicable_struct_class, scm_class_generic_with_setter, SCM_EOL);
SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_generic_with_setter,
"<extended-generic-with-setter>",
scm_class_entity_class,
scm_class_applicable_struct_class,
scm_list_2 (scm_class_generic_with_setter,
scm_class_extended_generic),
SCM_EOL);
SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_accessor, "<extended-accessor>",
scm_class_entity_class,
scm_class_applicable_struct_class,
scm_list_2 (scm_class_accessor,
scm_class_extended_generic_with_setter),
SCM_EOL);

37
libguile/goops.h
View file

@ -42,11 +42,7 @@
*/
#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_VTABLE_FLAG_GOOPS_PURE_GENERIC SCM_VTABLE_FLAG_GOOPS_2
#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
#define SCM_CLASS_FLAGS(class) (SCM_VTABLE_FLAGS (class))
@ -54,13 +50,10 @@
#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_METACLASS (SCM_VTABLE_FLAG_GOOPS_CLASS|SCM_VTABLE_FLAG_VTABLE)
#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)
/*
@ -140,10 +133,6 @@ typedef struct scm_t_method {
(SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_PURE_GENERIC))
#define SCM_VALIDATE_PUREGENERIC(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, PUREGENERICP, "pure generic function")
#define SCM_ACCESSORP(x) \
(SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_ACCESSOR_METHOD))
#define SCM_VALIDATE_ACCESSOR(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, ACCESSORP, "accessor")
#define SCM_SLOT(x, i) (SCM_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)])
@ -176,12 +165,12 @@ typedef struct scm_t_method {
#define SCM_INITIAL_MCACHE_SIZE 1
#define scm_si_methods 0 /* offset of methods slot in a <generic> */
#define scm_si_n_specialized 1
#define scm_si_cache_mutex 2
#define scm_si_extended_by 3
#define scm_si_generic_cache 4
#define scm_si_dispatch_procedure 5
#define scm_si_dispatch_procedure scm_applicable_struct_index_procedure /* 0 */
#define scm_si_methods 1
#define scm_si_n_specialized 2
#define scm_si_cache_mutex 3
#define scm_si_extended_by 4
#define scm_si_generic_cache 5
#define scm_si_effective_methods 6
#define scm_si_generic_setter 7
@ -213,8 +202,8 @@ SCM_API SCM scm_class_top;
SCM_API SCM scm_class_object;
SCM_API SCM scm_class_class;
SCM_API SCM scm_class_applicable;
SCM_API SCM scm_class_entity;
SCM_API SCM scm_class_entity_with_setter;
SCM_API SCM scm_class_applicable_struct;
SCM_API SCM scm_class_applicable_struct_with_setter;
SCM_API SCM scm_class_generic;
SCM_API SCM scm_class_generic_with_setter;
SCM_API SCM scm_class_accessor;
@ -222,10 +211,9 @@ SCM_API SCM scm_class_extended_generic;
SCM_API SCM scm_class_extended_generic_with_setter;
SCM_API SCM scm_class_extended_accessor;
SCM_API SCM scm_class_method;
SCM_API SCM scm_class_simple_method;
SCM_API SCM scm_class_accessor_method;
SCM_API SCM scm_class_procedure_class;
SCM_API SCM scm_class_entity_class;
SCM_API SCM scm_class_applicable_struct_class;
SCM_API SCM scm_class_number;
SCM_API SCM scm_class_list;
SCM_API SCM scm_class_keyword;
@ -233,8 +221,6 @@ SCM_API SCM scm_class_port;
SCM_API SCM scm_class_input_output_port;
SCM_API SCM scm_class_input_port;
SCM_API SCM scm_class_output_port;
SCM_API SCM scm_class_foreign_class;
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;
@ -304,7 +290,6 @@ SCM_API SCM scm_generic_function_methods (SCM obj);
SCM_API SCM scm_method_generic_function (SCM obj);
SCM_API SCM scm_method_specializers (SCM obj);
SCM_API SCM scm_method_procedure (SCM obj);
SCM_API SCM scm_accessor_method_slot_definition (SCM obj);
SCM_API SCM scm_sys_tag_body (SCM body);
SCM_API SCM scm_sys_fast_slot_ref (SCM obj, SCM index);
SCM_API SCM scm_sys_fast_slot_set_x (SCM obj, SCM index, SCM value);

179
libguile/struct.c
View file

@ -146,6 +146,63 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
void
scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
#define FUNC_NAME "%inherit-vtable-magic"
{
/* Verily, what is the deal here, you ask? Basically, we need to know a couple
of properties of structures at runtime. For example, "is this structure a
vtable of vtables (a metaclass)?"; also, "is this structure applicable?".
Both of these questions also imply a certain layout of the structure. So
instead of checking the layout at runtime, what we do is pre-verify the
layout -- so that at runtime we can just check the applicable flag and
dispatch directly to the Scheme procedure in slot 0.
*/
SCM olayout;
/* verify that obj is a valid vtable */
if (scm_is_false (scm_symbol_p (SCM_VTABLE_LAYOUT (obj))))
scm_misc_error (FUNC_NAME, "invalid layout for new vtable",
scm_list_1 (SCM_VTABLE_LAYOUT (obj)));
/* if obj's vtable is compatible with the required vtable (class) layout, it
is a metaclass */
olayout = scm_symbol_to_string (SCM_VTABLE_LAYOUT (obj));
if (scm_is_true (scm_leq_p (scm_string_length (required_vtable_fields),
scm_string_length (olayout)))
&& scm_is_true (scm_string_eq (olayout, required_vtable_fields,
scm_from_size_t (0),
scm_string_length (required_vtable_fields),
scm_from_size_t (0),
scm_string_length (required_vtable_fields))))
SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);
/* finally if obj is an applicable class, verify that its vtable is
compatible with the required applicable layout */
if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SETTER_VTABLE))
{
if (scm_is_false (scm_string_eq (olayout, required_applicable_with_setter_fields,
scm_from_size_t (0),
scm_from_size_t (4),
scm_from_size_t (0),
scm_from_size_t (4))))
scm_misc_error (FUNC_NAME, "invalid applicable-with-setter struct layout",
scm_list_1 (olayout));
SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE | SCM_VTABLE_FLAG_SETTER);
}
else if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE))
{
if (scm_is_false (scm_string_eq (olayout, required_applicable_fields,
scm_from_size_t (0),
scm_from_size_t (2),
scm_from_size_t (0),
scm_from_size_t (2))))
scm_misc_error (FUNC_NAME, "invalid applicable struct layout",
scm_list_1 (olayout));
SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE);
}
}
#undef FUNC_NAME
static void
@ -255,6 +312,17 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
#undef FUNC_NAME
/* Finalization: invoke the finalizer of the struct pointed to by PTR. */
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);
if (finalize)
finalize (obj);
}
/* All struct data must be allocated at an address whose bottom three
bits are zero. This is because the tag for a struct lives in the
bottom three bits of the struct's car, and the upper bits point to
@ -270,38 +338,30 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
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)
scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words, const char *what)
{
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));
/* vtable_data can be null when making a vtable vtable */
if (vtable_data && vtable_data[scm_vtable_index_instance_finalize])
{
/* Register a finalizer for the newly created instance. */
GC_finalization_proc prev_finalizer;
GC_PTR prev_finalizer_data;
GC_REGISTER_FINALIZER_NO_ORDER ((void*)ret,
struct_finalizer_trampoline,
NULL,
&prev_finalizer,
&prev_finalizer_data);
}
return SCM_PACK (ret);
}
/* Finalization. */
/* Invoke the finalizer of the struct pointed to by PTR. */
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);
if (finalize)
finalize (obj);
}
SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
(SCM vtable, SCM tail_array_size, SCM init),
@ -353,79 +413,16 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
goto bad_tail;
}
obj = scm_alloc_struct (SCM_STRUCT_DATA (vtable), basic_size + tail_elts,
obj = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), basic_size + tail_elts,
"struct");
if (SCM_VTABLE_INSTANCE_FINALIZER (vtable))
{
/* 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),
struct_finalizer_trampoline,
NULL,
&prev_finalizer,
&prev_finalizer_data);
}
scm_struct_init (obj, layout, tail_elts, init);
/* Verily, what is the deal here, you ask? Basically, we need to know a couple
of properties of structures at runtime. For example, "is this structure a
vtable of vtables (a metaclass)?"; also, "is this structure applicable?".
Both of these questions also imply a certain layout of the structure. So
instead of checking the layout at runtime, what we do is pre-verify the
layout -- so that at runtime we can just check the applicable flag and
dispatch directly to the Scheme procedure in slot 0.
*/
if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE)
/* only do these checks if the layout was passed as an initarg.
/* only check things and inherit magic if the layout was passed as an initarg.
something of a hack, but it's for back-compatibility. */
if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE)
&& 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);
}
}
scm_i_struct_inherit_vtable_magic (vtable, obj);
return obj;
}
@ -496,7 +493,7 @@ 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;
obj = scm_alloc_struct (NULL, basic_size + tail_elts, "struct");
obj = scm_i_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;

8
libguile/struct.h
View file

@ -143,24 +143,26 @@ SCM_API SCM scm_struct_table;
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);
SCM_API SCM scm_make_struct (SCM vtable, SCM tail_array_size, SCM init);
SCM_API SCM scm_make_vtable (SCM fields, SCM printer);
SCM_API SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init);
SCM_INTERNAL SCM scm_i_struct_equalp (SCM s1, SCM s2);
SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
SCM_API SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
SCM_API SCM scm_struct_vtable (SCM handle);
SCM_API SCM scm_struct_vtable_tag (SCM handle);
SCM_INTERNAL unsigned long scm_struct_ihashq (SCM, unsigned long, void *);
SCM_API SCM scm_struct_create_handle (SCM obj);
SCM_API SCM scm_struct_vtable_name (SCM vtable);
SCM_API SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name);
SCM_API void scm_print_struct (SCM exp, SCM port, scm_print_state *);
SCM_API void scm_struct_prehistory (void);
SCM_INTERNAL SCM scm_i_struct_equalp (SCM s1, SCM s2);
SCM_INTERNAL unsigned long scm_struct_ihashq (SCM, unsigned long, void *);
SCM_INTERNAL SCM scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words, const char *what);
SCM_INTERNAL void scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj);
SCM_INTERNAL void scm_init_struct (void);
#endif /* SCM_STRUCT_H */

38
module/oop/goops.scm
View file

@ -73,7 +73,6 @@
primitive-generic-generic enable-primitive-generic!
method-procedure accessor-method-slot-definition
slot-exists? make find-method get-keyword)
:replace (<class> <entity-class> <entity>)
:no-backtrace)
(define *goops-module* (current-module))
@ -705,6 +704,10 @@
(define (slot-init-function class slot-name)
(cadr (assq slot-name (slot-ref class 'getters-n-setters))))
(define (accessor-method-slot-definition obj)
"Return the slot definition of the accessor @var{obj}."
(slot-ref obj 'slot-definition))
;;;
;;; {Standard methods used by the C runtime}
@ -745,17 +748,6 @@
(display #\> file))
(next-method))))
(define-method (write (o <foreign-object>) file)
(let ((class (class-of o)))
(if (slot-bound? class 'name)
(begin
(display "#<foreign-object " file)
(display (class-name class) file)
(display #\space file)
(display-address o file)
(display #\> file))
(next-method))))
(define-method (write (class <class>) file)
(let ((meta (class-of class)))
(if (and (slot-bound? class 'name)
@ -1168,6 +1160,7 @@
;;; compute-getters-n-setters
;;;
;; FIXME!!!
(define (make-thunk thunk)
(lambda () (thunk)))
@ -1467,11 +1460,10 @@
;; Support for the underlying structs:
;; Inherit class flags (invisible on scheme level) from supers
(%inherit-magic! class supers)
;; Set the layout slot
(%prep-layout! class)))
(%prep-layout! class)
;; Inherit class flags (invisible on scheme level) from supers
(%inherit-magic! class supers)))
(define (initialize-object-procedure object initargs)
(let ((proc (get-keyword #:procedure initargs #f)))
@ -1484,13 +1476,9 @@
(set-object-procedure! object
(lambda args (apply proc args)))))))
(define-method (initialize (entity <entity>) initargs)
(define-method (initialize (applicable-struct <applicable-struct>) initargs)
(next-method)
(initialize-object-procedure entity initargs))
(define-method (initialize (ews <entity-with-setter>) initargs)
(next-method)
(%set-object-setter! ews (get-keyword #:setter initargs #f)))
(initialize-object-procedure applicable-struct initargs))
(define-method (initialize (generic <generic>) initargs)
(let ((previous-definition (get-keyword #:default initargs #f))
@ -1504,6 +1492,10 @@
(set-procedure-property! generic 'name name))
))
(define-method (initialize (gws <generic-with-setter>) initargs)
(next-method)
(%set-object-setter! gws (get-keyword #:setter initargs #f)))
(define-method (initialize (eg <extended-generic>) initargs)
(next-method)
(slot-set! eg 'extends (get-keyword #:extends initargs '())))
@ -1521,8 +1513,6 @@
(slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f)))
(define-method (initialize (obj <foreign-object>) initargs))
;;;
;;; {Change-class}
;;;

4
module/oop/goops/dispatch.scm
View file

@ -206,7 +206,7 @@
(with-fluids ((*in-progress* (cons gf in-progress)))
(let ((dispatch (compute-dispatch-procedure
gf (slot-ref gf 'effective-methods))))
(slot-set! gf 'dispatch-procedure dispatch)
(slot-set! gf 'procedure dispatch)
(apply dispatch args))))))))))
(define (cache-dispatch gf args)
@ -242,7 +242,7 @@
(cache (cons (vector len types rest? cmethod)
(slot-ref gf 'effective-methods))))
(slot-set! gf 'effective-methods cache)
(slot-set! gf 'dispatch-procedure (delayed-compile gf))
(slot-set! gf 'procedure (delayed-compile gf))
cmethod))
(parse 0 args))