basis/typed/typed-tests.factor

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