object is now an empty intersection

core/bootstrap/primitives.factor

@@ -5,8 +5,9 @@ hashtables.private io kernel math namespaces parser sequences
 strings vectors words quotations assocs layouts classes
 classes.builtin classes.tuple classes.tuple.private
 kernel.private vocabs vocabs.loader source-files definitions
-slots.deprecated classes.union compiler.units
+slots.deprecated classes.union classes.intersection
-bootstrap.image.private io.files accessors combinators ;
+compiler.units bootstrap.image.private io.files accessors
+combinators ;
 IN: bootstrap.primitives
 
 "Creating primitives and basic runtime structures..." print flush
@@ -159,16 +160,16 @@ bootstrapping? on
 "tuple-layout" "classes.tuple.private" create register-builtin
 
 ! Catch-all class for providing a default method.
-"object" "kernel" create
-[ f builtins get [ ] filter f union-class define-class ]
-[ [ drop t ] "predicate" set-word-prop ]
-bi
-
 ! "object" "kernel" create
-! [ f f { } intersection-class define-class ]
+! [ f builtins get [ ] filter f union-class define-class ]
 ! [ [ drop t ] "predicate" set-word-prop ]
 ! bi
 
+"object" "kernel" create
+[ f f { } intersection-class define-class ]
+[ [ drop t ] "predicate" set-word-prop ]
+bi
+
 "object?" "kernel" vocab-words delete-at
 
 ! Class of objects with object tag

core/classes/algebra/algebra-tests.factor

@@ -1,10 +1,10 @@
-IN: classes.algebra.tests
 USING: alien arrays definitions generic assocs hashtables io
 kernel math namespaces parser prettyprint sequences strings
 tools.test vectors words quotations classes classes.algebra
 classes.private classes.union classes.mixin classes.predicate
 vectors definitions source-files compiler.units growable
 random inference effects kernel.private sbufs math.order ;
+IN: classes.algebra.tests
 
 \ class< must-infer
 \ class-and must-infer
@@ -277,7 +277,7 @@ INTERSECTION: generic-class generic class ;
 [
     [ t ] [ \ class generic class-and generic-class class<= ] unit-test
     [ t ] [ \ class generic class-and generic-class swap class<= ] unit-test
-] call drop
+] drop
 
 [ t ] [ \ word generic-class classes-intersect? ] unit-test
 [ f ] [ number generic-class classes-intersect? ] unit-test
@@ -300,3 +300,5 @@ INTERSECTION: empty-intersection ;
 [ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test
 
 [ t ] [ object \ f class-not \ f class-or class<= ] unit-test
+
+[ ] [ object flatten-builtin-class drop ] unit-test

core/classes/algebra/algebra.factor

@@ -95,13 +95,15 @@ PREDICATE: nontrivial-anonymous-complement < anonymous-complement
         [ participants ]
     } cleave or or or ;
 
+PREDICATE: empty-union < anonymous-union members>> empty? ;
+
+PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
+
 : (class<=) ( first second -- -1/0/1 )
-    {
+    2dup eq? [ 2drop t ] [
-        { [ 2dup eq? ] [ 2drop t ] }
-        { [ dup object eq? ] [ 2drop t ] }
-        { [ over null eq? ] [ 2drop t ] }
-        [
         [ normalize-class ] bi@ {
+            { [ dup empty-intersection? ] [ 2drop t ] }
+            { [ over empty-union? ] [ 2drop t ] }
             { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
             { [ over anonymous-union? ] [ left-anonymous-union<= ] }
             { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
@@ -112,8 +114,7 @@ PREDICATE: nontrivial-anonymous-complement < anonymous-complement
             { [ over superclass ] [ superclass<= ] }
             [ 2drop f ]
         } cond
-        ]
+    ] if ;
-    } cond ;
 
 : anonymous-union-intersect? ( first second -- ? )
     members>> [ classes-intersect? ] with contains? ;
@@ -230,7 +231,7 @@ DEFER: flatten-builtin-class
 : flatten-intersection-class ( class -- )
     participants [ flatten-builtin-class ] map
     dup empty? [
-        drop object (flatten-class)
+        drop builtins get [ (flatten-class) ] each
     ] [
         unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
     ] if ;