basis/functors/functors-tests.factor

   1 USING: classes.struct functors tools.test math words kernel
   2 multiline parser io.streams.string generic ;
   3 QUALIFIED-WITH: alien.c-types c
   4 IN: functors.tests
   5
   6 <<
   7
   8 FUNCTOR: define-box ( T -- )
   9
  10 B DEFINES-CLASS ${T}-box
  11 <B> DEFINES <${B}>
  12
  13 WHERE
  14
  15 TUPLE: B { value T } ;
  16
  17 C: <B> B ( T -- B )
  18
  19 ;FUNCTOR
  20
  21 \ float define-box
  22
  23 >>
  24
  25 { 1 0 } [ define-box ] must-infer-as
  26
  27 [ T{ float-box f 5.0 } ] [ 5.0 <float-box> ] unit-test
  28
  29 : twice ( word -- )
  30     [ execute ] [ execute ] bi ; inline
  31 <<
  32
  33 FUNCTOR: wrapper-test ( W -- )
  34
  35 WW DEFINES ${W}${W}
  36
  37 WHERE
  38
  39 : WW ( a -- b ) \ W twice ; inline
  40
  41 ;FUNCTOR
  42
  43 \ sq wrapper-test
  44
  45 >>
  46
  47 [ 16 ] [ 2 sqsq ] unit-test
  48
  49 <<
  50
  51 FUNCTOR: wrapper-test-2 ( W -- )
  52
  53 W DEFINES ${W}
  54
  55 WHERE
  56
  57 : W ( a b -- c ) \ + execute ;
  58
  59 ;FUNCTOR
  60
  61 "blah" wrapper-test-2
  62
  63 >>
  64
  65 [ 4 ] [ 1 3 blah ] unit-test
  66
  67 <<
  68
  69 FUNCTOR: symbol-test ( W -- )
  70
  71 W DEFINES ${W}
  72
  73 WHERE
  74
  75 SYMBOL: W
  76
  77 ;FUNCTOR
  78
  79 "blorgh" symbol-test
  80
  81 >>
  82
  83 [ blorgh ] [ blorgh ] unit-test
  84
  85 <<
  86
  87 FUNCTOR: generic-test ( W -- )
  88
  89 W DEFINES ${W}
  90
  91 WHERE
  92
  93 GENERIC: W ( a -- b )
  94 M: object W ;
  95 M: integer W 1 + ;
  96
  97 ;FUNCTOR
  98
  99 "snurv" generic-test
 100
 101 >>
 102
 103 [ 2   ] [ 1   snurv ] unit-test
 104 [ 3.0 ] [ 3.0 snurv ] unit-test
 105
 106 ! Does replacing an ordinary word with a functor-generated one work?
 107 [ [ ] ] [
 108     <" IN: functors.tests
 109
 110     TUPLE: some-tuple ;
 111     : some-word ( -- ) ;
 112     GENERIC: some-generic ( a -- b )
 113     M: some-tuple some-generic ;
 114     SYMBOL: some-symbol
 115     "> <string-reader> "functors-test" parse-stream
 116 ] unit-test
 117
 118 : test-redefinition ( -- )
 119     [ t ] [ "some-word" "functors.tests" lookup >boolean ] unit-test
 120     [ t ] [ "some-tuple" "functors.tests" lookup >boolean ] unit-test
 121     [ t ] [ "some-generic" "functors.tests" lookup >boolean ] unit-test
 122     [ t ] [
 123         "some-tuple" "functors.tests" lookup
 124         "some-generic" "functors.tests" lookup method >boolean
 125     ] unit-test ;
 126     [ t ] [ "some-symbol" "functors.tests" lookup >boolean ] unit-test
 127
 128 test-redefinition
 129
 130 FUNCTOR: redefine-test ( W -- )
 131
 132 W-word DEFINES ${W}-word
 133 W-tuple DEFINES-CLASS ${W}-tuple
 134 W-generic DEFINES ${W}-generic
 135 W-symbol DEFINES ${W}-symbol
 136
 137 WHERE
 138
 139 TUPLE: W-tuple ;
 140 : W-word ( -- ) ;
 141 GENERIC: W-generic ( a -- b )
 142 M: W-tuple W-generic ;
 143 SYMBOL: W-symbol
 144
 145 ;FUNCTOR
 146
 147 [ [ ] ] [
 148     <" IN: functors.tests
 149     << "some" redefine-test >>
 150     "> <string-reader> "functors-test" parse-stream
 151 ] unit-test
 152
 153 test-redefinition
 154
 155 <<
 156
 157 FUNCTOR: define-a-struct ( T NAME TYPE N -- )
 158
 159 T-class DEFINES-CLASS ${T}
 160
 161 WHERE
 162
 163 STRUCT: T-class
 164     { NAME c:int }
 165     { x { TYPE 4 } }
 166     { y { c:short N } }
 167     { z TYPE initial: 5 }
 168     { float { c:float 2 } } ;
 169
 170 ;FUNCTOR
 171
 172 "a-struct" "nemo" c:char 2 define-a-struct
 173
 174 >>
 175
 176 [
 177     {
 178         T{ struct-slot-spec
 179             { name "nemo" }
 180             { offset 0 }
 181             { class integer }
 182             { initial 0 }
 183             { type c:int }
 184         }
 185         T{ struct-slot-spec
 186             { name "x" }
 187             { offset 4 }
 188             { class object }
 189             { initial f }
 190             { type { c:char 4 } }
 191         }
 192         T{ struct-slot-spec
 193             { name "y" }
 194             { offset 8 }
 195             { class object }
 196             { initial f }
 197             { type { c:short 2 } }
 198         }
 199         T{ struct-slot-spec
 200             { name "z" }
 201             { offset 12 }
 202             { class fixnum }
 203             { initial 5 }
 204             { type c:char }
 205         }
 206         T{ struct-slot-spec
 207             { name "float" }
 208             { offset 16 }
 209             { class object }
 210             { initial f }
 211             { type { c:float 2 } }
 212         }
 213     }
 214 ] [ a-struct struct-slots ] unit-test
 215