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
! 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
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 ;
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
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> ;
-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
] [
[ \ 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
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 )
[ 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
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
: unboxable-tuple-class? ( type -- ? )
{
- [ maybe? not ]
+ [ only-classoid? not ]
[ all-slots empty? not ]
[ immutable-tuple-class? ]
[ final-class? ]
">>"
"call-next-method"
"maybe:"
+ "union{"
+ "intersection{"
"initial:"
"read-only"
"call("
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 ;
TUPLE: anonymous-intersection { participants read-only } ;
+INSTANCE: anonymous-intersection classoid
+
: <anonymous-intersection> ( participants -- class )
set-members dup length 1 =
[ first ] [ anonymous-intersection boa ] if ;
TUPLE: anonymous-complement { class read-only } ;
+INSTANCE: anonymous-complement classoid
+
C: <anonymous-complement> anonymous-complement
M: anonymous-complement rank-class drop 3 ;
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 ;
! 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
PREDICATE: class < word "class" word-prop ;
+MIXIN: classoid
+INSTANCE: class classoid
+
<PRIVATE
SYMBOL: class<=-cache
-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 ;
M: t4 g drop t4 ;
[ t4 ] [ T{ t4 } g ] unit-test
-[ i ] [ T{ t5 } g ] unit-test
\ No newline at end of file
+[ 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
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 ;
C: <maybe> maybe
+INSTANCE: maybe classoid
+
M: maybe instance?
over [ class>> instance? ] [ 2drop t ] if ;
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 ;
M: maybe (flatten-class)
maybe-class-or (flatten-class) ;
-M: maybe effect>type ;
-
M: maybe union-of-builtins?
class>> union-of-builtins? ;
[ 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
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
[ ] [ "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
! 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
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 ;
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
[ 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 -- )
- [ [ conjoin ] with-implementors ]
+: reveal-method ( method classes generic -- )
+ [ [ [ conjoin ] with each ] with-implementors ]
[ [ set-at ] with-methods ]
2bi ;
] keep eq?
[
[ [ delete-at ] with-methods ]
- [ [ delete-at ] with-implementors ] 2bi
+ [ [ [ delete-at ] with each ] with-implementors ] 2bi
reset-caches
] [ 2drop ] if
] if
! 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 ;
[ 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 ] }
} 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
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
"maybe:" [
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
projects / factor.git / commitdiff