mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +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));

128
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. */ SCM vtable = SCM_STRUCT_VTABLE (x);
return SCM_CLASS_OF (x); scm_t_bits flags = SCM_VTABLE_FLAGS (vtable);
else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS) scm_t_bits direct = SCM_VTABLE_FLAG_GOOPS_CLASS;
/* A GOOPS object whose class might have been redefined; scm_t_bits indirect = direct | SCM_VTABLE_FLAG_GOOPS_INDIRECT;
try to migrate it over to the new class. */ scm_t_bits mask = indirect;
{ if ((flags & mask) == direct)
scm_call_1 (scm_variable_ref (var_migrate_instance), x); /* A direct GOOPS object. */
/* At this point, either the migration succeeded, in which return vtable;
case SCM_CLASS_OF is the new class, or the migration else if ((flags & mask) == indirect)
failed because it's already in progress on the current /* An indirect GOOPS object. If the vtable of the slots
thread, in which case we want to return the old class object is flagged to indicate that there's a new class
for the time being. SCM_CLASS_OF (x) is the right definition available, migrate the instance before
answer for both cases. */ returning the class. */
return SCM_CLASS_OF (x); {
} SCM slots = get_indirect_slots (x);
else scm_t_bits slot_flags = SCM_OBJ_CLASS_FLAGS (slots);
return scm_i_define_class_for_vtable (SCM_CLASS_OF (x)); 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
/* 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,39 +504,40 @@ 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_STRUCT_DATA (old)[scm_vtable_index_self] = SCM_UNPACK (old);
scm_t_bits word0, word1; SCM_STRUCT_DATA (new)[scm_vtable_index_self] = SCM_UNPACK (new);
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_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_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));
} }

554
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 ...))
@ -2118,14 +2114,14 @@ function."
;;; have a rest argument. ;;; have a rest argument.
;;; ;;;
(define (map* fn . l) ; A map which accepts dotted lists (arg lists (define (map* fn . l) ; A map which accepts dotted lists (arg lists
(cond ; must be "isomorph" (cond ; must be "isomorph"
((null? (car l)) '()) ((null? (car l)) '())
((pair? (car l)) (cons (apply fn (map car l)) ((pair? (car l)) (cons (apply fn (map car l))
(apply map* fn (map cdr l)))) (apply map* fn (map cdr l))))
(else (apply fn l)))) (else (apply fn l))))
(define (for-each* fn . l) ; A for-each which accepts dotted lists (arg lists (define (for-each* fn . l) ; A for-each which accepts dotted lists (arg lists
(cond ; must be "isomorph" (cond ; must be "isomorph"
((null? (car l)) '()) ((null? (car l)) '())
((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l))) ((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l)))
@ -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}
;;; ;;;

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

@ -337,25 +337,31 @@
(with-test-prefix "object update" (with-test-prefix "object update"
(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)
(current-module)) #:metaclass <redefinable-class>)
(current-module))
(eval '(is-a? <foo> <class>) (current-module))) (eval '(is-a? <foo> <class>) (current-module)))
(pass-if "making instance" (pass-if "making instance"
(eval '(define foo (make <foo>)) (current-module)) (eval '(define foo (make <foo>)) (current-module))
(eval '(and (is-a? foo <foo>) (= (x foo) 123)) (current-module))) (eval '(and (is-a? foo <foo>) (= (x foo) 123)) (current-module)))
(pass-if "redefining class" (pass-if "redefining class"
(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)
(current-module)) #:metaclass <redefinable-class>)
(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.