1 USING: accessors alien arrays definitions generic assocs
2 hashtables io kernel math namespaces parser prettyprint
3 sequences strings tools.test vectors words quotations classes
4 classes.private classes.union classes.mixin classes.predicate
5 classes.algebra classes.union.private source-files
6 compiler.units kernel.private sorting vocabs io.streams.string
7 eval see math.private slots generic.single ;
8 IN: classes.union.tests
12 UNION: bah fixnum alien ;
13 { bah } [ \ bah? "predicating" word-prop ] unit-test
15 { "USING: alien math ;\nIN: classes.union.tests\nUNION: bah fixnum alien ;\n" }
16 [ [ \ bah see ] with-string-writer ] unit-test
18 ! Test redefinition of classes
19 UNION: union-1 fixnum float ;
21 GENERIC: generic-update-test ( x -- y )
23 M: union-1 generic-update-test drop "union-1" ;
25 { f } [ bignum union-1 class<= ] unit-test
26 { t } [ union-1 number class<= ] unit-test
27 { "union-1" } [ 1.0 generic-update-test ] unit-test
29 "IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" eval( -- )
31 { t } [ bignum union-1 class<= ] unit-test
32 { f } [ union-1 number class<= ] unit-test
33 { "union-1" } [ { 1.0 } generic-update-test ] unit-test
35 "IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" eval( -- )
37 { f } [ union-1 union-class? ] unit-test
38 { t } [ union-1 predicate-class? ] unit-test
39 { "union-1" } [ 8 generic-update-test ] unit-test
40 [ -7 generic-update-test ] must-fail
42 ! Empty unions were causing problems
43 GENERIC: empty-union-test ( obj -- obj )
45 UNION: empty-union-1 ;
47 M: empty-union-1 empty-union-test ;
49 UNION: empty-union-2 ;
51 M: empty-union-2 empty-union-test ;
53 { [ drop f ] } [ \ empty-union-1? def>> ] unit-test
55 ! Redefining a class didn't update containing unions
56 UNION: redefine-bug-1 fixnum ;
58 UNION: redefine-bug-2 redefine-bug-1 quotation ;
60 { t } [ fixnum redefine-bug-2 class<= ] unit-test
61 { t } [ quotation redefine-bug-2 class<= ] unit-test
63 { } [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" eval( -- ) ] unit-test
65 { t } [ bignum redefine-bug-1 class<= ] unit-test
66 { f } [ fixnum redefine-bug-2 class<= ] unit-test
67 { t } [ bignum redefine-bug-2 class<= ] unit-test
69 ! Too eager with reset-class
71 { } [ "IN: classes.union.tests SINGLETON: foo UNION: blah foo ;" <string-reader> "union-reset-test" parse-stream drop ] unit-test
73 { t } [ "blah" "classes.union.tests" lookup-word union-class? ] unit-test
75 { t } [ "foo?" "classes.union.tests" lookup-word predicate? ] unit-test
77 { } [ "IN: classes.union.tests USE: math UNION: blah integer ;" <string-reader> "union-reset-test" parse-stream drop ] unit-test
79 { t } [ "blah" "classes.union.tests" lookup-word union-class? ] unit-test
81 { f } [ "foo?" "classes.union.tests" lookup-word predicate? ] unit-test
83 GENERIC: test-generic ( x -- y )
87 UNION: a-union a-tuple ;
89 M: a-union test-generic ;
91 { f } [ \ test-generic "methods" word-prop assoc-empty? ] unit-test
93 { } [ [ \ a-tuple forget-class ] with-compilation-unit ] unit-test
95 { t } [ \ test-generic "methods" word-prop assoc-empty? ] unit-test
97 ! Fast union predicates
99 { t } [ integer union-of-builtins? ] unit-test
101 { t } [ \ integer? def>> \ fixnum-bitand swap member? ] unit-test
103 { } [ "IN: classes.union.tests USE: math UNION: fast-union-1 fixnum ; UNION: fast-union-2 fast-union-1 bignum ;" eval( -- ) ] unit-test
105 { t } [ "fast-union-2?" "classes.union.tests" lookup-word def>> \ fixnum-bitand swap member? ] unit-test
107 { } [ "IN: classes.union.tests USE: vectors UNION: fast-union-1 vector ;" eval( -- ) ] unit-test
109 { f } [ "fast-union-2?" "classes.union.tests" lookup-word def>> \ fixnum-bitand swap member? ] unit-test
113 TUPLE: stuff { a union{ integer string } } ;
115 { 0 } [ stuff new a>> ] unit-test
116 { 3 } [ stuff new 3 >>a a>> ] unit-test
117 { "asdf" } [ stuff new "asdf" >>a a>> ] unit-test
118 [ stuff new 3.4 >>a a>> ] [ bad-slot-value? ] must-fail-with
120 TUPLE: things { a union{ integer float } } ;
122 { 0 } [ stuff new a>> ] unit-test
123 { 3 } [ stuff new 3 >>a a>> ] unit-test
124 { "asdf" } [ stuff new "asdf" >>a a>> ] unit-test
125 [ stuff new 3.4 >>a a>> ] [ bad-slot-value? ] must-fail-with
127 PREDICATE: numba-ova-10 < union{ float integer }
130 { f } [ 100/3 numba-ova-10? ] unit-test
131 { t } [ 100 numba-ova-10? ] unit-test
132 { t } [ 100.0 numba-ova-10? ] unit-test
133 { f } [ 5 numba-ova-10? ] unit-test
134 { f } [ 5.75 numba-ova-10? ] unit-test
137 [ "IN: issue-420 UNION: omg omg ;" eval( -- ) ]
138 [ error>> cannot-reference-self? ] must-fail-with
144 [ "IN: issue-420 UNION: a b ;" eval( -- ) ]
145 [ error>> cannot-reference-self? ] must-fail-with