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" <string-reader> "functors-test" parse-stream
 115 ] unit-test
 116
 117 : test-redefinition ( -- )
 118     [ t ] [ "some-word" "functors.tests" lookup >boolean ] unit-test
 119     [ t ] [ "some-tuple" "functors.tests" lookup >boolean ] unit-test
 120     [ t ] [ "some-generic" "functors.tests" lookup >boolean ] unit-test
 121     [ t ] [
 122         "some-tuple" "functors.tests" lookup
 123         "some-generic" "functors.tests" lookup method >boolean
 124     ] unit-test ;
 125     [ t ] [ "some-symbol" "functors.tests" lookup >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:int }
 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:int }
 182         }
 183         T{ struct-slot-spec
 184             { name "x" }
 185             { offset 4 }
 186             { class object }
 187             { initial f }
 188             { type { c:char 4 } }
 189         }
 190         T{ struct-slot-spec
 191             { name "y" }
 192             { offset 8 }
 193             { class object }
 194             { initial f }
 195             { type { c:short 2 } }
 196         }
 197         T{ struct-slot-spec
 198             { name "z" }
 199             { offset 12 }
 200             { class fixnum }
 201             { initial 5 }
 202             { type c:char }
 203         }
 204         T{ struct-slot-spec
 205             { name "float" }
 206             { offset 16 }
 207             { class object }
 208             { initial f }
 209             { type { c:float 2 } }
 210         }
 211     }
 212 ] [ a-struct struct-slots ] unit-test
 213