diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index e1bcc07ef4..504b28b400 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/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 diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 3e85f0acaf..105750bbb3 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/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 -combinators continuations effects generic hashtables io -io.pathnames io.styles kernel make math math.order math.parser -namespaces prettyprint.config prettyprint.custom -prettyprint.sections prettyprint.stylesheet quotations sbufs -sequences strings vectors words words.symbol hash-sets -classes.maybe ; +classes.algebra.private classes.intersection classes.maybe +classes.tuple classes.tuple.private classes.union colors +colors.constants combinators continuations effects generic +hash-sets hashtables io io.pathnames io.styles kernel make math +math.order math.parser namespaces prettyprint.config +prettyprint.custom prettyprint.sections prettyprint.stylesheet +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 -- ) ; inline @@ -255,3 +263,9 @@ M: wrapper pprint* M: maybe pprint* > pprint-word block> ; + +M: anonymous-union pprint* + > [ pprint-word ] each \ } pprint-word block> ; + +M: anonymous-intersection pprint* + > [ pprint-word ] each \ } pprint-word block> ; diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index 2ce227674e..49dcbab433 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -1,10 +1,11 @@ -USING: arrays definitions io.streams.string io.streams.duplex -kernel math namespaces parser prettyprint prettyprint.config -prettyprint.sections sequences tools.test vectors words -effects splitting generic.standard prettyprint.private -continuations generic compiler.units tools.continuations -tools.continuations.private eval accessors make vocabs.parser see -listener classes.maybe ; +USING: accessors arrays classes.intersection classes.maybe +classes.union compiler.units continuations definitions effects +eval generic generic.standard io io.streams.duplex +io.streams.string kernel listener make math namespaces parser +prettyprint prettyprint.config prettyprint.private +prettyprint.sections see sequences splitting +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 diff --git a/basis/typed/typed-tests.factor b/basis/typed/typed-tests.factor index e1ee431c53..5209038473 100644 --- a/basis/typed/typed-tests.factor +++ b/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 diff --git a/basis/typed/typed.factor b/basis/typed/typed.factor index fc1eee608c..4bd692dbfe 100644 --- a/basis/typed/typed.factor +++ b/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? ] diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 8e9acd1507..3a99923b9e 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -86,6 +86,8 @@ IN: bootstrap.syntax ">>" "call-next-method" "maybe:" + "union{" + "intersection{" "initial:" "read-only" "call(" diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 5380e28d98..fcdab0eac6 100644 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -11,6 +11,8 @@ IN: classes.algebra TUPLE: anonymous-union { members read-only } ; +INSTANCE: anonymous-union classoid + : ( 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 + : ( 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 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 ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 051fbb7203..3256785ecb 100644 --- a/core/classes/classes.factor +++ b/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 -slots.private namespaces make sequences strings words words.symbol -vectors math quotations combinators sorting effects graphs -vocabs sets ; +USING: accessors assocs combinators definitions graphs kernel +make namespaces quotations sequences sets words words.symbol ; 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 + > ] 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 diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor index 0ed4f4b636..20b456648f 100644 --- a/core/classes/intersection/intersection.factor +++ b/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 normalize-class ; diff --git a/core/classes/maybe/maybe.factor b/core/classes/maybe/maybe.factor index 30da5a5869..30c09e9237 100644 --- a/core/classes/maybe/maybe.factor +++ b/core/classes/maybe/maybe.factor @@ -9,6 +9,8 @@ TUPLE: maybe { class word initial: object read-only } ; C: 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? ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 9ac04464c7..3aa225b1f5 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/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 diff --git a/core/classes/union/union-tests.factor b/core/classes/union/union-tests.factor index 5d1dae2bd3..164c51f371 100644 --- a/core/classes/union/union-tests.factor +++ b/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 diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 6626ee685d..ffc59e21a1 100644 --- a/core/effects/effects.factor +++ b/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 ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index dc92c0705e..2ba2f412cd 100644 --- a/core/generic/generic.factor +++ b/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 ] [ 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 -- ) - [ [ conjoin ] with-implementors ] +: reveal-method ( method classes generic -- ) + [ [ [ 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 diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 5bb1630eb8..4c6731c93a 100644 --- a/core/slots/slots.factor +++ b/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 -make sequences strings effects generic generic.standard -classes classes.algebra slots.private combinators accessors -words sequences.private assocs alien quotations hashtables -classes.maybe ; +USING: accessors alien arrays assocs byte-arrays classes +classes.algebra classes.algebra.private classes.maybe +combinators generic generic.standard hashtables kernel +kernel.private make math quotations sequences sequences.private +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? - [ name>> bad-initial-value ] unless + [ ] [ initial>> ] [ class>> ] tri + 2dup instance? [ + 2drop + ] [ + [ name>> ] 2dip bad-initial-value + ] if ] if-bootstrapping ; M: array make-slot diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index b4c2c5b065..c780abe0eb 100644 --- a/core/syntax/syntax.factor +++ b/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 @@ -252,7 +253,15 @@ IN: bootstrap.syntax "maybe:" [ scan-class suffix! ] define-core-syntax - + + "intersection{" [ + \ } [ ] parse-literal + ] define-core-syntax + + "union{" [ + \ } [ ] parse-literal + ] define-core-syntax + "initial:" "syntax" lookup-word define-symbol "read-only" "syntax" lookup-word define-symbol