Clean up tuple code and get hierarchy changes working

diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index ccb735f392c8f1c9c6cd1760063bbbaf34f6c104..435c7413a35e6971101baacabc32a35283cf876b 100755 (executable)
--- a/core/classes/classes.factor
+++ b/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 -- )
-    [ drop update-predicate ] assoc-each ;
+: update-classes ( assoc -- )
+    [ 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-
-    dupd (define-class)
-    dup update-map+
-    class-usages dup update-predicates update-methods ;
+    [ drop update-map- ]
+    [ (define-class) ] [
+        drop
+        [ update-map+ ] [
+            class-usages
+            [ update-classes ]
+            [ update-methods ] bi
+        ] bi
+    ] 2tri ;
 
 GENERIC: class ( object -- class ) inline
 

diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor
index 814ab0e8384d2002b7bb40d18f9d3176f53fa7e0..e9b98770dc3273a3c9061e01b040d6e6bbef6a6f 100755 (executable)
--- a/core/classes/union/union.factor
+++ b/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 ;

diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor
index 7b8c8f2997b2bcd33f74814c075704553d703971..675841816f1f4eba663d135d63f9910eb62a04ca 100755 (executable)
--- a/core/prettyprint/prettyprint.factor
+++ b/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 ;

diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor
index 09795888a8dd35fc65c773725ea4d20cf75495d5..2ae53ee05da6108c2849612aeb360b88fe5537e0 100755 (executable)
--- a/core/tuples/tuples-tests.factor
+++ b/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
 
 [ ] [
     [

diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor
index 60606357d328748cd15a9fe7bc1e6087080fa029..f4ab215bf0c7c4ef18afd42a6e59df830e05b98c 100755 (executable)
--- a/core/tuples/tuples.factor
+++ b/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 )
-    over superclass-size 2 + simple-slots
-    dup [ slot-spec-name ] map ;
+: generate-tuple-slots ( class slots -- slots )
+    over superclass-size 2 + simple-slots ;
 
 : define-tuple-slots ( class slots -- )
     dupd generate-tuple-slots
-    >r dupd "slots" set-word-prop
-    r> dupd "slot-names" set-word-prop
-    dup "slots" word-prop 2dup define-slots define-accessors ;
+    [ "slots" set-word-prop ]
+    [ 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
-        writer-word forget-method
+        [ reader-word forget-method ]
+        [ writer-word forget-method ] 2bi
     ] 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>
-        [ reshape-tuple ] curry map
+        >r "predicate" word-prop instances dup
+        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 ]
-        [ define-tuple-predicate ]
-        bi
-    ]
-    3tri ;
+        class-usages [
+            drop
+            [ define-tuple-layout ]
+            [ define-tuple-predicate ]
+            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
-    [ "superclass" word-prop = ]
-    [ "slot-names" word-prop = ] 2bi* and ;
+    rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
 
 PRIVATE>
 
@@ -199,9 +201,7 @@ M: tuple hashcode*
 
 ! Definition protocol
 M: tuple-class reset-class
-    {
-        "metaclass" "superclass" "slot-names" "slots" "layout"
-    } reset-props ;
+    { "metaclass" "superclass" "slots" "layout" } reset-props ;
 
 M: object get-slots ( obj slots -- ... )
     [ execute ] with each ;

diff --git a/extra/json/writer/writer.factor b/extra/json/writer/writer.factor
index 4f3bd096135d7b013cabdbb52ea64e854a108de6..110e9b843c1d0f4396b805ac0854bb791c4f8151 100644 (file)
--- a/extra/json/writer/writer.factor
+++ b/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