Clean up tuple code and get hierarchy changes working

core/classes/classes.factor

@@ -101,12 +101,12 @@ M: word reset-class drop ;
 
 PRIVATE>
 
-GENERIC: update-predicate ( class -- )
+GENERIC: update-class ( class -- )
 
-M: class update-predicate drop ;
+M: class update-class drop ;
 
-: update-predicates ( assoc -- )
+: update-classes ( assoc -- )
-    [ drop update-predicate ] assoc-each ;
+    [ drop update-class ] assoc-each ;
 
 GENERIC: update-methods ( assoc -- )
 
@@ -114,10 +114,15 @@ GENERIC: update-methods ( assoc -- )
     #! If it was already a class, update methods after.
     reset-caches
     define-class-props
-    over update-map-
+    [ drop update-map- ]
-    dupd (define-class)
+    [ (define-class) ] [
-    dup update-map+
+        drop
-    class-usages dup update-predicates update-methods ;
+        [ update-map+ ] [
+            class-usages
+            [ update-classes ]
+            [ update-methods ] bi
+        ] bi
+    ] 2tri ;
 
 GENERIC: class ( object -- class ) inline
 

core/classes/union/union.factor

@@ -33,10 +33,10 @@ PREDICATE: union-class < class
 : define-union-predicate ( class -- )
     dup members union-predicate-quot define-predicate ;
 
-M: union-class update-predicate define-union-predicate ;
+M: union-class update-class define-union-predicate ;
 
 : define-union-class ( class members -- )
-    >r dup f r> union-class define-class define-union-predicate ;
+    f swap union-class define-class ;
 
 M: union-class reset-class
     { "metaclass" "members" } reset-props ;

core/prettyprint/prettyprint.factor

@@ -260,7 +260,7 @@ M: tuple-class see-class*
     dup superclass tuple eq? [
         "<" text dup superclass pprint-word
     ] unless
-    "slot-names" word-prop [ text ] each
+    slot-names [ text ] each
     pprint-; block> ;
 
 M: word see-class* drop ;

core/tuples/tuples-tests.factor

@@ -343,7 +343,7 @@ TUPLE: electronic-device ;
 ! Hardcore unit tests
 USE: threads
 
-\ thread "slot-names" word-prop "slot-names" set
+\ thread slot-names "slot-names" set
 
 [ ] [
     [
@@ -361,7 +361,7 @@ USE: threads
 
 USE: vocabs
 
-\ vocab "slot-names" word-prop "slot-names" set
+\ vocab slot-names "slot-names" set
 
 [ ] [
     [

core/tuples/tuples.factor

@@ -4,7 +4,7 @@ USING: arrays definitions hashtables kernel
 kernel.private math namespaces sequences sequences.private
 strings vectors words quotations memory combinators generic
 classes classes.private slots.deprecated slots.private slots
-compiler.units math.private ;
+compiler.units math.private accessors ;
 IN: tuples
 
 M: tuple delegate 2 slot ;
@@ -44,6 +44,9 @@ PRIVATE>
         2each
     ] keep ;
 
+: slot-names ( class -- seq )
+    "slots" word-prop [ name>> ] map ;
+
 <PRIVATE
 
 : tuple= ( tuple1 tuple2 -- ? )
@@ -87,33 +90,33 @@ PRIVATE>
 
 : superclass-size ( class -- n )
     superclasses 1 head-slice*
-    [ "slot-names" word-prop length ] map sum ;
+    [ slot-names length ] map sum ;
 
-: generate-tuple-slots ( class slots -- slot-specs slot-names )
+: generate-tuple-slots ( class slots -- slots )
-    over superclass-size 2 + simple-slots
+    over superclass-size 2 + simple-slots ;
-    dup [ slot-spec-name ] map ;
 
 : define-tuple-slots ( class slots -- )
     dupd generate-tuple-slots
-    >r dupd "slots" set-word-prop
+    [ "slots" set-word-prop ]
-    r> dupd "slot-names" set-word-prop
+    [ define-accessors ]
-    dup "slots" word-prop 2dup define-slots define-accessors ;
+    [ define-slots ] 2tri ;
 
 : make-tuple-layout ( class -- layout )
-    dup superclass-size over "slot-names" word-prop length +
+    [ ]
-    over superclasses dup length 1- <tuple-layout> ;
+    [ [ superclass-size ] [ "slots" word-prop length ] bi + ]
+    [ superclasses dup length 1- ] tri
+    <tuple-layout> ;
 
 : define-tuple-layout ( class -- )
     dup make-tuple-layout "layout" set-word-prop ;
 
 : removed-slots ( class newslots -- seq )
-    swap "slot-names" word-prop seq-diff ;
+    swap slot-names seq-diff ;
 
-: forget-slots ( class newslots -- )
+: forget-slots ( class slots -- )
     dupd removed-slots [
-        2dup
+        [ reader-word forget-method ]
-        reader-word forget-method
+        [ writer-word forget-method ] 2bi
-        writer-word forget-method
     ] with each ;
 
 : permutation ( seq1 seq2 -- permutation )
@@ -126,28 +129,29 @@ PRIVATE>
 
 : reshape-tuples ( class superclass newslots -- )
     nip
-    >r dup "slot-names" word-prop r> permutation
+    >r dup slot-names r> permutation
     [
-        >r [ swap class eq? ] curry instances dup r>
+        >r "predicate" word-prop instances dup
-        [ reshape-tuple ] curry map
+        r> [ reshape-tuple ] curry map
         become
     ] 2curry after-compilation ;
 
 : define-new-tuple-class ( class superclass slots -- )
     [ drop f tuple-class define-class ]
-    [ nip define-tuple-slots ]
+    [ nip define-tuple-slots ] [
-    [
         2drop
-        [ define-tuple-layout ]
+        class-usages [
-        [ define-tuple-predicate ]
+            drop
-        bi
+            [ define-tuple-layout ]
-    ]
+            [ define-tuple-predicate ]
-    3tri ;
+            bi
+        ] assoc-each
+    ] 3tri ;
 
 : redefine-tuple-class ( class superclass slots -- )
     [ reshape-tuples ]
     [
-        drop
+        nip
         [ forget-slots ]
         [ drop changed-word ]
         [ drop redefined ]
@@ -157,9 +161,7 @@ PRIVATE>
     3tri ;
 
 : tuple-class-unchanged? ( class superclass slots -- ? )
-    rot tuck
+    rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
-    [ "superclass" word-prop = ]
-    [ "slot-names" word-prop = ] 2bi* and ;
 
 PRIVATE>
 
@@ -199,9 +201,7 @@ M: tuple hashcode*
 
 ! Definition protocol
 M: tuple-class reset-class
-    {
+    { "metaclass" "superclass" "slots" "layout" } reset-props ;
-        "metaclass" "superclass" "slot-names" "slots" "layout"
-    } reset-props ;
 
 M: object get-slots ( obj slots -- ... )
     [ execute ] with each ;

extra/json/writer/writer.factor

@@ -42,7 +42,7 @@ M: sequence json-print ( array -- string )
 : slots ( object -- values names )
   #! Given an object return an array of slots names and a sequence of slot values
   #! the slot name and the slot value. 
-  [ tuple-slots ] keep class "slot-names" word-prop ;
+  [ tuple-slots ] keep class slot-names ;
 
 : slots>fields ( values names -- array )
   #! Convert the arrays containing the slot names and values