basis/functors/functors-tests.factor

   1 USING: classes.struct classes.tuple functors tools.test math
   2 words kernel 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
  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 ;
  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" <string-reader> "functors-test" parse-stream
 115 ] unit-test
 116
 117 : test-redefinition ( -- )
 118     [ t ] [ "some-word" "functors.tests" lookup-word >boolean ] unit-test
 119     [ t ] [ "some-tuple" "functors.tests" lookup-word >boolean ] unit-test
 120     [ t ] [ "some-generic" "functors.tests" lookup-word >boolean ] unit-test
 121     [ t ] [
 122         "some-tuple" "functors.tests" lookup-word
 123         "some-generic" "functors.tests" lookup-word lookup-method >boolean
 124     ] unit-test ;
 125     [ t ] [ "some-symbol" "functors.tests" lookup-word >boolean ] unit-test
 126
 127 test-redefinition
 128
 129 <FUNCTOR: redefine-test ( W -- )
 130
 131 W-word DEFINES ${W}-word
 132 W-tuple DEFINES-CLASS ${W}-tuple
 133 W-generic DEFINES ${W}-generic
 134 W-symbol DEFINES ${W}-symbol
 135
 136 WHERE
 137
 138 TUPLE: W-tuple ;
 139 : W-word ( -- ) ;
 140 GENERIC: W-generic ( a -- b )
 141 M: W-tuple W-generic ;
 142 SYMBOL: W-symbol
 143
 144 ;FUNCTOR>
 145
 146 [ [ ] ] [
 147     "IN: functors.tests
 148     << \"some\" redefine-test >>" <string-reader> "functors-test" parse-stream
 149 ] unit-test
 150
 151 test-redefinition
 152
 153 <<
 154
 155 <FUNCTOR: define-a-struct ( T NAME TYPE N -- )
 156
 157 T-class DEFINES-CLASS ${T}
 158
 159 WHERE
 160
 161 STRUCT: T-class
 162     { NAME c:longlong }
 163     { x { TYPE 4 } }
 164     { y { c:short N } }
 165     { z TYPE initial: 5 }
 166     { float { c:float 2 } } ;
 167
 168 ;FUNCTOR>
 169
 170 "a-struct" "nemo" c:char 2 define-a-struct
 171
 172 >>
 173
 174 [
 175     {
 176         T{ struct-slot-spec
 177             { name "nemo" }
 178             { offset 0 }
 179             { class integer }
 180             { initial 0 }
 181             { type c:longlong }
 182         }
 183         T{ struct-slot-spec
 184             { name "x" }
 185             { offset 8 }
 186             { class object }
 187             { initial f }
 188             { type { c:char 4 } }
 189         }
 190         T{ struct-slot-spec
 191             { name "y" }
 192             { offset 12 }
 193             { class object }
 194             { initial f }
 195             { type { c:short 2 } }
 196         }
 197         T{ struct-slot-spec
 198             { name "z" }
 199             { offset 16 }
 200             { class fixnum }
 201             { initial 5 }
 202             { type c:char }
 203         }
 204         T{ struct-slot-spec
 205             { name "float" }
 206             { offset 20 }
 207             { class object }
 208             { initial f }
 209             { type { c:float 2 } }
 210         }
 211     }
 212 ] [ a-struct struct-slots ] unit-test
 213
 214 <<
 215
 216 <FUNCTOR: define-an-inline-word ( W -- )
 217
 218 W DEFINES ${W}
 219 W-W DEFINES ${W}-${W}
 220
 221 WHERE
 222
 223 : W ( -- ) ; inline
 224 : W-W ( -- ) W W ;
 225
 226 ;FUNCTOR>
 227
 228 "an-inline-word" define-an-inline-word
 229
 230 >>
 231
 232 [ t ] [ \ an-inline-word inline? ] unit-test
 233 [ f ] [ \ an-inline-word-an-inline-word inline? ] unit-test
 234
 235 <<
 236
 237 <FUNCTOR: define-a-final-class ( T W -- )
 238
 239 T DEFINES-CLASS ${T}
 240 W DEFINES ${W}
 241
 242 WHERE
 243
 244 TUPLE: T ; final
 245
 246 : W ( -- ) ;
 247
 248 ;FUNCTOR>
 249
 250 "a-final-tuple" "a-word" define-a-final-class
 251
 252 >>
 253
 254 [ t ] [ a-final-tuple final-class? ] unit-test