core/generic/standard/standard-tests.factor

   1 IN: generic.standard.tests
   2 USING: tools.test math math.functions math.constants
   3 generic.standard strings sequences arrays kernel accessors
   4 words float-arrays byte-arrays bit-arrays parser namespaces
   5 quotations inference vectors growable hashtables sbufs
   6 prettyprint byte-vectors bit-vectors float-vectors definitions
   7 generic sets graphs assocs ;
   8
   9 GENERIC: lo-tag-test
  10
  11 M: integer lo-tag-test 3 + ;
  12
  13 M: float lo-tag-test 4 - ;
  14
  15 M: rational lo-tag-test 2 - ;
  16
  17 M: complex lo-tag-test sq ;
  18
  19 [ 8 ] [ 5 >bignum lo-tag-test ] unit-test
  20 [ 0.0 ] [ 4.0 lo-tag-test ] unit-test
  21 [ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
  22 [ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
  23
  24 GENERIC: hi-tag-test
  25
  26 M: string hi-tag-test ", in bed" append ;
  27
  28 M: integer hi-tag-test 3 + ;
  29
  30 M: array hi-tag-test [ hi-tag-test ] map ;
  31
  32 M: sequence hi-tag-test reverse ;
  33
  34 [ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test
  35
  36 [ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test
  37
  38 [ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test
  39
  40 TUPLE: shape ;
  41
  42 TUPLE: abstract-rectangle < shape width height ;
  43
  44 TUPLE: rectangle < abstract-rectangle ;
  45
  46 C: <rectangle> rectangle
  47
  48 TUPLE: parallelogram < abstract-rectangle skew ;
  49
  50 C: <parallelogram> parallelogram
  51
  52 TUPLE: circle < shape radius ;
  53
  54 C: <circle> circle
  55
  56 GENERIC: area
  57
  58 M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
  59
  60 M: circle area radius>> sq pi * ;
  61
  62 [ 12 ] [ 4 3 <rectangle> area ] unit-test
  63 [ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
  64 [ t ] [ 2 <circle> area 4 pi * = ] unit-test
  65
  66 GENERIC: perimiter
  67
  68 : rectangle-perimiter + 2 * ;
  69
  70 M: rectangle perimiter
  71     [ width>> ] [ height>> ] bi
  72     rectangle-perimiter ;
  73
  74 : hypotenuse [ sq ] bi@ + sqrt ;
  75
  76 M: parallelogram perimiter
  77     [ width>> ]
  78     [ [ height>> ] [ skew>> ] bi hypotenuse ] bi
  79     rectangle-perimiter ;
  80
  81 M: circle perimiter 2 * pi * ;
  82
  83 [ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
  84 [ 30 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
  85
  86 GENERIC: big-mix-test
  87
  88 M: object big-mix-test drop "object" ;
  89
  90 M: tuple big-mix-test drop "tuple" ;
  91
  92 M: integer big-mix-test drop "integer" ;
  93
  94 M: float big-mix-test drop "float" ;
  95
  96 M: complex big-mix-test drop "complex" ;
  97
  98 M: string big-mix-test drop "string" ;
  99
 100 M: array big-mix-test drop "array" ;
 101
 102 M: sequence big-mix-test drop "sequence" ;
 103
 104 M: rectangle big-mix-test drop "rectangle" ;
 105
 106 M: parallelogram big-mix-test drop "parallelogram" ;
 107
 108 M: circle big-mix-test drop "circle" ;
 109
 110 [ "integer" ] [ 3 big-mix-test ] unit-test
 111 [ "float" ] [ 5.0 big-mix-test ] unit-test
 112 [ "complex" ] [ -1 sqrt big-mix-test ] unit-test
 113 [ "sequence" ] [ F{ 1.0 2.0 3.0 } big-mix-test ] unit-test
 114 [ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
 115 [ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
 116 [ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
 117 [ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
 118 [ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
 119 [ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
 120 [ "sequence" ] [ FV{ -0.3 4.6 } big-mix-test ] unit-test
 121 [ "string" ] [ "hello" big-mix-test ] unit-test
 122 [ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
 123 [ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
 124 [ "circle" ] [ 100 <circle> big-mix-test ] unit-test
 125 [ "tuple" ] [ H{ } big-mix-test ] unit-test
 126 [ "object" ] [ \ + big-mix-test ] unit-test
 127
 128 GENERIC: small-lo-tag
 129
 130 M: fixnum small-lo-tag drop "fixnum" ;
 131
 132 M: string small-lo-tag drop "string" ;
 133
 134 M: array small-lo-tag drop "array" ;
 135
 136 M: float-array small-lo-tag drop "float-array" ;
 137
 138 M: byte-array small-lo-tag drop "byte-array" ;
 139
 140 [ "fixnum" ] [ 3 small-lo-tag ] unit-test
 141
 142 [ "float-array" ] [ F{ 1.0 } small-lo-tag ] unit-test
 143
 144 ! Testing next-method
 145 TUPLE: person ;
 146
 147 TUPLE: intern < person ;
 148
 149 TUPLE: employee < person ;
 150
 151 TUPLE: tape-monkey < employee ;
 152
 153 TUPLE: manager < employee ;
 154
 155 TUPLE: junior-manager < manager ;
 156
 157 TUPLE: middle-manager < manager ;
 158
 159 TUPLE: senior-manager < manager ;
 160
 161 TUPLE: executive < senior-manager ;
 162
 163 TUPLE: ceo < executive ;
 164
 165 GENERIC: salary ( person -- n )
 166
 167 M: intern salary
 168     #! Intentional mistake.
 169     call-next-method ;
 170
 171 M: employee salary drop 24000 ;
 172
 173 M: manager salary call-next-method 12000 + ;
 174
 175 M: middle-manager salary call-next-method 5000 + ;
 176
 177 M: senior-manager salary call-next-method 15000 + ;
 178
 179 M: executive salary call-next-method 2 * ;
 180
 181 M: ceo salary
 182     #! Intentional error.
 183     drop 5 call-next-method 3 * ;
 184
 185 [ salary ] must-infer
 186
 187 [ 24000 ] [ employee boa salary ] unit-test
 188
 189 [ 24000 ] [ tape-monkey boa salary ] unit-test
 190
 191 [ 36000 ] [ junior-manager boa salary ] unit-test
 192
 193 [ 41000 ] [ middle-manager boa salary ] unit-test
 194
 195 [ 51000 ] [ senior-manager boa salary ] unit-test
 196
 197 [ 102000 ] [ executive boa salary ] unit-test
 198
 199 [ ceo boa salary ]
 200 [ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
 201
 202 [ intern boa salary ]
 203 [ T{ no-next-method f intern salary } = ] must-fail-with
 204
 205 ! Weird shit
 206 TUPLE: a ;
 207 TUPLE: b ;
 208 TUPLE: c ;
 209
 210 UNION: x a b ;
 211 UNION: y a c ;
 212
 213 UNION: z x y ;
 214
 215 GENERIC: funky* ( obj -- )
 216
 217 M: z funky* "z" , drop ;
 218
 219 M: x funky* "x" , call-next-method ;
 220
 221 M: y funky* "y" , call-next-method ;
 222
 223 M: a funky* "a" , call-next-method ;
 224
 225 M: b funky* "b" , call-next-method ;
 226
 227 M: c funky* "c" , call-next-method ;
 228
 229 : funky [ funky* ] { } make ;
 230
 231 [ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
 232
 233 [ { "c" "y" "z" } ] [ T{ c } funky ] unit-test
 234
 235 [ t ] [
 236     T{ a } funky
 237     { { "a" "x" "z" } { "a" "y" "z" } } member?
 238 ] unit-test
 239
 240 ! Hooks
 241 SYMBOL: my-var
 242 HOOK: my-hook my-var ( -- x )
 243
 244 M: integer my-hook "an integer" ;
 245 M: string my-hook "a string" ;
 246
 247 [ "an integer" ] [ 3 my-var set my-hook ] unit-test
 248 [ "a string" ] [ my-hook my-var set my-hook ] unit-test
 249 [ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
 250
 251 HOOK: my-tuple-hook my-var ( -- x )
 252
 253 M: sequence my-tuple-hook my-hook ;
 254
 255 TUPLE: m-t-h-a ;
 256
 257 M: m-t-h-a my-tuple-hook "foo" ;
 258
 259 TUPLE: m-t-h-b < m-t-h-a ;
 260
 261 M: m-t-h-b my-tuple-hook "bar" ;
 262
 263 [ f ] [
 264     \ my-tuple-hook [ "engines" word-prop ] keep prefix
 265     [ 1quotation infer ] map all-equal?
 266 ] unit-test
 267
 268 HOOK: call-next-hooker my-var ( -- x )
 269
 270 M: sequence call-next-hooker "sequence" ;
 271
 272 M: array call-next-hooker call-next-method "array " prepend ;
 273
 274 M: vector call-next-hooker call-next-method "vector " prepend ;
 275
 276 M: growable call-next-hooker call-next-method "growable " prepend ;
 277
 278 [ "vector growable sequence" ] [
 279     V{ } my-var [ call-next-hooker ] with-variable
 280 ] unit-test
 281
 282 GENERIC: no-stack-effect-decl
 283
 284 M: hashtable no-stack-effect-decl ;
 285 M: vector no-stack-effect-decl ;
 286 M: sbuf no-stack-effect-decl ;
 287
 288 [ ] [ \ no-stack-effect-decl see ] unit-test
 289
 290 [ ] [ \ no-stack-effect-decl word-def . ] unit-test
 291
 292 ! Cross-referencing with generic words
 293 TUPLE: xref-tuple-1 ;
 294 TUPLE: xref-tuple-2 < xref-tuple-1 ;
 295
 296 : (xref-test) drop ;
 297
 298 GENERIC: xref-test ( obj -- )
 299
 300 M: xref-tuple-1 xref-test (xref-test) ;
 301 M: xref-tuple-2 xref-test (xref-test) ;
 302
 303 [ t ] [
 304     \ xref-test
 305     \ xref-tuple-1 \ xref-test method [ usage unique ] closure key?
 306 ] unit-test
 307
 308 [ t ] [
 309     \ xref-test
 310     \ xref-tuple-2 \ xref-test method [ usage unique ] closure key?
 311 ] unit-test