Clean up class algebra a bit, and change mixins to recompile less, taking advantage of new semantics

core/bootstrap/primitives.factor

@@ -126,6 +126,9 @@ call( -- )
     prepare-slots make-slots 1 finalize-slots
     [ "slots" set-word-prop ] [ define-accessors ] 2bi ;
 
+: define-builtin-predicate ( class -- )
+    dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
+
 : define-builtin ( symbol slotspec -- )
     [ [ define-builtin-predicate ] keep ] dip define-builtin-slots ;
 

core/classes/algebra/algebra-tests.factor

@@ -164,7 +164,7 @@ MIXIN: empty-mixin
 ! classes-intersect?
 [ t ] [ both tuple classes-intersect? ] unit-test
 
-[ t ] [ vector virtual-sequence classes-intersect? ] unit-test
+[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
 
 [ t ] [ number vector class-or sequence classes-intersect? ] unit-test
 
@@ -192,11 +192,11 @@ MIXIN: empty-mixin
 [ t ] [ union-with-one-member object classes-intersect? ] unit-test
 
 [ t ] [ a mixin-with-one-member classes-intersect? ] unit-test
-[ t ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test
+[ f ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test
 [ t ] [ object mixin-with-one-member classes-intersect? ] unit-test
 
 [ t ] [ mixin-with-one-member a classes-intersect? ] unit-test
-[ t ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test
+[ f ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test
 [ t ] [ mixin-with-one-member object classes-intersect? ] unit-test
 
 ! class=

core/classes/builtin/builtin.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors classes classes.algebra classes.algebra.private
 words kernel kernel.private namespaces sequences math
@@ -20,11 +20,6 @@ M: object class tag type>class ; inline
 
 M: builtin-class rank-class drop 0 ;
 
-GENERIC: define-builtin-predicate ( class -- )
-
-M: builtin-class define-builtin-predicate
-    dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
-
 M: builtin-class instance? [ tag ] [ class>type ] bi* eq? ;
 
 M: builtin-class (flatten-class) dup set ;

core/classes/intersection/intersection.factor

@@ -8,6 +8,8 @@ IN: classes.intersection
 PREDICATE: intersection-class < class
     "metaclass" word-prop intersection-class eq? ;
 
+<PRIVATE
+
 : intersection-predicate-quot ( members -- quot )
     [
         [ drop t ]
@@ -23,11 +25,6 @@ PREDICATE: intersection-class < class
 
 M: intersection-class update-class define-intersection-predicate ;
 
-: define-intersection-class ( class participants -- )
-    [ [ f f ] dip intersection-class define-class ]
-    [ drop update-classes ]
-    2bi ;
-
 M: intersection-class rank-class drop 2 ;
 
 M: intersection-class instance?
@@ -50,3 +47,10 @@ M: anonymous-intersection (flatten-class)
         [ intersect-flattened-classes ] map-reduce
         [ dup set ] each
     ] if-empty ;
+
+PRIVATE>
+
+: define-intersection-class ( class participants -- )
+    [ [ f f ] dip intersection-class define-class ]
+    [ drop update-classes ]
+    2bi ;

core/classes/mixin/mixin.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes classes.algebra classes.algebra.private
-classes.union words kernel sequences definitions combinators
+classes.union classes.union.private words kernel sequences
-arrays assocs generic accessors ;
+definitions combinators arrays assocs generic accessors ;
 IN: classes.mixin
 
 PREDICATE: mixin-class < union-class "mixin" word-prop ;
@@ -46,40 +46,35 @@ TUPLE: check-mixin-class class ;
     [ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
     swap redefine-mixin-class ; inline
 
-: update-classes/new ( mixin -- )
+: update-mixin-class ( member mixin -- )
     class-usages
+    [ update-methods ]
     [ [ update-class ] each ]
-    [ implementors [ remake-generic ] each ] bi ;
+    [ implementors [ remake-generic ] each ]
+    tri ;
 
 : (add-mixin-instance) ( class mixin -- )
     [ [ suffix ] change-mixin-class ]
     [ [ f ] 2dip "instances" word-prop set-at ]
-    2bi ;
+    [ update-mixin-class ]
+    2tri ;
 
 GENERIC# add-mixin-instance 1 ( class mixin -- )
 
 M: class add-mixin-instance
-    [ 2drop ] [
+    [ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ;
-        [ (add-mixin-instance) ] 2keep
-        [ nip ] [ [ new-class? ] either? ] 2bi
-        [ update-classes/new ] [ update-classes ] if
-    ] if-mixin-member? ;
 
 : (remove-mixin-instance) ( class mixin -- )
     [ [ swap remove ] change-mixin-class ]
     [ "instances" word-prop delete-at ]
-    2bi ;
+    [ update-mixin-class ]
+    2tri ;
 
 : remove-mixin-instance ( class mixin -- )
     #! The order of the three clauses is important here. The last
     #! one must come after the other two so that the entries it
     #! adds to changed-generics are not overwritten.
-    [
+    [ (remove-mixin-instance) ] [ 2drop ] if-mixin-member? ;
-        [ (remove-mixin-instance) ]
-        [ nip update-classes ]
-        [ class-usages update-methods ]
-        2tri
-    ] [ 2drop ] if-mixin-member? ;
 
 M: mixin-class class-forgotten remove-mixin-instance ;
 

core/classes/predicate/predicate.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes classes.algebra classes.algebra.private kernel
 namespaces make words sequences quotations arrays kernel.private
@@ -8,6 +8,8 @@ IN: classes.predicate
 PREDICATE: predicate-class < class
     "metaclass" word-prop predicate-class eq? ;
 
+<PRIVATE
+
 GENERIC: predicate-quot ( class -- quot )
 
 M: predicate-class predicate-quot
@@ -18,6 +20,8 @@ M: predicate-class predicate-quot
         [ drop f ] , \ if ,
     ] [ ] make ;
 
+PRIVATE>
+
 : define-predicate-class ( class superclass definition -- )
     [ drop f f predicate-class define-class ]
     [ nip "predicate-definition" set-word-prop ]

core/classes/singleton/singleton.factor

@@ -1,11 +1,16 @@
-! Copyright (C) 2008, 2009 Doug Coleman, Slava Pestov.
+! Copyright (C) 2008, 2010 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes classes.algebra classes.algebra.private
-classes.predicate kernel sequences words ;
+classes.predicate classes.predicate.private kernel sequences
+words ;
 IN: classes.singleton
 
+<PRIVATE
+
 : singleton-predicate-quot ( class -- quot ) [ eq? ] curry ;
 
+PRIVATE>
+
 PREDICATE: singleton-class < predicate-class
     [ "predicate-definition" word-prop ]
     [ singleton-predicate-quot ]

core/classes/tuple/tuple-docs.factor

@@ -348,8 +348,7 @@ HELP: tuple-class
 
 HELP: tuple=
 { $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
-{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
+{ $description "Checks if two tuples have equal slot values. This is the default behavior of " { $link = } " on tuples, unless the tuple class subclasses " { $link identity-tuple } " or implements a method on " { $link equal? } ". In cases where equality has been redefined, this word can be used to get the default semantics if needed." } ;
-{ $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: tuple
 { $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class."

core/classes/union/union.factor

@@ -8,6 +8,8 @@ IN: classes.union
 PREDICATE: union-class < class
     "metaclass" word-prop union-class eq? ;
 
+<PRIVATE
+
 : union-predicate-quot ( members -- quot )
     [
         [ drop f ]
@@ -26,6 +28,8 @@ M: union-class update-class define-union-predicate ;
 : (define-union-class) ( class members -- )
     f swap f union-class define-class ;
 
+PRIVATE>
+
 : define-union-class ( class members -- )
     [ (define-union-class) ] [ drop update-classes ] 2bi ;