Implement class redefinition on top of fixed structs

* 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.

1 files changed, 24 insertions, 15 deletions

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