Tuple reshaping now works with inheritance

core/classes/tuple/tuple-docs.factor

@@ -153,23 +153,11 @@ HELP: tuple=
 { $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
 { $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
 
-HELP: permutation
-{ $values { "seq1" sequence } { "seq2" sequence } { "permutation" "a sequence whose elements are integers or " { $link f } } }
-{ $description "Outputs a permutation for taking " { $snippet "seq1" } " to " { $snippet "seq2" } "." } ;
-
-HELP: reshape-tuple
-{ $values { "oldtuple" tuple } { "permutation" "a sequence whose elements are integers or " { $link f } } { "newtuple" tuple } }
-{ $description "Permutes the slots of a tuple. If a tuple class is redefined at runtime, this word is called on every instance to change its shape to conform to the new layout." } ;
-
-HELP: reshape-tuples
-{ $values { "class" tuple-class } { "superclass" class } { "newslots" "a sequence of strings" } }
-{ $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ;
-
 HELP: removed-slots
 { $values { "class" tuple-class } { "newslots" "a sequence of strings" } { "seq" "a sequence of strings" } }
 { $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ;
 
-HELP: forget-slots
+HELP: forget-removed-slots
 { $values { "class" tuple-class } { "slots" "a sequence of strings" } }
 { $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ;
 

core/classes/tuple/tuple-tests.factor

@@ -265,9 +265,13 @@ C: <laptop> laptop
 [ t ] [ "laptop" get computer? ] unit-test
 [ t ] [ "laptop" get tuple? ] unit-test
 
-[ "Pentium" ] [ "laptop" get cpu>> ] unit-test
+: test-laptop-slot-values
-[ 128 ] [ "laptop" get ram>> ] unit-test
+    [ laptop ] [ "laptop" get class ] unit-test
-[ t ] [ "laptop" get battery>> 3 hours = ] unit-test
+    [ "Pentium" ] [ "laptop" get cpu>> ] unit-test
+    [ 128 ] [ "laptop" get ram>> ] unit-test
+    [ t ] [ "laptop" get battery>> 3 hours = ] unit-test ;
+
+test-laptop-slot-values
 
 [ laptop ] [
     "laptop" get tuple-layout
@@ -294,9 +298,13 @@ C: <server> server
 [ t ] [ "server" get computer? ] unit-test
 [ t ] [ "server" get tuple? ] unit-test
 
-[ "PowerPC" ] [ "server" get cpu>> ] unit-test
+: test-server-slot-values
-[ 64 ] [ "server" get ram>> ] unit-test
+    [ server ] [ "server" get class ] unit-test
-[ "1U" ] [ "server" get rackmount>> ] unit-test
+    [ "PowerPC" ] [ "server" get cpu>> ] unit-test
+    [ 64 ] [ "server" get ram>> ] unit-test
+    [ "1U" ] [ "server" get rackmount>> ] unit-test ;
+
+test-server-slot-values
 
 [ f ] [ "server" get laptop? ] unit-test
 [ f ] [ "laptop" get server? ] unit-test
@@ -316,10 +324,10 @@ C: <server> server
     "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval
 ] must-fail
 
-! Reshaping with inheritance
+! Dynamically changing inheritance hierarchy
 TUPLE: electronic-device ;
 
-[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
 
 [ f ] [ electronic-device laptop class< ] unit-test
 [ t ] [ server electronic-device class< ] unit-test
@@ -335,11 +343,73 @@ TUPLE: electronic-device ;
 [ f ] [ "server" get laptop? ] unit-test
 [ t ] [ "server" get server? ] unit-test
 
-[ ] [ "IN: classes.tuple.tests TUPLE: computer ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval ] unit-test
 
 [ f ] [ "laptop" get electronic-device? ] unit-test
 [ t ] [ "laptop" get computer? ] unit-test
 
+[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval ] unit-test
+
+test-laptop-slot-values
+test-server-slot-values
+
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval ] unit-test
+
+test-laptop-slot-values
+test-server-slot-values
+
+TUPLE: make-me-some-accessors voltage grounded? ;
+
+[ f ] [ "laptop" get voltage>> ] unit-test
+[ f ] [ "server" get voltage>> ] unit-test
+
+[ ] [ "laptop" get 220 >>voltage drop ] unit-test
+[ ] [ "server" get 110 >>voltage drop ] unit-test
+
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval ] unit-test
+
+test-laptop-slot-values
+test-server-slot-values
+
+[ 220 ] [ "laptop" get voltage>> ] unit-test
+[ 110 ] [ "server" get voltage>> ] unit-test
+
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval ] unit-test
+
+test-laptop-slot-values
+test-server-slot-values
+
+[ 220 ] [ "laptop" get voltage>> ] unit-test
+[ 110 ] [ "server" get voltage>> ] unit-test
+
+! Reshaping superclass and subclass simultaneously
+"IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval
+
+test-laptop-slot-values
+test-server-slot-values
+
+[ 220 ] [ "laptop" get voltage>> ] unit-test
+[ 110 ] [ "server" get voltage>> ] unit-test
+
+! Reshape crash
+TUPLE: test1 a ; TUPLE: test2 < test1 b ;
+
+T{ test2 f "a" "b" } "test" set
+
+: test-a/b
+    [ "a" ] [ "test" get a>> ] unit-test
+    [ "b" ] [ "test" get b>> ] unit-test ;
+
+test-a/b
+
+[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval ] unit-test
+
+test-a/b
+
+[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval ] unit-test
+
+test-a/b
+
 ! Redefinition problem
 TUPLE: redefinition-problem ;
 

core/classes/tuple/tuple.factor

@@ -24,13 +24,14 @@ M: class tuple-layout "layout" word-prop ;
 M: tuple tuple-layout 1 slot ;
 
 M: tuple-layout tuple-layout ;
+
 : tuple-size tuple-layout layout-size ; inline
 
 : prepare-tuple>array ( tuple -- n tuple layout )
     [ tuple-size ] [ ] [ tuple-layout ] tri ;
 
-: copy-tuple-slots ( n tuple first -- array )
+: copy-tuple-slots ( n tuple -- array )
-    [ array-nth ] curry map r> add* ;
+    [ array-nth ] curry map ;
 
 PRIVATE>
 
@@ -128,48 +129,63 @@ PRIVATE>
         [ writer-word forget-method ] 2bi
     ] with each ;
 
-: permutation ( seq1 seq2 -- permutation )
-    swap [ index ] curry map ;
-
 : all-slot-names ( class -- slots )
     superclasses [ slot-names ] map concat \ class add* ;
 
-: slot-permutation ( class superclass newslots -- n permutation )
+: compute-slot-permutation ( class old-slot-names -- permutation )
-    [ all-slot-names ] [ all-slot-names ] [ ] tri* append
+    >r all-slot-names r> [ index ] curry map ;
-    [ drop length ] [ permutation ] 2bi ;
 
-: permute-direct-slots ( oldslots permutation -- newslots )
+: apply-slot-permutation ( old-values permutation -- new-values )
     [ [ swap ?nth ] [ drop f ] if* ] with map ;
 
-: permute-all-slots ( oldslots n permutation -- newslots )
+: permute-slots ( old-values -- new-values )
-    [ >r head r> permute-direct-slots ] [ drop tail ] 3bi append ;
+    dup first dup outdated-tuples get at
+    compute-slot-permutation
+    apply-slot-permutation ;
 
 : change-tuple ( tuple quot -- newtuple )
     >r tuple>array r> call >tuple ; inline
 
-: update-tuples ( predicate n permutation -- )
+: update-tuple ( tuple -- newtuple )
-    [ permute-all-slots ] 2curry [ change-tuple ] curry
+    [ permute-slots ] change-tuple ;
-    >r "predicate" word-prop instances dup r> map
-    become ; inline
 
-: update-tuples-after ( class superclass newslots -- )
+: update-tuples ( -- )
-    [ 2drop ] [ slot-permutation ] 3bi
+    outdated-tuples get
-    [ update-tuples ] 3curry after-compilation ;
+    dup assoc-empty? [ drop ] [
+        [ >r class r> key? ] curry instances
+        dup [ update-tuple ] map become
+    ] if ;
+
+[ update-tuples ] update-tuples-hook set-global
+
+: update-tuples-after ( class -- )
+    outdated-tuples get [ all-slot-names ] cache drop ;
+
+: subclasses ( class -- classes )
+    class-usages keys [ tuple-class? ] subset ;
+
+: each-subclass ( class quot -- )
+    >r subclasses r> each ; inline
+
+: define-tuple-shape ( class -- )
+    [ define-tuple-slots ]
+    [ define-tuple-layout ]
+    [ define-tuple-predicate ]
+    tri ;
 
 : define-new-tuple-class ( class superclass slots -- )
     [ drop f tuple-class define-class ]
-    [ nip "slot-names" set-word-prop ] [
+    [ nip "slot-names" set-word-prop ]
+    [
         2drop
-        class-usages keys [ tuple-class? ] subset [
+        [ define-tuple-shape ] each-subclass
-            [ define-tuple-slots ]
-            [ define-tuple-layout ]
-            [ define-tuple-predicate ]
-            tri
-        ] each
     ] 3tri ;
 
 : redefine-tuple-class ( class superclass slots -- )
-    [ update-tuples-after ]
+    [
+        2drop
+        [ update-tuples-after ] each-subclass
+    ]
     [
         nip
         [ forget-removed-slots ]
@@ -205,11 +221,6 @@ M: tuple clone
 M: tuple equal?
     over tuple? [ tuple= ] [ 2drop f ] if ;
 
-: delegates ( obj -- seq )
-    [ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
-
-: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
-
 M: tuple hashcode*
     [
         dup tuple-size -rot 0 -rot [
@@ -217,21 +228,26 @@ M: tuple hashcode*
         ] 2curry reduce
     ] recursive-hashcode ;
 
-! Definition protocol
 M: tuple-class reset-class
     { "metaclass" "superclass" "slots" "layout" } reset-props ;
 
 M: object get-slots ( obj slots -- ... )
     [ execute ] with each ;
 
-M: object set-slots ( ... obj slots -- )
-    <reversed> get-slots ;
-
 M: object construct-empty ( class -- tuple )
     tuple-layout <tuple> ;
 
+M: object construct-boa ( ... class -- tuple )
+    tuple-layout <tuple-boa> ;
+
+! Deprecated
+M: object set-slots ( ... obj slots -- )
+    <reversed> get-slots ;
+
 M: object construct ( ... slots class -- tuple )
     construct-empty [ swap set-slots ] keep ;
 
-M: object construct-boa ( ... class -- tuple )
+: delegates ( obj -- seq )
-    tuple-layout <tuple-boa> ;
+    [ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
+
+: is? ( obj quot -- ? ) >r delegates r> contains? ; inline

core/compiler/units/units.factor

@@ -69,21 +69,19 @@ GENERIC: definitions-changed ( assoc obj -- )
     dup [ drop crossref? ] assoc-contains?
     modify-code-heap ;
 
-SYMBOL: post-compile-tasks
+SYMBOL: outdated-tuples
-
+SYMBOL: update-tuples-hook
-: after-compilation ( quot -- )
-    post-compile-tasks get push ;
 
 : call-recompile-hook ( -- )
     changed-words get keys
     compiled-usages recompile-hook get call ;
 
-: call-post-compile-tasks ( -- )
+: call-update-tuples-hook ( -- )
-    post-compile-tasks get [ call ] each ;
+    update-tuples-hook get call ;
 
 : finish-compilation-unit ( -- )
     call-recompile-hook
-    call-post-compile-tasks
+    call-update-tuples-hook
     dup [ drop crossref? ] assoc-contains? modify-code-heap
     changed-definitions notify-definition-observers ;
 
@@ -91,7 +89,7 @@ SYMBOL: post-compile-tasks
     [
         H{ } clone changed-words set
         H{ } clone forgotten-definitions set
-        V{ } clone post-compile-tasks set
+        H{ } clone outdated-tuples set
         <definitions> new-definitions set
         <definitions> old-definitions set
         [ finish-compilation-unit ]

core/slots/slots.factor

@@ -79,3 +79,6 @@ C: <slot-spec> slot-spec
         dup slot-spec-offset swap slot-spec-name
         define-slot-methods
     ] with each ;
+
+: slot-named ( name specs -- spec/f )
+    [ slot-spec-name = ] with find nip ;