From a42756abac269619ea95064fca064d6731b5afcf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 11 May 2008 01:37:37 -0500
Subject: [PATCH] object is now an empty intersection

---
 core/bootstrap/primitives.factor          | 17 +++++-----
 core/classes/algebra/algebra-tests.factor |  6 ++--
 core/classes/algebra/algebra.factor       | 39 ++++++++++++-----------
 3 files changed, 33 insertions(+), 29 deletions(-)

diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 5ab623b8de..4aebef3e0d 100755
--- a/core/bootstrap/primitives.factor
+++ b/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
-bootstrap.image.private io.files accessors combinators ;
+slots.deprecated classes.union classes.intersection
+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
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index 678bf4e47d..0b8fb9680b 100755
--- a/core/classes/algebra/algebra-tests.factor
+++ b/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
diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index f6d5179ec2..a9c1520fc6 100755
--- a/core/classes/algebra/algebra.factor
+++ b/core/classes/algebra/algebra.factor
@@ -95,25 +95,26 @@ 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 ] }
-        { [ dup object eq? ] [ 2drop t ] }
-        { [ over null eq? ] [ 2drop t ] }
-        [
-            [ normalize-class ] bi@ {
-                { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
-                { [ over anonymous-union? ] [ left-anonymous-union<= ] }
-                { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
-                { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
-                { [ dup anonymous-union? ] [ right-anonymous-union<= ] }
-                { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
-                { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
-                { [ over superclass ] [ superclass<= ] }
-                [ 2drop f ]
-            } cond
-        ]
-    } cond ;
+    2dup 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<= ] }
+            { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
+            { [ dup anonymous-union? ] [ right-anonymous-union<= ] }
+            { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
+            { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
+            { [ over superclass ] [ superclass<= ] }
+            [ 2drop f ]
+        } cond
+    ] if ;
 
 : 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 ;