core/classes/union/union-tests.factor

   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
   9
  10 ! DEFER: bah
  11 ! FORGET: bah
  12 UNION: bah fixnum alien ;
  13 [ bah ] [ \ bah? "predicating" word-prop ] unit-test
  14
  15 [ "USING: alien math ;\nIN: classes.union.tests\nUNION: bah fixnum alien ;\n" ]
  16 [ [ \ bah see ] with-string-writer ] unit-test
  17
  18 ! Test redefinition of classes
  19 UNION: union-1 fixnum float ;
  20
  21 GENERIC: generic-update-test ( x -- y )
  22
  23 M: union-1 generic-update-test drop "union-1" ;
  24
  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
  28
  29 "IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" eval( -- )
  30
  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
  34
  35 "IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" eval( -- )
  36
  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
  41
  42 ! Empty unions were causing problems
  43 GENERIC: empty-union-test ( obj -- obj )
  44
  45 UNION: empty-union-1 ;
  46
  47 M: empty-union-1 empty-union-test ;
  48
  49 UNION: empty-union-2 ;
  50
  51 M: empty-union-2 empty-union-test ;
  52
  53 [ [ drop f ] ] [ \ empty-union-1? def>> ] unit-test
  54
  55 ! Redefining a class didn't update containing unions
  56 UNION: redefine-bug-1 fixnum ;
  57
  58 UNION: redefine-bug-2 redefine-bug-1 quotation ;
  59
  60 [ t ] [ fixnum redefine-bug-2 class<= ] unit-test
  61 [ t ] [ quotation redefine-bug-2 class<= ] unit-test
  62
  63 [ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" eval( -- ) ] unit-test
  64
  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
  68
  69 ! Too eager with reset-class
  70
  71 [ ] [ "IN: classes.union.tests SINGLETON: foo UNION: blah foo ;" <string-reader> "union-reset-test" parse-stream drop ] unit-test
  72
  73 [ t ] [ "blah" "classes.union.tests" lookup-word union-class? ] unit-test
  74
  75 [ t ] [ "foo?" "classes.union.tests" lookup-word predicate? ] unit-test
  76
  77 [ ] [ "IN: classes.union.tests USE: math UNION: blah integer ;" <string-reader> "union-reset-test" parse-stream drop ] unit-test
  78
  79 [ t ] [ "blah" "classes.union.tests" lookup-word union-class? ] unit-test
  80
  81 [ f ] [ "foo?" "classes.union.tests" lookup-word predicate? ] unit-test
  82
  83 GENERIC: test-generic ( x -- y )
  84
  85 TUPLE: a-tuple ;
  86
  87 UNION: a-union a-tuple ;
  88
  89 M: a-union test-generic ;
  90
  91 [ f ] [ \ test-generic "methods" word-prop assoc-empty? ] unit-test
  92
  93 [ ] [ [ \ a-tuple forget-class ] with-compilation-unit ] unit-test
  94
  95 [ t ] [ \ test-generic "methods" word-prop assoc-empty? ] unit-test
  96
  97 ! Fast union predicates
  98
  99 [ t ] [ integer union-of-builtins? ] unit-test
 100
 101 [ t ] [ \ integer? def>> \ fixnum-bitand swap member? ] unit-test
 102
 103 [ ] [ "IN: classes.union.tests USE: math UNION: fast-union-1 fixnum ; UNION: fast-union-2 fast-union-1 bignum ;" eval( -- ) ] unit-test
 104
 105 [ t ] [ "fast-union-2?" "classes.union.tests" lookup-word def>> \ fixnum-bitand swap member? ] unit-test
 106
 107 [ ] [ "IN: classes.union.tests USE: vectors UNION: fast-union-1 vector ;" eval( -- ) ] unit-test
 108
 109 [ f ] [ "fast-union-2?" "classes.union.tests" lookup-word def>> \ fixnum-bitand swap member? ] unit-test
 110
 111 ! Test union{
 112
 113 TUPLE: stuff { a union{ integer string } } ;
 114
 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
 119
 120 TUPLE: things { a union{ integer float } } ;
 121
 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
 126
 127 PREDICATE: numba-ova-10 < union{ float integer }
 128     10 > ;
 129
 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
 135
 136 ! Issue #420 lol
 137 [ "IN: issue-420 UNION: omg omg ;" eval( -- ) ]
 138 [ error>> cannot-reference-self? ] must-fail-with
 139
 140 IN: issue-420
 141 UNION: a ;
 142 UNION: b a ;
 143
 144 [ "IN: issue-420 UNION: a b ;" eval( -- ) ]
 145 [ error>> cannot-reference-self? ] must-fail-with