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

Implement class redefinition on top of fixed structs

Browse source 
* libguile/struct.h: Steal another flag for GOOPS.
* libguile/goops.h (SCM_VTABLE_FLAG_GOOPS_INDIRECT)
  (SCM_VTABLE_FLAG_GOOPS_NEEDS_MIGRATION): New flags.
  (SCM_CLASSF_GOOPS_VALID, SCM_CLASSF_GOOPS_OR_VALID): Remove obsolete
  definitions.
  (SCM_IS_A_P): Use the scm_class_of function.
* libguile/goops.c (var_class_of_obsolete_indirect_instance): Rename
  from var_migrate_instance.
  (scm_is_generic, scm_is_method, scm_sys_init_layout_x): Use
  scm_class_of instead of the SCM_CLASS_OF macro.
  (get_indirect_slots): New helper.
  (scm_class_of): This patch moves us in a direction where we won't be
  able to separately address a struct's data and its identity.
  Therefore to check whether a class needs migration, we check an
  embedded pointer from a slot instead of the vtable data.
  (scm_sys_struct_data): Remove this temporary function.
  (scm_sys_modify_instance): Update to swap slot values instead of the
  data pointers themselves.
  (scm_sys_modify_class): Use scm_sys_modify_instance.
  (scm_sys_goops_loaded): Capture class-of-obsolete-indirect-instance
  instead of migrate-instance.
  (scm_init_goops_builtins): Don't export the "valid" flag any more;
  export instead the "indirect" and "needs-migration" flags.
* libguile/foreign-object.c (scm_assert_foreign_object_type): Add a
  FIXME.
* libguile/vm-engine.c (class-of): Take away fast path for the time
  being.
* module/oop/goops.scm (class-has-indirect-instances?)
  (indirect-slots-need-migration?): New helpers.
  (<class>, <slot>, %class-slot-definition, initialize): Remove use of
  vtable-flag-goops-valid.
  (define-class): Always push redefined values through
  `class-redefinition'.
  (<redefinable-class>): New public definition.  Use it as a metaclass
  for redefinable classes.  Provide a compute-slots function that
  declares the indirect slots mechanism.  Add the "indirect" flag to
  instances of <redefinable-class>.  Create indirect-slots objects for
  instances of those classes as part of their allocate-instance.
  (change-object-class, class-of-obsolete-indirect-instance): Update for
  new representation change.
* test-suite/tests/goops.test ("object update"): Add #:metaclass
  <redefinable-class> to all redefinable classes.  For the "hell" test,
  make the new classes with class-direct-slots, not class-slots; this
  was an error in the test.
This commit is contained in:
Andy Wingo 2017-09-08 10:44:54 +02:00
parent 5c8bb13630
commit 4898959901
7 changed files with 472 additions and 287 deletions
Download patch file Download diff file Expand all files Collapse all files

1
libguile/foreign-object.c
View file

@ -58,6 +58,7 @@ scm_make_foreign_object_type (SCM name, SCM slot_names,
void void
scm_assert_foreign_object_type (SCM type, SCM val) scm_assert_foreign_object_type (SCM type, SCM val)
{ {
/* FIXME: Add fast path for when type == struct vtable */
if (!SCM_IS_A_P (val, type)) if (!SCM_IS_A_P (val, type))
scm_error (scm_arg_type_key, NULL, "Wrong type (expecting ~A): ~S", scm_error (scm_arg_type_key, NULL, "Wrong type (expecting ~A): ~S",
scm_list_2 (scm_class_name (type), val), scm_list_1 (val)); scm_list_2 (scm_class_name (type), val), scm_list_1 (val));

118
libguile/goops.c
View file

@ -68,7 +68,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
static int goops_loaded_p = 0; static int goops_loaded_p = 0;
static SCM var_make_standard_class = SCM_BOOL_F; static SCM var_make_standard_class = SCM_BOOL_F;
static SCM var_migrate_instance = SCM_BOOL_F; static SCM var_class_of_obsolete_indirect_instance = SCM_BOOL_F;
static SCM var_make = SCM_BOOL_F; static SCM var_make = SCM_BOOL_F;
static SCM var_inherit_applicable = SCM_BOOL_F; static SCM var_inherit_applicable = SCM_BOOL_F;
static SCM var_class_name = SCM_BOOL_F; static SCM var_class_name = SCM_BOOL_F;
@ -174,8 +174,8 @@ SCM_DEFINE (scm_sys_init_layout_x, "%init-layout!", 2, 0, 0,
SCM_VALIDATE_STRING (2, layout); SCM_VALIDATE_STRING (2, layout);
SCM_SET_VTABLE_LAYOUT (class, scm_make_struct_layout (layout)); SCM_SET_VTABLE_LAYOUT (class, scm_make_struct_layout (layout));
scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class); scm_i_struct_inherit_vtable_magic (scm_class_of (class), class);
SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID); SCM_SET_CLASS_FLAGS (class, SCM_VTABLE_FLAG_GOOPS_CLASS);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
@ -184,6 +184,17 @@ SCM_DEFINE (scm_sys_init_layout_x, "%init-layout!", 2, 0, 0,
static SCM
get_indirect_slots (SCM x)
{
/* Precondition: X is an indirect instance. The indirect slots are in
the last field. */
scm_t_bits nfields =
SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (x), scm_vtable_index_size);
return SCM_STRUCT_SLOT_REF (x, nfields - 1);
}
/* This function is used for efficient type dispatch. */ /* This function is used for efficient type dispatch. */
SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
(SCM x), (SCM x),
@ -283,24 +294,34 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return ptob->output_class; return ptob->output_class;
} }
case scm_tcs_struct: case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
/* A GOOPS object with a valid class. */
return SCM_CLASS_OF (x);
else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
/* A GOOPS object whose class might have been redefined;
try to migrate it over to the new class. */
{ {
scm_call_1 (scm_variable_ref (var_migrate_instance), x); SCM vtable = SCM_STRUCT_VTABLE (x);
/* At this point, either the migration succeeded, in which scm_t_bits flags = SCM_VTABLE_FLAGS (vtable);
case SCM_CLASS_OF is the new class, or the migration scm_t_bits direct = SCM_VTABLE_FLAG_GOOPS_CLASS;
failed because it's already in progress on the current scm_t_bits indirect = direct | SCM_VTABLE_FLAG_GOOPS_INDIRECT;
thread, in which case we want to return the old class scm_t_bits mask = indirect;
for the time being. SCM_CLASS_OF (x) is the right if ((flags & mask) == direct)
answer for both cases. */ /* A direct GOOPS object. */
return SCM_CLASS_OF (x); return vtable;
else if ((flags & mask) == indirect)
/* An indirect GOOPS object. If the vtable of the slots
object is flagged to indicate that there's a new class
definition available, migrate the instance before
returning the class. */
{
SCM slots = get_indirect_slots (x);
scm_t_bits slot_flags = SCM_OBJ_CLASS_FLAGS (slots);
if (slot_flags & SCM_VTABLE_FLAG_GOOPS_NEEDS_MIGRATION)
return scm_call_1
(scm_variable_ref (var_class_of_obsolete_indirect_instance),
x);
else
return vtable;
} }
else else
return scm_i_define_class_for_vtable (SCM_CLASS_OF (x)); /* A non-GOOPS struct. */
return scm_i_define_class_for_vtable (vtable);
}
default: default:
if (scm_is_pair (x)) if (scm_is_pair (x))
return class_pair; return class_pair;
@ -334,13 +355,13 @@ SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
int int
scm_is_generic (SCM x) scm_is_generic (SCM x)
{ {
return SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), class_generic); return SCM_INSTANCEP (x) && SCM_SUBCLASSP (scm_class_of (x), class_generic);
} }
int int
scm_is_method (SCM x) scm_is_method (SCM x)
{ {
return SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), class_method); return SCM_INSTANCEP (x) && SCM_SUBCLASSP (scm_class_of (x), class_method);
} }
@ -483,38 +504,39 @@ SCM_DEFINE (scm_sys_clear_fields_x, "%clear-fields!", 2, 0, 0,
static scm_i_pthread_mutex_t goops_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; static scm_i_pthread_mutex_t goops_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
SCM_INTERNAL SCM scm_sys_struct_data (SCM);
SCM_DEFINE (scm_sys_struct_data, "%struct-data", 1, 0, 0,
(SCM s),
"Internal function used when migrating classes")
#define FUNC_NAME s_scm_sys_struct_data
{
SCM_VALIDATE_INSTANCE (1, s);
return scm_from_uintptr_t (SCM_CELL_WORD_1 (s));
}
#undef FUNC_NAME
SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0, SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
(SCM old, SCM new), (SCM old, SCM new),
"Used by change-class to modify objects in place.") "Used by change-class to modify objects in place.")
#define FUNC_NAME s_scm_sys_modify_instance #define FUNC_NAME s_scm_sys_modify_instance
{ {
scm_t_bits i, old_nfields, new_nfields;
SCM_VALIDATE_INSTANCE (1, old); SCM_VALIDATE_INSTANCE (1, old);
SCM_VALIDATE_INSTANCE (2, new); SCM_VALIDATE_INSTANCE (2, new);
old_nfields = SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (old),
scm_vtable_index_size);
new_nfields = SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (new),
scm_vtable_index_size);
SCM_ASSERT (old_nfields == new_nfields, new, SCM_ARG2, FUNC_NAME);
/* Exchange the data contained in old and new. We exchange rather than /* Exchange the data contained in old and new. We exchange rather than
* scratch the old value with new to be correct with GC. * scratch the old value with new to be correct with GC.
* See "Class redefinition protocol above". * See "Class redefinition protocol above".
*/ */
scm_i_pthread_mutex_lock (&goops_lock); scm_i_pthread_mutex_lock (&goops_lock);
/* Swap vtables. */
{ {
scm_t_bits word0, word1; scm_t_bits tmp = SCM_CELL_WORD_0 (old);
word0 = SCM_CELL_WORD_0 (old);
word1 = SCM_CELL_WORD_1 (old);
SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new)); SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new)); SCM_SET_CELL_WORD_0 (new, tmp);
SCM_SET_CELL_WORD_0 (new, word0); }
SCM_SET_CELL_WORD_1 (new, word1); /* Swap data. */
for (i = 0; i < old_nfields; i++)
{
scm_t_bits tmp = SCM_STRUCT_DATA_REF (old, i);
SCM_STRUCT_DATA_SET (old, i, SCM_STRUCT_DATA_REF (new, i));
SCM_STRUCT_DATA_SET (new, i, tmp);
} }
scm_i_pthread_mutex_unlock (&goops_lock); scm_i_pthread_mutex_unlock (&goops_lock);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
@ -529,19 +551,10 @@ SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0,
SCM_VALIDATE_CLASS (1, old); SCM_VALIDATE_CLASS (1, old);
SCM_VALIDATE_CLASS (2, new); SCM_VALIDATE_CLASS (2, new);
scm_i_pthread_mutex_lock (&goops_lock); scm_sys_modify_instance (old, new);
{
scm_t_bits word0, word1;
word0 = SCM_CELL_WORD_0 (old);
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_self] = 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_self] = SCM_UNPACK (new); SCM_STRUCT_DATA (new)[scm_vtable_index_self] = SCM_UNPACK (new);
}
scm_i_pthread_mutex_unlock (&goops_lock);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -997,7 +1010,8 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0,
var_method_specializers = scm_c_lookup ("method-specializers"); var_method_specializers = scm_c_lookup ("method-specializers");
var_method_procedure = scm_c_lookup ("method-procedure"); var_method_procedure = scm_c_lookup ("method-procedure");
var_migrate_instance = scm_c_lookup ("migrate-instance"); var_class_of_obsolete_indirect_instance =
scm_c_lookup ("class-of-obsolete-indirect-instance");
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
@ -1020,12 +1034,14 @@ scm_init_goops_builtins (void *unused)
scm_from_int (SCM_VTABLE_FLAG_VALIDATED)); scm_from_int (SCM_VTABLE_FLAG_VALIDATED));
scm_c_define ("vtable-flag-goops-class", scm_c_define ("vtable-flag-goops-class",
scm_from_int (SCM_VTABLE_FLAG_GOOPS_CLASS)); scm_from_int (SCM_VTABLE_FLAG_GOOPS_CLASS));
scm_c_define ("vtable-flag-goops-valid",
scm_from_int (SCM_VTABLE_FLAG_GOOPS_VALID));
scm_c_define ("vtable-flag-goops-slot", scm_c_define ("vtable-flag-goops-slot",
scm_from_int (SCM_VTABLE_FLAG_GOOPS_SLOT)); scm_from_int (SCM_VTABLE_FLAG_GOOPS_SLOT));
scm_c_define ("vtable-flag-goops-static-slot-allocation", scm_c_define ("vtable-flag-goops-static-slot-allocation",
scm_from_int (SCM_VTABLE_FLAG_GOOPS_STATIC_SLOT_ALLOCATION)); scm_from_int (SCM_VTABLE_FLAG_GOOPS_STATIC_SLOT_ALLOCATION));
scm_c_define ("vtable-flag-goops-indirect",
scm_from_int (SCM_VTABLE_FLAG_GOOPS_INDIRECT));
scm_c_define ("vtable-flag-goops-needs-migration",
scm_from_int (SCM_VTABLE_FLAG_GOOPS_NEEDS_MIGRATION));
} }
void void

22
libguile/goops.h
View file

@ -40,10 +40,22 @@
* certain class or its subclasses when traversal of the inheritance * certain class or its subclasses when traversal of the inheritance
* graph would be too costly. * graph would be too costly.
*/ */
/* Set for all GOOPS classes. */
#define SCM_VTABLE_FLAG_GOOPS_CLASS SCM_VTABLE_FLAG_GOOPS_0 #define SCM_VTABLE_FLAG_GOOPS_CLASS SCM_VTABLE_FLAG_GOOPS_0
#define SCM_VTABLE_FLAG_GOOPS_VALID SCM_VTABLE_FLAG_GOOPS_1 /* Set for GOOPS classes whose instances are <slot> objects. */
#define SCM_VTABLE_FLAG_GOOPS_SLOT SCM_VTABLE_FLAG_GOOPS_2 #define SCM_VTABLE_FLAG_GOOPS_SLOT SCM_VTABLE_FLAG_GOOPS_1
#define SCM_VTABLE_FLAG_GOOPS_STATIC_SLOT_ALLOCATION SCM_VTABLE_FLAG_GOOPS_3 /* Set for GOOPS classes whose instance's slots must always be allocated
to the same indices, for all concrete subclasses. */
#define SCM_VTABLE_FLAG_GOOPS_STATIC_SLOT_ALLOCATION SCM_VTABLE_FLAG_GOOPS_2
/* Set for GOOPS classes whose instances are "indirect", meaning they
just have one slot that indirects to a direct instance with the
slots. For non-class instances, this is at struct slot 0. For class
instances, it's the first slot after the <class> fixed slots. */
#define SCM_VTABLE_FLAG_GOOPS_INDIRECT SCM_VTABLE_FLAG_GOOPS_3
/* For indirect classes, the slots object itself has a direct vtable.
This flag will be set on that vtable if the instance needs to migrate
to a new class. */
#define SCM_VTABLE_FLAG_GOOPS_NEEDS_MIGRATION SCM_VTABLE_FLAG_GOOPS_4
#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x) #define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
#define SCM_CLASS_FLAGS(class) (SCM_VTABLE_FLAGS (class)) #define SCM_CLASS_FLAGS(class) (SCM_VTABLE_FLAGS (class))
@ -52,9 +64,7 @@
#define SCM_CLEAR_CLASS_FLAGS(c, f) (SCM_CLEAR_VTABLE_FLAGS (c, f)) #define SCM_CLEAR_CLASS_FLAGS(c, f) (SCM_CLEAR_VTABLE_FLAGS (c, f))
#define SCM_CLASSF_METACLASS (SCM_VTABLE_FLAG_GOOPS_CLASS|SCM_VTABLE_FLAG_VTABLE) #define SCM_CLASSF_METACLASS (SCM_VTABLE_FLAG_GOOPS_CLASS|SCM_VTABLE_FLAG_VTABLE)
#define SCM_CLASSF_GOOPS_VALID SCM_VTABLE_FLAG_GOOPS_VALID
#define SCM_CLASSF_GOOPS SCM_VTABLE_FLAG_GOOPS_CLASS #define SCM_CLASSF_GOOPS SCM_VTABLE_FLAG_GOOPS_CLASS
#define SCM_CLASSF_GOOPS_OR_VALID (SCM_CLASSF_GOOPS | SCM_CLASSF_GOOPS_VALID)
#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x) #define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
@ -72,7 +82,7 @@
#define SCM_SUBCLASSP(c1, c2) \ #define SCM_SUBCLASSP(c1, c2) \
(scm_is_true (scm_c_memq (c2, scm_class_precedence_list (c1)))) (scm_is_true (scm_c_memq (c2, scm_class_precedence_list (c1))))
#define SCM_IS_A_P(x, c) \ #define SCM_IS_A_P(x, c) \
(SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), c)) (SCM_INSTANCEP (x) && SCM_SUBCLASSP (scm_class_of (x), c))
#define SCM_GENERICP(x) (scm_is_generic (x)) #define SCM_GENERICP(x) (scm_is_generic (x))
#define SCM_VALIDATE_GENERIC(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, GENERICP, "generic function") #define SCM_VALIDATE_GENERIC(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, GENERICP, "generic function")

12
libguile/struct.h
View file

@ -112,12 +112,12 @@
#define SCM_VTABLE_FLAG_SIMPLE_RW (1L << 7) /* instances of this vtable have only "pw" fields and no tail array */ #define SCM_VTABLE_FLAG_SIMPLE_RW (1L << 7) /* instances of this vtable have only "pw" fields and no tail array */
#define SCM_VTABLE_FLAG_RESERVED_0 (1L << 8) #define SCM_VTABLE_FLAG_RESERVED_0 (1L << 8)
#define SCM_VTABLE_FLAG_RESERVED_1 (1L << 9) #define SCM_VTABLE_FLAG_RESERVED_1 (1L << 9)
#define SCM_VTABLE_FLAG_RESERVED_2 (1L << 10) #define SCM_VTABLE_FLAG_SMOB_0 (1L << 10)
#define SCM_VTABLE_FLAG_SMOB_0 (1L << 11) #define SCM_VTABLE_FLAG_GOOPS_0 (1L << 11)
#define SCM_VTABLE_FLAG_GOOPS_0 (1L << 12) #define SCM_VTABLE_FLAG_GOOPS_1 (1L << 12)
#define SCM_VTABLE_FLAG_GOOPS_1 (1L << 13) #define SCM_VTABLE_FLAG_GOOPS_2 (1L << 13)
#define SCM_VTABLE_FLAG_GOOPS_2 (1L << 14) #define SCM_VTABLE_FLAG_GOOPS_3 (1L << 14)
#define SCM_VTABLE_FLAG_GOOPS_3 (1L << 15) #define SCM_VTABLE_FLAG_GOOPS_4 (1L << 15)
#define SCM_VTABLE_USER_FLAG_SHIFT 16 #define SCM_VTABLE_USER_FLAG_SHIFT 16
typedef void (*scm_t_struct_finalize) (SCM obj); typedef void (*scm_t_struct_finalize) (SCM obj);

3
libguile/vm-engine.c
View file

@ -2905,8 +2905,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
VM_DEFINE_OP (113, class_of, "class-of", OP1 (X8_S12_S12) | OP_DST) VM_DEFINE_OP (113, class_of, "class-of", OP1 (X8_S12_S12) | OP_DST)
{ {
ARGS1 (obj); ARGS1 (obj);
if (SCM_INSTANCEP (obj)) /* FIXME: restore fast path for direct instances. */
RETURN (SCM_CLASS_OF (obj));
RETURN_EXP (scm_class_of (obj)); RETURN_EXP (scm_class_of (obj));
} }

550
module/oop/goops.scm
View file

@ -46,6 +46,9 @@
<protected-hidden-slot> <protected-read-only-slot> <protected-hidden-slot> <protected-read-only-slot>
<scm-slot> <int-slot> <float-slot> <double-slot> <scm-slot> <int-slot> <float-slot> <double-slot>
;; Redefinable classes.
<redefinable-class>
;; Methods are implementations of generic functions. ;; Methods are implementations of generic functions.
<method> <accessor-method> <method> <accessor-method>
@ -250,9 +253,11 @@
;;; a vtable are themselves vtables, and `vtable-flag-validated' ;;; a vtable are themselves vtables, and `vtable-flag-validated'
;;; indicates that the struct's layout has been validated. goops.c ;;; indicates that the struct's layout has been validated. goops.c
;;; defines a few additional flags: one to indicate that a vtable is ;;; defines a few additional flags: one to indicate that a vtable is
;;; actually a class, one to indicate that the class is "valid" (meaning ;;; actually a class, one to indicate that instances of a class are slot
;;; that it hasn't been redefined), and one to indicate that instances ;;; definition objects (<slot> instances), one to indicate that this
;;; of a class are slot definition objects (<slot> instances). ;;; class has "static slot allocation" (meaning that its slots must
;;; always be allocated to the same indices in all subclasses), and two
;;; more flags used for redefinable classes (more below).
;;; ;;;
(define vtable-flag-goops-metaclass (define vtable-flag-goops-metaclass
(logior vtable-flag-vtable vtable-flag-goops-class)) (logior vtable-flag-vtable vtable-flag-goops-class))
@ -282,6 +287,12 @@
(define (class-has-statically-allocated-slots? class) (define (class-has-statically-allocated-slots? class)
(class-has-flags? class vtable-flag-goops-static-slot-allocation)) (class-has-flags? class vtable-flag-goops-static-slot-allocation))
(define (class-has-indirect-instances? class)
(class-has-flags? class vtable-flag-goops-indirect))
(define (indirect-slots-need-migration? slots)
(class-has-flags? (struct-vtable slots) vtable-flag-goops-needs-migration))
;;; ;;;
;;; Now that we know the slots that must be present in classes, and ;;; Now that we know the slots that must be present in classes, and
;;; their offsets, we can create the root of the class hierarchy. ;;; their offsets, we can create the root of the class hierarchy.
@ -311,8 +322,7 @@
(let* ((layout (fold-class-slots macro-fold-right cons-layout "")) (let* ((layout (fold-class-slots macro-fold-right cons-layout ""))
(nfields (/ (string-length layout) 2)) (nfields (/ (string-length layout) 2))
(<class> (%make-vtable-vtable layout))) (<class> (%make-vtable-vtable layout)))
(class-add-flags! <class> (logior vtable-flag-goops-class (class-add-flags! <class> vtable-flag-goops-class)
vtable-flag-goops-valid))
(struct-set! <class> class-index-name '<class>) (struct-set! <class> class-index-name '<class>)
(struct-set! <class> class-index-nfields nfields) (struct-set! <class> class-index-nfields nfields)
(struct-set! <class> class-index-direct-supers '()) (struct-set! <class> class-index-direct-supers '())
@ -422,8 +432,7 @@ followed by its associated value. If @var{l} does not hold a value for
(nfields (/ (string-length layout) 2)) (nfields (/ (string-length layout) 2))
(<slot> (make-struct/no-tail <class> (make-struct-layout layout)))) (<slot> (make-struct/no-tail <class> (make-struct-layout layout))))
(class-add-flags! <slot> (logior vtable-flag-goops-class (class-add-flags! <slot> (logior vtable-flag-goops-class
vtable-flag-goops-slot vtable-flag-goops-slot))
vtable-flag-goops-valid))
(struct-set! <slot> class-index-name '<slot>) (struct-set! <slot> class-index-name '<slot>)
(struct-set! <slot> class-index-nfields nfields) (struct-set! <slot> class-index-nfields nfields)
(struct-set! <slot> class-index-direct-supers '()) (struct-set! <slot> class-index-direct-supers '())
@ -1094,8 +1103,7 @@ function."
(#:body body ()) (#:body body ())
(#:make-procedure make-procedure #f)))) (#:make-procedure make-procedure #f))))
((memq <class> (class-precedence-list class)) ((memq <class> (class-precedence-list class))
(class-add-flags! z (logior vtable-flag-goops-class (class-add-flags! z vtable-flag-goops-class)
vtable-flag-goops-valid))
(for-each (match-lambda (for-each (match-lambda
((kw slot default) ((kw slot default)
(slot-set! z slot (get-keyword kw args default)))) (slot-set! z slot (get-keyword kw args default))))
@ -1112,18 +1120,6 @@ function."
;;; ;;;
;;; Slot access. ;;; Slot access.
;;; ;;;
;;; Before we go on, some notes about class redefinition. In GOOPS,
;;; classes can be redefined. Redefinition of a class marks the class
;;; as invalid, and instances will be lazily migrated over to the new
;;; representation as they are accessed. Migration happens when
;;; `class-of' is called on an instance. For more technical details on
;;; object redefinition, see struct.h.
;;;
;;; In the following interfaces, class-of handles the redefinition
;;; protocol. I would think though that there is some thread-unsafety
;;; here though as the { class, object data } pair needs to be accessed
;;; atomically, not the { class, object } pair.
;;;
(define-inlinable (%class-slot-definition class slot-name kt kf) (define-inlinable (%class-slot-definition class slot-name kt kf)
(let lp ((slots (struct-ref class class-index-slots))) (let lp ((slots (struct-ref class class-index-slots)))
(match slots (match slots
@ -1716,12 +1712,12 @@ function."
(define-syntax-rule (define-class name supers slot ...) (define-syntax-rule (define-class name supers slot ...)
(begin (begin
(define-class-pre-definitions (slot ...)) (define-class-pre-definitions (slot ...))
(if (and (defined? 'name) (let ((cls (class supers slot ... #:name 'name)))
(is-a? name <class>) (toplevel-define!
(memq <object> (class-precedence-list name))) 'name
(class-redefinition name (if (defined? 'name)
(class supers slot ... #:name 'name)) (class-redefinition name cls)
(toplevel-define! 'name (class supers slot ... #:name 'name))))) cls)))))
(define-syntax-rule (standard-define-class arg ...) (define-syntax-rule (standard-define-class arg ...)
(define-class arg ...)) (define-class arg ...))
@ -2516,115 +2512,6 @@ function."
slots) slots)
clone)) clone))
;;;
;;; {Class redefinition utilities}
;;;
;;; (class-redefinition OLD NEW)
;;;
;;; Has correct the following conditions:
;;; Methods
;;;
;;; 1. New accessor specializers refer to new header
;;;
;;; Classes
;;;
;;; 1. New class cpl refers to the new class header
;;; 2. Old class header exists on old super classes direct-subclass lists
;;; 3. New class header exists on new super classes direct-subclass lists
(define-method (class-redefinition (old <class>) (new <class>))
;; Work on direct methods:
;; 1. Remove accessor methods from the old class
;; 2. Patch the occurences of new in the specializers by old
;; 3. Displace the methods from old to new
(remove-class-accessors! old) ;; -1-
(let ((methods (class-direct-methods new)))
(for-each (lambda (m)
(update-direct-method! m new old)) ;; -2-
methods)
(struct-set! new
class-index-direct-methods
(append methods (class-direct-methods old))))
;; Substitute old for new in new cpl
(set-car! (struct-ref new class-index-cpl) old)
;; Remove the old class from the direct-subclasses list of its super classes
(for-each (lambda (c) (struct-set! c class-index-direct-subclasses
(delv! old (class-direct-subclasses c))))
(class-direct-supers old))
;; Replace the new class with the old in the direct-subclasses of the supers
(for-each (lambda (c)
(struct-set! c class-index-direct-subclasses
(cons old (delv! new (class-direct-subclasses c)))))
(class-direct-supers new))
;; Swap object headers
(%modify-class old new)
;; Now old is NEW!
;; Redefine all the subclasses of old to take into account modification
(for-each
(lambda (c)
(update-direct-subclass! c new old))
(class-direct-subclasses new))
;; Invalidate class so that subsequent instances slot accesses invoke
;; change-object-class
(struct-set! new class-index-redefined old)
(class-clear-flags! new vtable-flag-goops-valid) ;must come after slot-set!
old)
;;;
;;; remove-class-accessors!
;;;
(define-method (remove-class-accessors! (c <class>))
(for-each (lambda (m)
(when (is-a? m <accessor-method>)
(let ((gf (slot-ref m 'generic-function)))
;; remove the method from its GF
(slot-set! gf 'methods
(delq1! m (slot-ref gf 'methods)))
(invalidate-method-cache! gf)
;; remove the method from its specializers
(remove-method-in-classes! m))))
(class-direct-methods c)))
;;;
;;; update-direct-method!
;;;
(define-method (update-direct-method! (m <method>)
(old <class>)
(new <class>))
(let loop ((l (method-specializers m)))
;; Note: the <top> in dotted list is never used.
;; So we can work as if we had only proper lists.
(when (pair? l)
(when (eqv? (car l) old)
(set-car! l new))
(loop (cdr l)))))
;;;
;;; update-direct-subclass!
;;;
(define-method (update-direct-subclass! (c <class>)
(old <class>)
(new <class>))
(class-redefinition c
(make-class (class-direct-supers c)
(class-direct-slots c)
#:name (class-name c)
#:metaclass (class-of c))))
;;; ;;;
;;; {Utilities for INITIALIZE methods} ;;; {Utilities for INITIALIZE methods}
;;; ;;;
@ -2807,8 +2694,7 @@ var{initargs}."
(compute-direct-slot-definition class initargs))) (compute-direct-slot-definition class initargs)))
(next-method) (next-method)
(class-add-flags! class (logior vtable-flag-goops-class (class-add-flags! class vtable-flag-goops-class)
vtable-flag-goops-valid))
(struct-set! class class-index-name (get-keyword #:name initargs '???)) (struct-set! class class-index-name (get-keyword #:name initargs '???))
(struct-set! class class-index-nfields 0) (struct-set! class class-index-nfields 0)
(struct-set! class class-index-direct-supers (struct-set! class class-index-direct-supers
@ -2897,68 +2783,6 @@ var{initargs}."
(slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f))) (slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f)))
;;;
;;; {Change-class}
;;;
(define (change-object-class old-instance old-class new-class)
(let ((new-instance (allocate-instance new-class '())))
;; Initialize the slots of the new instance
(for-each
(lambda (slot)
(if (and (slot-exists? old-instance slot)
(eq? (%slot-definition-allocation
(class-slot-definition old-class slot))
#:instance)
(slot-bound? old-instance slot))
;; Slot was present and allocated in old instance; copy it
(slot-set! new-instance slot (slot-ref old-instance slot))
;; slot was absent; initialize it with its default value
(let ((init (slot-init-function new-class slot)))
(when init
(slot-set! new-instance slot (init))))))
(map slot-definition-name (class-slots new-class)))
;; Exchange old and new instance in place to keep pointers valid
(%modify-instance old-instance new-instance)
;; Allow class specific updates of instances (which now are swapped)
(update-instance-for-different-class new-instance old-instance)
old-instance))
(define-method (update-instance-for-different-class (old-instance <object>)
(new-instance
<object>))
;;not really important what we do, we just need a default method
new-instance)
(define-method (change-class (old-instance <object>) (new-class <class>))
(change-object-class old-instance (class-of old-instance) new-class))
(define migrate-instance
(let ((lock (make-mutex))
(stack '()))
(lambda (instance)
(let ((key (%struct-data instance)))
(let/ec return
(dynamic-wind
(lambda ()
(with-mutex lock
(if (memv key stack)
(return #f)
(set! stack (cons key stack)))))
(lambda ()
(let* ((old-class (struct-vtable instance))
(new-class (slot-ref old-class 'redefined)))
;; Although migrate-indirect-instance-if-needed should
;; only be called if the "valid" flag is not present on
;; the old-class, it's possible that multiple threads can
;; race, so we need to check again here.
(when new-class
(change-class instance new-class))))
(lambda ()
(with-mutex lock
(set! stack (delq! key stack))))))))))
;;; ;;;
;;; {make} ;;; {make}
;;; ;;;
@ -3077,6 +2901,332 @@ var{initargs}."
no-method no-method
)) ))
;;;
;;; Class redefinition
;;;
;;; GOOPS has a facility to allow a user to change the definition of
;;; class. This will cause instances of that class to lazily migrate
;;; over to the new definition. Implementing this is tricky because
;;; identity is a fundamental part of object-oriented programming; you
;;; can't just make a new class and start using it, just like that. In
;;; GOOPS, classes are objects too and need to be addressable by
;;; identity (by `eq?'). Classes need the ability to change their
;;; definition "in place". The same goes for instances; redefining a
;;; class might change the amount of storage associated with each
;;; instance, and yet we need to update the instances in place, and
;;; without having classes maintain a list of all of their instances.
;;;
;;; The way that we implement this is by adding an indirection. An
;;; instance of a redefinable class becomes a small object containing
;;; only a single field, a reference to an external "slots" objects that
;;; holds the actual slots. There is an exception however for objects
;;; that have statically allocated slots, most importantly classes -- in
;;; that case the indirected slots are allocated "directly" in the
;;; object.
;;;
;;; Instances update by checking the class of their their indirected
;;; slots object. In addition to describing the slots of the indirected
;;; slots object, that slots class (which is a direct class) has a
;;; "redefined" slot. If the indirect slots object is current, this
;;; value is #f. Otherwise it points to the old class definition
;;; corresponding to its instances.
;;;
;;; To try to clarify things, here is a diagram of the "normal" state of
;;; affairs. The redefinable class has an associated slots class. When
;;; it makes instances, the instances have a pointer to the indirect
;;; "slots" object. The class of the indirect slots object is the slots
;;; class associated with the instance's class. The "V" arrows indicate
;;; a vtable (class-of) relationship. Dashed arrows indicate a reference
;;; from a struct slot to an object.
;;;
;;; Initial state.
;;; +-------------+ +------------------------------+
;;; | class ----> slots class, redefined: #f |
;;; +-V-----------+ +-V----------------------------+
;;; V V
;;; +-V-----------+ +-V----------------------------+
;;; | instance ----> slots ... |
;;; +-------------+ +------------------------------+
;;;
;;; When a class is redefined, it is updated in place. However existing
;;; instances are only migrated lazily. So after a class has been
;;; redefined but before the instance has been updated, the state looks
;;; like this:
;;;
;;; Redefined state.
;;; ,-------------------------------------------.
;;; | |
;;; +-v-----------+ +----------------------------|-+
;;; | old class ----> old slots class, redefined:' VVV
;;; +-------------+ +------------------------------+ V
;;; V
;;; +-------------+ +------------------------------+ V
;;; | new class ----> new slots class, redefined:#f| V
;;; +-V-----------+ +------------------------------+ V
;;; V V
;;; +-V-----------+ +------------------------------+ V
;;; | old inst ----> slots ... VVV
;;; +-------------+ +------------------------------+
;;;
;;; That is to say, because the class was updated in place, the old
;;; instance's vtable is the new class, even though the old instance's
;;; slots still correspond to the old class. The vtable of the old slots
;;; has the "redefined" field, which has been set to point to a fresh
;;; object containing the direct slots of the old class, and a pointer to
;;; the old slots class -- as if it were the old class, but with a new
;;; temporary identity. This allows us to then call
;;;
;;; (change-object-class obj old-class new-class)
;;;
;;; which will allocate a fresh slots object for the old instance
;;; corresponding to the new class, completing the migration for that
;;; instance.
;;;
;;; Lazy instance migration is triggered by "class-of". Calling
;;; "class-of" on an indirect instance will check the indirect slots to
;;; see if they need redefinition. If so, we construct a fresh instance
;;; of the new class and swap fields with the old instance (including
;;; the indirect-slots field). Unfortunately there is some
;;; thread-unsafety here, as retrieving the class is unsynchronized with
;;; retrieving the indirect slots.
;;;
(define-class <indirect-slots-class> (<class>)
(%redefined #:init-value #f))
(define-class <redefinable-class> (<class>)
(indirect-slots-class))
(define-method (compute-slots (class <redefinable-class>))
(let* ((slots (next-method))
;; The base method ensured that at most one superclass has
;; statically allocated slots.
(static-slots
(match (filter class-has-statically-allocated-slots?
(cdr (class-precedence-list class)))
(() '())
((class) (struct-ref class class-index-direct-slots)))))
(define (simplify-slot-definition s)
;; Here we take a slot definition and strip it to just be a plain
;; old name, suitable for use as a slot for the plain-old-data
;; indirect-slots class.
(and (eq? (slot-definition-allocation s) #:instance)
(make (class-of s) #:name (slot-definition-name s))))
(define (maybe-make-indirect-slot-definition s)
;; Here we copy over all the frippery of a slot definition
;; (accessors, init-keywords, and so on), but we change the slot
;; to have virtual allocation and we provide explicit
;; slot-ref/slot-set! functions that access the slot value through
;; the indirect slots object. For slot definitions without
;; instance allocation though, we just pass them through.
(cond
((eq? (slot-definition-allocation s) #:instance)
(let* ((s* (class-slot-definition (slot-ref class 'indirect-slots-class)
(slot-definition-name s)))
(ref (slot-definition-slot-ref/raw s*))
(set! (slot-definition-slot-set! s*)))
(make (class-of s) #:name (slot-definition-name s)
#:getter (slot-definition-getter s)
#:setter (slot-definition-setter s)
#:accessor (slot-definition-accessor s)
#:init-keyword (slot-definition-init-keyword s)
#:init-thunk (slot-definition-init-thunk s)
#:allocation #:virtual
;; TODO: Make faster.
#:slot-ref (lambda (o)
(ref (slot-ref o 'indirect-slots)))
#:slot-set! (lambda (o v)
(set! (slot-ref o 'indirect-slots) v)))))
(else s)))
(unless (equal? (list-head slots (length static-slots))
static-slots)
(error "unexpected slots"))
(let* ((indirect-slots (list-tail slots (length static-slots)))
(indirect-slots-class
(make-class '()
(filter-map simplify-slot-definition
indirect-slots)
#:name 'indirect-slots
#:metaclass <indirect-slots-class>)))
(slot-set! class 'indirect-slots-class indirect-slots-class)
(append static-slots
(cons (make <slot> #:name 'indirect-slots)
(map maybe-make-indirect-slot-definition
indirect-slots))))))
(define-method (initialize (class <redefinable-class>) initargs)
(next-method)
(class-add-flags! class vtable-flag-goops-indirect))
(define-method (allocate-instance (class <redefinable-class>) initargs)
(let ((instance (next-method))
(nfields (struct-ref class class-index-nfields))
(indirect-slots-class (slot-ref class 'indirect-slots-class)))
;; Indirect slots will be last struct field.
(struct-set! instance (1- nfields) (make indirect-slots-class))
instance))
;; Called when redefining an existing binding, and the new binding is a
;; class. Two arguments: the old value, and the new.
(define-generic class-redefinition)
(define-method (class-redefinition (old <top>) (new <class>))
;; Default class-redefinition method is to just replace old binding
;; with the class.
new)
(define-method (class-redefinition (old <redefinable-class>)
(new <redefinable-class>))
;; When redefining a redefinable class with a redefinable class, we
;; migrate the old definition and its instances to become the new
;; definition.
;;
;; Work on direct methods:
;; 1. Remove accessor methods from the old class
;; 2. Patch the occurences of new in the specializers by old
;; 3. Displace the methods from old to new
(remove-class-accessors! old) ;; -1-
(let ((methods (class-direct-methods new)))
(for-each (lambda (m)
(update-direct-method! m new old)) ;; -2-
methods)
(struct-set! new
class-index-direct-methods
(append methods (class-direct-methods old))))
;; Substitute old for new in new cpl
(set-car! (struct-ref new class-index-cpl) old)
;; Remove the old class from the direct-subclasses list of its super classes
(for-each (lambda (c) (struct-set! c class-index-direct-subclasses
(delv! old (class-direct-subclasses c))))
(class-direct-supers old))
;; Replace the new class with the old in the direct-subclasses of the supers
(for-each (lambda (c)
(struct-set! c class-index-direct-subclasses
(cons old (delv! new (class-direct-subclasses c)))))
(class-direct-supers new))
;; Swap object headers
(%modify-class old new)
;; Now old is NEW!
;; Redefine all the subclasses of old to take into account modification
(for-each
(lambda (c)
(update-direct-subclass! c new old))
(class-direct-subclasses new))
;; Invalidate class so that subsequent instance slot accesses invoke
;; change-object-class
(let ((slots-class (slot-ref new 'indirect-slots-class)))
(slot-set! slots-class '%redefined new)
(class-add-flags! slots-class vtable-flag-goops-needs-migration))
old)
(define-method (remove-class-accessors! (c <class>))
(for-each (lambda (m)
(when (is-a? m <accessor-method>)
(let ((gf (slot-ref m 'generic-function)))
;; remove the method from its GF
(slot-set! gf 'methods
(delq1! m (slot-ref gf 'methods)))
(invalidate-method-cache! gf)
;; remove the method from its specializers
(remove-method-in-classes! m))))
(class-direct-methods c)))
(define-method (update-direct-method! (m <method>)
(old <class>)
(new <class>))
(let loop ((l (method-specializers m)))
;; Note: the <top> in dotted list is never used.
;; So we can work as if we had only proper lists.
(when (pair? l)
(when (eqv? (car l) old)
(set-car! l new))
(loop (cdr l)))))
(define-method (update-direct-subclass! (c <class>)
(old <class>)
(new <class>))
(class-redefinition c
(make-class (class-direct-supers c)
(class-direct-slots c)
#:name (class-name c)
#:metaclass (class-of c))))
(define (change-object-class old-instance old-class new-class)
(let ((new-instance (allocate-instance new-class '())))
;; Initialize the slots of the new instance
(for-each
(lambda (slot)
(unless (eq? slot 'indirect-slots)
(if (and (slot-exists? old-instance slot)
(memq (%slot-definition-allocation
(class-slot-definition old-class slot))
'(#:instance #:virtual))
(slot-bound? old-instance slot))
;; Slot was present and allocated in old instance; copy it
(slot-set! new-instance slot (slot-ref old-instance slot))
;; slot was absent; initialize it with its default value
(let ((init (slot-init-function new-class slot)))
(when init
(slot-set! new-instance slot (init)))))))
(map slot-definition-name (class-slots new-class)))
;; Exchange old and new instance in place to keep pointers valid
(%modify-instance old-instance new-instance)
;; Allow class specific updates of instances (which now are swapped)
(update-instance-for-different-class new-instance old-instance)
old-instance))
(define-method (update-instance-for-different-class (old-instance <object>)
(new-instance
<object>))
;;not really important what we do, we just need a default method
new-instance)
(define-method (change-class (old-instance <object>)
(new-class <redefinable-class>))
(unless (is-a? (class-of old-instance) <redefinable-class>)
(error (string-append
"Default change-class implementation only works on"
" instances of redefinable classes")))
(change-object-class old-instance (class-of old-instance) new-class))
(define class-of-obsolete-indirect-instance
(let ((lock (make-mutex))
(stack '()))
(lambda (instance)
(let* ((new-class (struct-vtable instance))
(nfields (struct-ref new-class class-index-nfields))
;; Indirect slots are in last instance slot. For normal
;; instances last slot is 0 of course.
(slots (struct-ref instance (1- nfields)))
(old-class (slot-ref (class-of slots) '%redefined)))
(let/ec return
(dynamic-wind
(lambda ()
(with-mutex lock
(if (memv slots stack)
(return (or old-class new-class))
(set! stack (cons slots stack)))))
(lambda ()
(when old-class
(change-class instance new-class))
new-class)
(lambda ()
(with-mutex lock
(set! stack (delq! slots stack))))))))))
;;; ;;;
;;; {Final initialization} ;;; {Final initialization}
;;; ;;;

29
test-suite/tests/goops.test
View file

@ -338,7 +338,8 @@
(pass-if "defining class" (pass-if "defining class"
(eval '(define-class <foo> () (eval '(define-class <foo> ()
(x #:accessor x #:init-value 123) (x #:accessor x #:init-value 123)
(z #:accessor z #:init-value 789)) (z #:accessor z #:init-value 789)
#:metaclass <redefinable-class>)
(current-module)) (current-module))
(eval '(is-a? <foo> <class>) (current-module))) (eval '(is-a? <foo> <class>) (current-module)))
(pass-if "making instance" (pass-if "making instance"
@ -348,14 +349,19 @@
(eval '(define-class <foo> () (eval '(define-class <foo> ()
(x #:accessor x #:init-value 123) (x #:accessor x #:init-value 123)
(y #:accessor y #:init-value 456) (y #:accessor y #:init-value 456)
(z #:accessor z #:init-value 789)) (z #:accessor z #:init-value 789)
#:metaclass <redefinable-class>)
(current-module)) (current-module))
(eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module))) (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module)))
(pass-if "changing class" (pass-if "changing class"
(let* ((c1 (class () (the-slot #:init-keyword #:value))) (let* ((c1 (class ()
(c2 (class () (the-slot #:init-keyword #:value) (the-slot #:init-keyword #:value)
(the-other-slot #:init-value 888))) #:metaclass <redefinable-class>))
(c2 (class ()
(the-slot #:init-keyword #:value)
(the-other-slot #:init-value 888)
#:metaclass <redefinable-class>))
(o1 (make c1 #:value 777))) (o1 (make c1 #:value 777)))
(and (is-a? o1 c1) (and (is-a? o1 c1)
(not (is-a? o1 c2)) (not (is-a? o1 c2))
@ -373,7 +379,8 @@
;; array, leading to out-of-bounds accesses. ;; array, leading to out-of-bounds accesses.
(let* ((parent-class (class () (let* ((parent-class (class ()
#:name '<class-that-will-be-redefined>)) #:name '<class-that-will-be-redefined>
#:metaclass <redefinable-class>))
(classes (classes
(unfold (lambda (i) (>= i 20)) (unfold (lambda (i) (>= i 20))
(lambda (i) (lambda (i)
@ -383,7 +390,8 @@
#:name (string->symbol #:name (string->symbol
(string-append "<foo-to-redefine-" (string-append "<foo-to-redefine-"
(number->string i) (number->string i)
">")))) ">"))
#:metaclass <redefinable-class>))
(lambda (i) (lambda (i)
(+ 1 i)) (+ 1 i))
0)) 0))
@ -393,7 +401,7 @@
classes))) classes)))
(define-method (change-class (foo parent-class) (define-method (change-class (foo parent-class)
(new <class>)) (new <redefinable-class>))
;; Called by `scm_change_object_class ()', via `purgatory ()'. ;; Called by `scm_change_object_class ()', via `purgatory ()'.
(if (null? classes) (if (null? classes)
(next-method) (next-method)
@ -407,8 +415,9 @@
;; nested `scm_change_object_class ()' calls, which increases ;; nested `scm_change_object_class ()' calls, which increases
;; the size of HELL and increments N_HELL. ;; the size of HELL and increments N_HELL.
(class-redefinition class (class-redefinition class
(make-class '() (class-slots class) (make-class '() (class-direct-slots class)
#:name (class-name class))) #:name (class-name class)
#:metaclass <redefinable-class>))
;; Use `slot-ref' to trigger the `scm_change_object_class ()' ;; Use `slot-ref' to trigger the `scm_change_object_class ()'
;; and `go_to_hell ()' calls. ;; and `go_to_hell ()' calls.