Working on classes

core/bootstrap/primitives.factor

@@ -341,7 +341,7 @@ define-tuple-slots
 
 ! Define general-t type, which is any object that is not f.
 "general-t" "kernel" create
-"f" "syntax" lookup builtins get remove [ ] subset f union-class
+f "f" "syntax" lookup builtins get remove [ ] subset union-class
 define-class
 
 "f" "syntax" create [ not ] "predicate" set-word-prop
@@ -353,15 +353,15 @@ define-class
 ! Catch-all class for providing a default method.
 "object" "kernel" create [ drop t ] "predicate" set-word-prop
 "object" "kernel" create
-builtins get [ ] subset f union-class define-class
+f builtins get [ ] subset union-class define-class
 
 ! Class of objects with object tag
 "hi-tag" "classes.private" create
-builtins get num-tags get tail f union-class define-class
+f builtins get num-tags get tail union-class define-class
 
 ! Null class with no instances.
 "null" "kernel" create [ drop f ] "predicate" set-word-prop
-"null" "kernel" create { } f union-class define-class
+"null" "kernel" create f { } union-class define-class
 
 ! Create special tombstone values
 "tombstone" "hashtables.private" create

core/classes/classes.factor

@@ -83,13 +83,12 @@ M: word reset-class drop ;
 : update-map- ( class -- )
     dup class-uses update-map get remove-vertex ;
 
-PRIVATE>
+: define-class-props ( superclass members metaclass -- assoc )
-
-: define-class-props ( members superclass metaclass -- assoc )
     [
-        "metaclass" set
+        [ dup [ bootstrap-word ] when "superclass" set ]
-        dup [ bootstrap-word ] when "superclass" set
+        [ [ bootstrap-word ] map "members" set ]
-        [ bootstrap-word ] map "members" set
+        [ "metaclass" set ]
+        tri*
     ] H{ } make-assoc ;
 
 : (define-class) ( word props -- )
@@ -100,6 +99,8 @@ PRIVATE>
     over "predicating" set-word-prop
     t "class" set-word-prop ;
 
+PRIVATE>
+
 GENERIC: update-predicate ( class -- )
 
 M: class update-predicate drop ;
@@ -109,7 +110,7 @@ M: class update-predicate drop ;
 
 GENERIC: update-methods ( assoc -- )
 
-: define-class ( word members superclass metaclass -- )
+: define-class ( word superclass members metaclass -- )
     #! If it was already a class, update methods after.
     reset-caches
     define-class-props

core/classes/predicate/predicate.factor

@@ -14,8 +14,8 @@ PREDICATE: predicate-class < class
     ] [ ] make ;
 
 : define-predicate-class ( class superclass definition -- )
-    >r >r dup f r> predicate-class define-class r>
+    >r dupd f predicate-class define-class
-    dupd "predicate-definition" set-word-prop
+    r> dupd "predicate-definition" set-word-prop
     dup predicate-quot define-predicate ;
 
 M: predicate-class reset-class

core/classes/union/union.factor

@@ -36,7 +36,7 @@ PREDICATE: union-class < class
 M: union-class update-predicate define-union-predicate ;
 
 : define-union-class ( class members -- )
-    dupd f union-class define-class define-union-predicate ;
+    >r dup f r> union-class define-class define-union-predicate ;
 
 M: union-class reset-class
     { "metaclass" "members" } reset-props ;

core/tuples/tuples.factor

@@ -124,7 +124,8 @@ PRIVATE>
     [ [ swap ?nth ] [ drop f ] if* ] with map
     append >tuple ;
 
-: reshape-tuples ( class newslots -- )
+: reshape-tuples ( class superclass newslots -- )
+    nip
     >r dup "slot-names" word-prop r> permutation
     [
         >r [ swap class eq? ] curry instances dup r>
@@ -132,36 +133,45 @@ PRIVATE>
         become
     ] 2curry after-compilation ;
 
-: tuple-class-unchanged ( class superclass slots -- ) 3drop ;
+: define-new-tuple-class ( class superclass slots -- )
-
+    [ drop f tuple-class define-class ]
-: prepare-tuple-class ( class slots -- )
+    [ nip define-tuple-slots ]
-    dupd define-tuple-slots
+    [
-    dup define-tuple-layout
+        2drop
-    define-tuple-predicate ;
+        [ define-tuple-layout ]
-
+        [ define-tuple-predicate ]
-: change-superclass "not supported" throw ;
+        bi
+    ]
+    3tri ;
 
 : redefine-tuple-class ( class superclass slots -- )
-    >r 2dup swap superclass eq?
+    [ reshape-tuples ]
-    [ drop ] [ dupd change-superclass ] if r>
+    [
-    2dup forget-slots
+        drop
-    2dup reshape-tuples
+        [ forget-slots ]
-    over changed-word
+        [ drop changed-word ]
-    over redefined
+        [ drop redefined ]
-    prepare-tuple-class ;
+        2tri
+    ]
+    [ define-new-tuple-class ]
+    3tri ;
 
-: define-new-tuple-class ( class superclass slots -- )
+: tuple-class-unchanged? ( class superclass slots -- ? )
-    >r dupd f swap tuple-class define-class r>
+    rot tuck
-    prepare-tuple-class ;
+    [ "superclass" word-prop = ]
+    [ "slot-names" word-prop = ] 2bi* and ;
 
 PRIVATE>
 
-: define-tuple-class ( class superclass slots -- )
+GENERIC# define-tuple-class 2 ( class superclass slots -- )
-    {
+
-        { [ pick tuple-class? not ] [ define-new-tuple-class ] }
+M: word define-tuple-class
-        { [ pick "slot-names" word-prop over = ] [ tuple-class-unchanged ] }
+    define-new-tuple-class ;
-        { [ t ] [ redefine-tuple-class ] }
+
-    } cond ;
+M: tuple-class define-tuple-class
+    3dup tuple-class-unchanged?
+    [ 3dup redefine-tuple-class ] unless
+    3drop ;
 
 : define-error-class ( class superclass slots -- )
     pick >r define-tuple-class r>