basis/typed/typed-tests.factor

   1 USING: accessors compiler.units effects eval kernel kernel.private layouts
   2 literals math namespaces quotations tools.test typed words words.symbol
   3 combinators.short-circuit compiler.tree.debugger prettyprint definitions
   4 sequences classes.intersection strings classes.union ;
   5 IN: typed.tests
   6
   7 TYPED: f+ ( a: float b: float -- c: float )
   8     + ;
   9
  10 { 3.5 }
  11 [ 2 1+1/2 f+ ] unit-test
  12
  13 TYPED: fix+ ( a: fixnum b: fixnum -- c: fixnum )
  14     + ;
  15
  16 ! XXX: As of .97, we don't require that the output is a fixnum.
  17 ! most-positive-fixnum neg 1 - 1quotation
  18 ! [ most-positive-fixnum 1 fix+ ] unit-test
  19
  20 ! XXX: Check that we throw an error. This used to underflow to the least-positive-fixnum.
  21 [ most-positive-fixnum 1 fix+ ] [ ${ KERNEL-ERROR 7 } head? ] must-fail-with
  22
  23 TUPLE: tweedle-dee ; final
  24 TUPLE: tweedle-dum ; final
  25
  26 TYPED: dee ( x: tweedle-dee -- y )
  27     drop \ tweedle-dee ;
  28
  29 TYPED: dum ( x: tweedle-dum -- y )
  30     drop \ tweedle-dum ;
  31
  32 [ \ tweedle-dum new dee ]
  33 [ { [ input-mismatch-error? ] [ expected-type>> tweedle-dee = ] [ value>> tweedle-dum? ] } 1&& ] must-fail-with
  34
  35 [ \ tweedle-dee new dum ]
  36 [ { [ input-mismatch-error? ] [ expected-type>> tweedle-dum = ] [ value>> tweedle-dee? ] } 1&& ] must-fail-with
  37
  38 TYPED: dumdum ( x -- y: tweedle-dum )
  39     drop \ tweedle-dee new ;
  40
  41 [ f dumdum ]
  42 [ { [ output-mismatch-error? ] [ expected-type>> tweedle-dum = ] [ value>> tweedle-dee? ] } 1&& ] must-fail-with
  43
  44 TYPED:: f+locals ( a: float b: float -- c: float )
  45     a b + ;
  46
  47 { 3.5 } [ 2 1+1/2 f+locals ] unit-test
  48
  49 TUPLE: unboxable
  50     { x fixnum read-only }
  51     { y fixnum read-only } ; final
  52
  53 TUPLE: unboxable2
  54     { u unboxable read-only }
  55     { xy fixnum read-only } ; final
  56
  57 TYPED: unboxy ( in: unboxable -- out: unboxable2 )
  58     dup [ x>> ] [ y>> ] bi - unboxable2 boa ;
  59
  60 { ( in: fixnum in: fixnum -- out: fixnum out: fixnum out: fixnum ) }
  61 [ \ unboxy "typed-word" word-prop stack-effect ] unit-test
  62
  63 { T{ unboxable2 { u T{ unboxable { x 12 } { y 3 } } } { xy 9 } } }
  64 [ T{ unboxable { x 12 } { y 3 } } unboxy ] unit-test
  65
  66 { 9 }
  67 [
  68 "
  69 USING: kernel math ;
  70 IN: typed.tests
  71
  72 TUPLE: unboxable
  73     { x fixnum read-only }
  74     { y fixnum read-only }
  75     { z float read-only } ; final
  76 " eval( -- )
  77
  78 "
  79 USING: accessors kernel math ;
  80 IN: typed.tests
  81 T{ unboxable f 12 3 4.0 } unboxy xy>>
  82 " eval( -- xy )
  83 ] unit-test
  84
  85 TYPED: no-inputs ( -- out: integer )
  86     1 ;
  87
  88 { 1 } [ no-inputs ] unit-test
  89
  90 TUPLE: unboxable3
  91     { x read-only } ; final
  92
  93 TYPED: no-inputs-unboxable-output ( -- out: unboxable3 )
  94     T{ unboxable3 } ;
  95
  96 { T{ unboxable3 } } [ no-inputs-unboxable-output ] unit-test
  97
  98 { f } [ no-inputs-unboxable-output no-inputs-unboxable-output eq? ] unit-test
  99
 100 SYMBOL: buh
 101
 102 TYPED: no-outputs ( x: integer -- )
 103     buh set ;
 104
 105 { 2 } [ 2 no-outputs buh get ] unit-test
 106
 107 TYPED: no-outputs-unboxable-input ( x: unboxable3 -- )
 108     buh set ;
 109
 110 { T{ unboxable3 } } [ T{ unboxable3 } no-outputs-unboxable-input buh get ] unit-test
 111
 112 { f } [
 113     T{ unboxable3 } no-outputs-unboxable-input buh get
 114     T{ unboxable3 } no-outputs-unboxable-input buh get
 115     eq?
 116 ] unit-test
 117
 118 ! Reported by littledan
 119 TUPLE: superclass { x read-only } ;
 120 TUPLE: subclass < superclass { y read-only } ; final
 121
 122 TYPED: unbox-fail ( a: superclass -- ? ) subclass? ;
 123
 124 { t } [ subclass new unbox-fail ] unit-test
 125
 126 ! If a final class becomes non-final, typed words need to be recompiled
 127 TYPED: recompile-fail ( a: subclass -- ? ) buh get eq? ;
 128
 129 { f } [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test
 130
 131 { } [ "IN: typed.tests TUPLE: subclass < superclass { y read-only } ;" eval( -- ) ] unit-test
 132
 133 { t } [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test
 134
 135 ! Make sure that foldable and flushable work on typed words
 136 TYPED: add ( a: integer b: integer -- c: integer ) + ; foldable
 137
 138 { [ 3 ] } [ [ 1 2 add ] cleaned-up-tree nodes>quot ] unit-test
 139
 140 TYPED: flush-test ( s: symbol -- ? ) on t ; flushable
 141
 142 : flush-print-1 ( symbol -- ) flush-test drop ;
 143 : flush-print-2 ( symbol -- ) flush-test . ;
 144
 145 SYMBOL: a-symbol
 146
 147 { f } [
 148     f a-symbol [
 149         a-symbol flush-print-1
 150         a-symbol get
 151     ] with-variable
 152 ] unit-test
 153
 154 { t } [
 155     f a-symbol [
 156         a-symbol flush-print-2
 157         a-symbol get
 158     ] with-variable
 159 ] unit-test
 160
 161 ! Forgetting an unboxed final class should work
 162 TUPLE: forget-class { x read-only } ; final
 163
 164 TYPED: forget-fail ( a: forget-class -- ) drop ;
 165
 166 { } [ [ \ forget-class forget ] with-compilation-unit ] unit-test
 167
 168 { } [ [ \ forget-fail forget ] with-compilation-unit ] unit-test
 169
 170 TYPED: typed-maybe ( x: maybe{ integer } -- ? ) >boolean ;
 171
 172 { f } [ f typed-maybe ] unit-test
 173 { t } [ 30 typed-maybe ] unit-test
 174 [ 30.0 typed-maybe ] [ input-mismatch-error? ] must-fail-with
 175
 176 TYPED: typed-union ( x: union{ integer string } -- ? ) >boolean ;
 177
 178 { t } [ 3 typed-union ] unit-test
 179 { t } [ "asdf" typed-union ] unit-test
 180 [ 3.3 typed-union ] [ input-mismatch-error? ] must-fail-with
 181
 182 TYPED: typed-intersection ( x: intersection{ integer bignum } -- ? ) >boolean ;
 183
 184 { t } [ 5555555555555555555555555555555555555555555555555555 typed-intersection ] unit-test
 185 [ 0 typed-intersection ] [ input-mismatch-error? ] must-fail-with
 186
 187 [
 188     "IN: test123 USE: typed TYPED: foo ( x -- y ) ;" eval( -- )
 189 ] [ error>> no-types-specified? ] must-fail-with