classes: add syntax for intersection{ and union{ anonymous classes. make classoid a mixin.

basis/compiler/tree/propagation/simple/simple.factor

@@ -40,6 +40,12 @@ M: class depends-on-class
 M: maybe depends-on-class
     class>> depends-on-class ;
 
+M: anonymous-union depends-on-class
+    members>> [ depends-on-class ] each ;
+
+M: anonymous-intersection depends-on-class
+    participants>> [ depends-on-class ] each ;
+
 M: #declare propagate-before
     #! We need to force the caller word to recompile when the
     #! classes mentioned in the declaration are redefined, since

basis/prettyprint/backend/backend.factor

@@ -1,13 +1,13 @@
 ! Copyright (C) 2003, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs byte-arrays byte-vectors classes
-classes.tuple classes.tuple.private colors colors.constants
+classes.algebra.private classes.intersection classes.maybe
-combinators continuations effects generic hashtables io
+classes.tuple classes.tuple.private classes.union colors
-io.pathnames io.styles kernel make math math.order math.parser
+colors.constants combinators continuations effects generic
-namespaces prettyprint.config prettyprint.custom
+hash-sets hashtables io io.pathnames io.styles kernel make math
-prettyprint.sections prettyprint.stylesheet quotations sbufs
+math.order math.parser namespaces prettyprint.config
-sequences strings vectors words words.symbol hash-sets
+prettyprint.custom prettyprint.sections prettyprint.stylesheet
-classes.maybe ;
+quotations sbufs sequences strings vectors words words.symbol ;
 FROM: sets => members ;
 IN: prettyprint.backend
 
@@ -28,6 +28,12 @@ GENERIC: word-name* ( obj -- str )
 M: maybe word-name*
     class>> word-name* "maybe: " prepend ;
 
+M: anonymous-union word-name*
+    members>> [ word-name* ] map " " join "union{ " " }" surround ;
+
+M: anonymous-intersection word-name*
+    participants>> [ word-name* ] map " " join "intersection{ " " }" surround ;
+
 M: word word-name* ( word -- str )
     [ name>> "( no name )" or ] [ record-vocab ] bi ;
 
@@ -36,10 +42,12 @@ M: word word-name* ( word -- str )
 
 GENERIC: pprint-class ( obj -- )
 
-M: maybe pprint-class pprint* ;
+M: classoid pprint-class pprint* ;
 
 M: class pprint-class \ f or pprint-word ;
 
+M: word pprint-class pprint-word ;
+
 : pprint-prefix ( word quot -- )
     <block swap pprint-word call block> ; inline
 
@@ -255,3 +263,9 @@ M: wrapper pprint*
 
 M: maybe pprint*
     <block \ maybe: pprint-word class>> pprint-word block> ;
+
+M: anonymous-union pprint*
+    <block \ union{ pprint-word members>> [ pprint-word ] each \ } pprint-word block> ;
+
+M: anonymous-intersection pprint*
+    <block \ intersection{ pprint-word participants>> [ pprint-word ] each \ } pprint-word block> ;

basis/prettyprint/prettyprint-tests.factor

@@ -1,10 +1,11 @@
-USING: arrays definitions io.streams.string io.streams.duplex
+USING: accessors arrays classes.intersection classes.maybe
-kernel math namespaces parser prettyprint prettyprint.config
+classes.union compiler.units continuations definitions effects
-prettyprint.sections sequences tools.test vectors words
+eval generic generic.standard io io.streams.duplex
-effects splitting generic.standard prettyprint.private
+io.streams.string kernel listener make math namespaces parser
-continuations generic compiler.units tools.continuations
+prettyprint prettyprint.config prettyprint.private
-tools.continuations.private eval accessors make vocabs.parser see
+prettyprint.sections see sequences splitting
-listener classes.maybe ;
+tools.continuations tools.continuations.private tools.test
+vectors vocabs.parser words ;
 IN: prettyprint.tests
 
 [ "4" ] [ 4 unparse ] unit-test
@@ -406,3 +407,25 @@ M: integer harhar M\\ integer harhar drop ;\n"""
 ] [
     [ \ harhar see-methods ] with-string-writer
 ] unit-test
+
+
+TUPLE: mo { a union{ float integer } } ;
+TUPLE: fo { a intersection{ fixnum integer } } ;
+
+[
+"""USING: classes.union math ;
+IN: prettyprint.tests
+TUPLE: mo { a union{ float integer } initial: 0 } ;
+"""
+] [
+    [ \ mo see ] with-string-writer
+] unit-test
+
+[
+"""USING: classes.intersection math ;
+IN: prettyprint.tests
+TUPLE: fo { a intersection{ fixnum integer } initial: 0 } ;
+"""
+] [
+    [ \ fo see ] with-string-writer
+] unit-test

basis/typed/typed-tests.factor

@@ -1,6 +1,7 @@
 USING: accessors effects eval kernel layouts math namespaces
 quotations tools.test typed words words.symbol combinators.short-circuit
-compiler.tree.debugger prettyprint definitions compiler.units sequences ;
+compiler.tree.debugger prettyprint definitions compiler.units sequences
+classes.intersection strings classes.union ;
 IN: typed.tests
 
 TYPED: f+ ( a: float b: float -- c: float )
@@ -167,3 +168,14 @@ TYPED: typed-maybe ( x: maybe: integer -- ? ) >boolean ;
 [ f ] [ f typed-maybe ] unit-test
 [ t ] [ 30 typed-maybe ] unit-test
 [ 30.0 typed-maybe ] [ input-mismatch-error? ] must-fail-with
+
+TYPED: typed-union ( x: union{ integer string } -- ? ) >boolean ;
+
+[ t ] [ 3 typed-union ] unit-test
+[ t ] [ "asdf" typed-union ] unit-test
+[ 3.3 typed-union ] [ input-mismatch-error? ] must-fail-with
+
+TYPED: typed-intersection ( x: intersection{ integer bignum } -- ? ) >boolean ;
+
+[ t ] [ 5555555555555555555555555555555555555555555555555555 typed-intersection ] unit-test
+[ 0 typed-intersection ] [ input-mismatch-error? ] must-fail-with

basis/typed/typed.factor

@@ -4,7 +4,7 @@ combinators.short-circuit definitions effects fry hints
 math kernel kernel.private namespaces parser quotations
 sequences slots words locals effects.parser
 locals.parser macros stack-checker.dependencies
-classes.maybe ;
+classes.maybe classes.algebra ;
 FROM: classes.tuple.private => tuple-layout ;
 IN: typed
 
@@ -19,7 +19,7 @@ PREDICATE: typed-word < word "typed-word" word-prop >boolean ;
 
 : unboxable-tuple-class? ( type -- ? )
     {
-        [ maybe? not ]
+        [ only-classoid? not ]
         [ all-slots empty? not ]
         [ immutable-tuple-class? ]
         [ final-class? ]

core/bootstrap/syntax.factor

@@ -86,6 +86,8 @@ IN: bootstrap.syntax
         ">>"
         "call-next-method"
         "maybe:"
+        "union{"
+        "intersection{"
         "initial:"
         "read-only"
         "call("

core/classes/algebra/algebra.factor

@@ -11,6 +11,8 @@ IN: classes.algebra
 
 TUPLE: anonymous-union { members read-only } ;
 
+INSTANCE: anonymous-union classoid
+
 : <anonymous-union> ( members -- class )
     [ null eq? not ] filter set-members
     dup length 1 = [ first ] [ anonymous-union boa ] if ;
@@ -19,6 +21,8 @@ M: anonymous-union rank-class drop 6 ;
 
 TUPLE: anonymous-intersection { participants read-only } ;
 
+INSTANCE: anonymous-intersection classoid
+
 : <anonymous-intersection> ( participants -- class )
     set-members dup length 1 =
     [ first ] [ anonymous-intersection boa ] if ;
@@ -27,6 +31,8 @@ M: anonymous-intersection rank-class drop 4 ;
 
 TUPLE: anonymous-complement { class read-only } ;
 
+INSTANCE: anonymous-complement classoid
+
 C: <anonymous-complement> anonymous-complement
 
 M: anonymous-complement rank-class drop 3 ;
@@ -52,19 +58,16 @@ M: object normalize-class ;
 
 PRIVATE>
 
-GENERIC: classoid? ( obj -- ? )
-
-M: word classoid? class? ;
-M: anonymous-union classoid? drop t ;
-M: anonymous-intersection classoid? drop t ;
-M: anonymous-complement classoid? drop t ;
-
 GENERIC: valid-classoid? ( obj -- ? )
 
 M: word valid-classoid? class? ;
 M: anonymous-union valid-classoid? members>> [ valid-classoid? ] all? ;
 M: anonymous-intersection valid-classoid? participants>> [ valid-classoid? ] all? ;
 M: anonymous-complement valid-classoid? class>> valid-classoid? ;
+M: object valid-classoid? drop f ;
+
+: only-classoid? ( obj -- ? )
+    [ classoid? ] [ class? not ] bi and ;
 
 : class<= ( first second -- ? )
     class<=-cache get [ (class<=) ] 2cache ;

core/classes/classes.factor

@@ -1,9 +1,7 @@
 ! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays definitions assocs kernel kernel.private
+USING: accessors assocs combinators definitions graphs kernel
-slots.private namespaces make sequences strings words words.symbol
+make namespaces quotations sequences sets words words.symbol ;
-vectors math quotations combinators sorting effects graphs
-vocabs sets ;
 FROM: namespaces => set ;
 IN: classes
 
@@ -11,6 +9,9 @@ ERROR: bad-inheritance class superclass ;
 
 PREDICATE: class < word "class" word-prop ;
 
+MIXIN: classoid
+INSTANCE: class classoid
+
 <PRIVATE
 
 SYMBOL: class<=-cache

core/classes/intersection/intersection-tests.factor

@@ -1,4 +1,5 @@
-USING: kernel tools.test generic generic.standard ;
+USING: kernel tools.test generic generic.standard classes math
+accessors classes.intersection slots math.order ;
 IN: classes.intersection.tests
 
 TUPLE: a ;
@@ -36,3 +37,23 @@ M: t4 g drop t4 ;
 
 [ t4 ] [ T{ t4 } g ] unit-test
 [ i ] [ T{ t5 } g ] unit-test
+
+PREDICATE: odd-integer < integer odd? ;
+
+! [ TUPLE: omg { a intersection{ fixnum odd-integer } initial: 2 } ;" eval( -- ) ]
+! [ bad-initial-value? ] must-fail-with
+
+TUPLE: omg { a intersection{ fixnum odd-integer } initial: 1 } ;
+
+[ 1 ] [ omg new a>> ] unit-test
+[ 3 ] [ omg new 3 >>a a>> ] unit-test
+[ omg new 1.2 >>a a>> ] [ bad-slot-value? ] must-fail-with
+
+PREDICATE: odd/float-between-10-20 < union{ odd-integer float }
+    10 20 between? ;
+
+[ t ] [ 17 odd/float-between-10-20? ] unit-test
+[ t ] [ 17.4 odd/float-between-10-20? ] unit-test
+[ f ] [ 18 odd/float-between-10-20? ] unit-test
+[ f ] [ 5 odd/float-between-10-20? ] unit-test
+[ f ] [ 5.75 odd/float-between-10-20? ] unit-test

core/classes/intersection/intersection.factor

@@ -30,6 +30,9 @@ M: intersection-class rank-class drop 5 ;
 M: intersection-class instance?
     "participants" word-prop [ instance? ] with all? ;
 
+M: anonymous-intersection instance?
+    participants>> [ instance? ] with all? ;
+
 M: intersection-class normalize-class
     participants <anonymous-intersection> normalize-class ;
 

core/classes/maybe/maybe.factor

@@ -9,6 +9,8 @@ TUPLE: maybe { class word initial: object read-only } ;
 
 C: <maybe> maybe
 
+INSTANCE: maybe classoid
+
 M: maybe instance?
     over [ class>> instance? ] [ 2drop t ] if ;
 
@@ -18,8 +20,6 @@ M: maybe instance?
 M: maybe normalize-class
     maybe-class-or ;
 
-M: maybe classoid? drop t ;
-
 M: maybe valid-classoid? class>> valid-classoid? ;
 
 M: maybe rank-class drop 6 ;
@@ -27,8 +27,6 @@ M: maybe rank-class drop 6 ;
 M: maybe (flatten-class)
     maybe-class-or (flatten-class) ;
 
-M: maybe effect>type ;
-
 M: maybe union-of-builtins?
     class>> union-of-builtins? ;
 

core/classes/tuple/tuple-tests.factor

@@ -829,8 +829,7 @@ DEFER: initial-slot
 [ t ] [ initial-slot new x>> initial-class? ] unit-test
 
 [ "IN: classes.tuple.tests TUPLE: initial-slot { x initial-class initial: f } ;" eval( -- ) ]
-[ error>> T{ bad-initial-value f "x" } = ] must-fail-with
+[ error>> T{ bad-initial-value f "x" f initial-class } = ] must-fail-with
 
 [ "IN: classes.tuple.tests TUPLE: initial-slot { x initial-class initial: 3 } ;" eval( -- ) ]
-[ error>> T{ bad-initial-value f "x" } = ] must-fail-with
+[ error>> T{ bad-initial-value f "x" 3 initial-class } = ] must-fail-with
-

core/classes/union/union-tests.factor

@@ -4,7 +4,7 @@ sequences strings tools.test vectors words quotations classes
 classes.private classes.union classes.mixin classes.predicate
 classes.algebra classes.union.private source-files
 compiler.units kernel.private sorting vocabs io.streams.string
-eval see math.private slots ;
+eval see math.private slots generic.single ;
 IN: classes.union.tests
 
 ! DEFER: bah
@@ -107,3 +107,28 @@ M: a-union test-generic ;
 [ ] [ "IN: classes.union.tests USE: vectors UNION: fast-union-1 vector ;" eval( -- ) ] unit-test
 
 [ f ] [ "fast-union-2?" "classes.union.tests" lookup-word def>> \ fixnum-bitand swap member? ] unit-test
+
+! Test union{
+
+TUPLE: stuff { a union{ integer string } } ;
+
+[ 0 ] [ stuff new a>> ] unit-test
+[ 3 ] [ stuff new 3 >>a a>> ] unit-test
+[ "asdf" ] [ stuff new "asdf" >>a a>> ] unit-test
+[ stuff new 3.4 >>a a>> ] [ bad-slot-value? ] must-fail-with
+
+TUPLE: things { a union{ integer float } } ;
+
+[ 0 ] [ stuff new a>> ] unit-test
+[ 3 ] [ stuff new 3 >>a a>> ] unit-test
+[ "asdf" ] [ stuff new "asdf" >>a a>> ] unit-test
+[ stuff new 3.4 >>a a>> ] [ bad-slot-value? ] must-fail-with
+
+PREDICATE: numba-ova-10 < union{ float integer }
+    10 > ;
+
+[ f ] [ 100/3 numba-ova-10? ] unit-test
+[ t ] [ 100 numba-ova-10? ] unit-test
+[ t ] [ 100.0 numba-ova-10? ] unit-test
+[ f ] [ 5 numba-ova-10? ] unit-test
+[ f ] [ 5.75 numba-ova-10? ] unit-test

core/effects/effects.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.parser math.order namespaces make
 sequences strings words assocs combinators accessors arrays
-quotations ;
+quotations classes.algebra classes ;
 IN: effects
 
 TUPLE: effect
@@ -79,6 +79,7 @@ GENERIC: effect>type ( obj -- type )
 M: object effect>type drop object ;
 M: word effect>type ;
 M: pair effect>type second effect>type ;
+M: classoid effect>type ;
 
 : effect-in-types ( effect -- input-types )
     in>> [ effect>type ] map ;

core/generic/generic.factor

@@ -3,7 +3,7 @@
 USING: accessors words kernel sequences namespaces make assocs
 hashtables definitions kernel.private classes classes.private
 classes.algebra quotations arrays vocabs effects combinators
-sets classes.maybe ;
+sets classes.maybe classes.algebra.private ;
 FROM: namespaces => set ;
 IN: generic
 
@@ -132,17 +132,21 @@ M: method crossref?
     [ method-word-name f <word> ] [ method-word-props ] 2bi
     >>props ;
 
-GENERIC: implementor-class ( obj -- class )
+GENERIC: implementor-classes ( obj -- class )
 
-M: maybe implementor-class class>> ;
+M: maybe implementor-classes class>> 1array ;
 
-M: class implementor-class ;
+M: class implementor-classes 1array ;
+
+M: anonymous-union implementor-classes members>> ;
+
+M: anonymous-intersection implementor-classes participants>> ;
 
 : with-implementors ( class generic quot -- )
-    [ swap implementor-class implementors-map get at ] dip call ; inline
+    [ swap implementor-classes [ implementors-map get at ] map ] dip call ; inline
 
-: reveal-method ( method class generic -- )
+: reveal-method ( method classes generic -- )
-    [ [ conjoin ] with-implementors ]
+    [ [ [ conjoin ] with each ] with-implementors ]
     [ [ set-at ] with-methods ]
     2bi ;
 
@@ -178,7 +182,7 @@ M: method forget*
                 ] keep eq?
                 [
                     [ [ delete-at ] with-methods ]
-                    [ [ delete-at ] with-implementors ] 2bi
+                    [ [ [ delete-at ] with each ] with-implementors ] 2bi
                     reset-caches
                 ] [ 2drop ] if
             ] if

core/slots/slots.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2005, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays byte-arrays kernel kernel.private math namespaces
+USING: accessors alien arrays assocs byte-arrays classes
-make sequences strings effects generic generic.standard
+classes.algebra classes.algebra.private classes.maybe
-classes classes.algebra slots.private combinators accessors
+combinators generic generic.standard hashtables kernel
-words sequences.private assocs alien quotations hashtables
+kernel.private make math quotations sequences sequences.private
-classes.maybe ;
+slots.private strings words ;
 IN: slots
 
 TUPLE: slot-spec name offset class initial read-only ;
@@ -151,13 +151,52 @@ M: object writer-quot
         [ define-changer ]
     } cleave ;
 
+DEFER: initial-value
+
 GENERIC: initial-value* ( class -- object ? )
 
 M: class initial-value* drop f f ;
 
+M: maybe initial-value*
+    drop f t ;
+
+! Default initial value is f, 0, or the default inital value
+! of the smallest class. Special case 0 because float is ostensibly
+! smaller than integer in union{ integer float } because of
+! alphabetical sorting.
+M: anonymous-union initial-value*
+    {
+        { [ f over instance? ] [ drop f t ] }
+        { [ 0 over instance? ] [ drop 0 t ] }
+        [
+            members>> sort-classes [ initial-value ] { } map>assoc
+            ?last [ second t ] [ f f ] if*
+        ]
+    } cond ;
+
+! See if any of the initial values fit the intersection class,
+! or else return that none do, and leave it up to the user to provide
+! an initial: value.
+M: anonymous-intersection initial-value*
+    {
+        { [ f over instance? ] [ drop f t ] }
+        { [ 0 over instance? ] [ drop 0 t ] }
+        [
+            [ ]
+            [ participants>> sort-classes [ initial-value ] { } map>assoc ]
+            [ ] tri
+
+            [ [ first2 nip ] dip instance? ] curry find swap [
+                nip second t
+            ] [
+                2drop f f
+            ] if
+        ]
+    } cond ;
+
 : initial-value ( class -- object ? )
     {
-        { [ dup maybe? ] [ f t ] }
+        { [ dup only-classoid? ] [ dup initial-value* ] }
         { [ dup "initial-value" word-prop ] [ dup "initial-value" word-prop t ] }
         { [ \ f bootstrap-word over class<= ] [ f t ] }
         { [ \ array-capacity bootstrap-word over class<= ] [ 0 t ] }
@@ -202,12 +241,16 @@ ERROR: bad-slot-attribute key ;
         } case
     ] unless ;
 
-ERROR: bad-initial-value name ;
+ERROR: bad-initial-value name initial-value class ;
 
 : check-initial-value ( slot-spec -- slot-spec )
     [ ] [
-        dup [ initial>> ] [ class>> ] bi instance?
+        [ ] [ initial>> ] [ class>> ] tri
-        [ name>> bad-initial-value ] unless
+        2dup instance? [
+            2drop
+        ] [
+            [ name>> ] 2dip bad-initial-value
+        ] if
     ] if-bootstrapping ;
 
 M: array make-slot

core/syntax/syntax.factor

@@ -8,7 +8,8 @@ generic.standard generic.hook generic.math generic.parser classes
 io.pathnames vocabs vocabs.parser classes.parser classes.union
 classes.intersection classes.mixin classes.predicate
 classes.singleton classes.tuple.parser compiler.units classes.maybe
-combinators effects.parser slots hash-sets source-files ;
+combinators effects.parser slots hash-sets source-files
+classes.algebra.private ;
 IN: bootstrap.syntax
 
 ! These words are defined as a top-level form, instead of with
@@ -253,6 +254,14 @@ IN: bootstrap.syntax
         scan-class <maybe> suffix!
     ] define-core-syntax
 
+    "intersection{" [
+         \ } [ <anonymous-intersection> ] parse-literal
+    ] define-core-syntax
+
+    "union{" [
+        \ } [ <anonymous-union> ] parse-literal
+    ] define-core-syntax
+
     "initial:" "syntax" lookup-word define-symbol
 
     "read-only" "syntax" lookup-word define-symbol