core/generic/standard/standard-tests.factor

   1 USING: tools.test math math.functions math.constants
   2 generic.standard generic.single strings sequences arrays kernel
   3 accessors words byte-arrays bit-arrays parser namespaces make
   4 quotations stack-checker vectors growable hashtables sbufs
   5 prettyprint byte-vectors bit-vectors specialized-vectors
   6 definitions generic sets graphs assocs grouping see eval
   7 classes.union classes.tuple compiler.units io.streams.string
   8 compiler.crossref math.order ;
   9 QUALIFIED-WITH: alien.c-types c
  10 FROM: namespaces => set ;
  11 SPECIALIZED-VECTOR: c:double
  12 IN: generic.standard.tests
  13
  14 GENERIC: class-of ( x -- y )
  15
  16 M: fixnum class-of drop "fixnum" ;
  17 M: word   class-of drop "word"   ;
  18
  19 [ "fixnum" ] [ 5 class-of ] unit-test
  20 [ "word" ] [ \ class-of class-of ] unit-test
  21 [ 3.4 class-of ] must-fail
  22
  23 GENERIC: foobar ( x -- y )
  24 M: object foobar drop "Hello world" ;
  25 M: fixnum foobar drop "Goodbye cruel world" ;
  26
  27 [ "Hello world" ] [ 4 foobar foobar ] unit-test
  28 [ "Goodbye cruel world" ] [ 4 foobar ] unit-test
  29
  30 GENERIC: lo-tag-test ( obj -- obj' )
  31
  32 M: integer lo-tag-test 3 + ;
  33 M: float lo-tag-test 4 - ;
  34 M: rational lo-tag-test 2 - ;
  35 M: complex lo-tag-test sq ;
  36
  37 [ 8 ] [ 5 >bignum lo-tag-test ] unit-test
  38 [ 0.0 ] [ 4.0 lo-tag-test ] unit-test
  39 [ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
  40 [ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
  41
  42 GENERIC: hi-tag-test ( obj -- obj' )
  43
  44 M: string hi-tag-test ", in bed" append ;
  45 M: integer hi-tag-test 3 + ;
  46 M: array hi-tag-test [ hi-tag-test ] map ;
  47 M: sequence hi-tag-test reverse ;
  48
  49 [ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test
  50
  51 [ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test
  52
  53 [ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test
  54
  55 UNION: funnies quotation float complex ;
  56
  57 GENERIC: funny ( x -- y )
  58 M: funnies funny drop 2 ;
  59 M: object funny drop 0 ;
  60
  61 GENERIC: union-containment ( x -- y )
  62 M: integer union-containment drop 1 ;
  63 M: number union-containment drop 2 ;
  64
  65 [ 1 ] [ 1 union-containment ] unit-test
  66 [ 2 ] [ 1.0 union-containment ] unit-test
  67
  68 [ 2 ] [ [ { } ] funny ] unit-test
  69 [ 0 ] [ { } funny ] unit-test
  70
  71 TUPLE: shape ;
  72
  73 TUPLE: abstract-rectangle < shape width height ;
  74
  75 TUPLE: rectangle < abstract-rectangle ;
  76
  77 C: <rectangle> rectangle
  78
  79 TUPLE: parallelogram < abstract-rectangle skew ;
  80
  81 C: <parallelogram> parallelogram
  82
  83 TUPLE: circle < shape radius ;
  84
  85 C: <circle> circle
  86
  87 GENERIC: area ( shape -- n )
  88
  89 M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
  90
  91 M: circle area radius>> sq pi * ;
  92
  93 [ 12 ] [ 4 3 <rectangle> area ] unit-test
  94 [ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
  95 [ t ] [ 2 <circle> area 4 pi * = ] unit-test
  96
  97 GENERIC: perimeter ( shape -- n )
  98
  99 : rectangle-perimeter ( l w -- n ) + 2 * ;
 100
 101 M: rectangle perimeter
 102     [ width>> ] [ height>> ] bi
 103     rectangle-perimeter ;
 104
 105 : hypotenuse ( a b -- c ) [ sq ] bi@ + sqrt ;
 106
 107 M: parallelogram perimeter
 108     [ width>> ]
 109     [ [ height>> ] [ skew>> ] bi hypotenuse ] bi
 110     rectangle-perimeter ;
 111
 112 M: circle perimeter 2 * pi * ;
 113
 114 [ 14 ] [ 4 3 <rectangle> perimeter ] unit-test
 115 [ 30.0 ] [ 10 4 3 <parallelogram> perimeter ] unit-test
 116
 117 PREDICATE: very-funny < funnies number? ;
 118
 119 GENERIC: gooey ( x -- y )
 120 M: very-funny gooey sq ;
 121
 122 [ 0.25 ] [ 0.5 gooey ] unit-test
 123
 124 GENERIC: empty-method-test ( x -- y )
 125 M: object empty-method-test ;
 126 TUPLE: for-arguments-sake ;
 127 C: <for-arguments-sake> for-arguments-sake
 128
 129 M: for-arguments-sake empty-method-test drop "Hi" ;
 130
 131 TUPLE: another-one ;
 132 C: <another-one> another-one
 133
 134 [ "Hi" ] [ <for-arguments-sake> empty-method-test empty-method-test ] unit-test
 135 [ T{ another-one f } ] [ <another-one> empty-method-test ] unit-test
 136
 137 GENERIC: big-mix-test ( obj -- obj' )
 138
 139 M: object big-mix-test drop "object" ;
 140
 141 M: tuple big-mix-test drop "tuple" ;
 142
 143 M: integer big-mix-test drop "integer" ;
 144
 145 M: float big-mix-test drop "float" ;
 146
 147 M: complex big-mix-test drop "complex" ;
 148
 149 M: string big-mix-test drop "string" ;
 150
 151 M: array big-mix-test drop "array" ;
 152
 153 M: sequence big-mix-test drop "sequence" ;
 154
 155 M: rectangle big-mix-test drop "rectangle" ;
 156
 157 M: parallelogram big-mix-test drop "parallelogram" ;
 158
 159 M: circle big-mix-test drop "circle" ;
 160
 161 [ "integer" ] [ 3 big-mix-test ] unit-test
 162 [ "float" ] [ 5.0 big-mix-test ] unit-test
 163 [ "complex" ] [ -1 sqrt big-mix-test ] unit-test
 164 [ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
 165 [ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
 166 [ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
 167 [ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
 168 [ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
 169 [ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
 170 [ "string" ] [ "hello" big-mix-test ] unit-test
 171 [ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
 172 [ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
 173 [ "circle" ] [ 100 <circle> big-mix-test ] unit-test
 174 [ "tuple" ] [ H{ } big-mix-test ] unit-test
 175 [ "object" ] [ \ + big-mix-test ] unit-test
 176
 177 GENERIC: small-lo-tag ( obj -- obj )
 178
 179 M: fixnum small-lo-tag drop "fixnum" ;
 180
 181 M: string small-lo-tag drop "string" ;
 182
 183 M: array small-lo-tag drop "array" ;
 184
 185 M: double-array small-lo-tag drop "double-array" ;
 186
 187 M: byte-array small-lo-tag drop "byte-array" ;
 188
 189 [ "fixnum" ] [ 3 small-lo-tag ] unit-test
 190
 191 [ "double-array" ] [ double-array{ 1.0 } small-lo-tag ] unit-test
 192
 193 ! Testing recovery from bad method definitions
 194 "IN: generic.standard.tests GENERIC: unhappy ( x -- x )" eval( -- )
 195 [
 196     "IN: generic.standard.tests M: dictionary unhappy ;" eval( -- )
 197 ] must-fail
 198 [ ] [ "IN: generic.standard.tests GENERIC: unhappy ( x -- x )" eval( -- ) ] unit-test
 199
 200 GENERIC# complex-combination 1 ( a b -- c )
 201 M: string complex-combination drop ;
 202 M: object complex-combination nip ;
 203
 204 [ "hi" ] [ "hi" 3 complex-combination ] unit-test
 205 [ "hi" ] [ 3 "hi" complex-combination ] unit-test
 206
 207 ! Regression
 208 TUPLE: first-one ;
 209 TUPLE: second-one ;
 210 UNION: both first-one union-class ;
 211
 212 GENERIC: wii ( x -- y )
 213 M: both wii drop 3 ;
 214 M: second-one wii drop 4 ;
 215 M: tuple-class wii drop 5 ;
 216 M: integer wii drop 6 ;
 217
 218 [ 3 ] [ T{ first-one } wii ] unit-test
 219
 220 GENERIC: tag-and-f ( x -- x x )
 221
 222 M: fixnum tag-and-f 1 ;
 223
 224 M: bignum tag-and-f 2 ;
 225
 226 M: float tag-and-f 3 ;
 227
 228 M: f tag-and-f 4 ;
 229
 230 [ f 4 ] [ f tag-and-f ] unit-test
 231
 232 [ 3.4 3 ] [ 3.4 tag-and-f ] unit-test
 233
 234 ! Issues with forget
 235 GENERIC: generic-forget-test ( a -- b )
 236
 237 M: f generic-forget-test ;
 238
 239 [ ] [ \ f \ generic-forget-test lookup-method "m" set ] unit-test
 240
 241 [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
 242
 243 [ ] [ "IN: generic.standard.tests M: f generic-forget-test ;" eval( -- ) ] unit-test
 244
 245 [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
 246
 247 [ f ] [ f generic-forget-test ] unit-test
 248
 249 ! erg's regression
 250 [ ] [
 251     """IN: generic.standard.tests
 252
 253     GENERIC: jeah ( a -- b )
 254     TUPLE: boii ;
 255     M: boii jeah ;
 256     GENERIC: jeah* ( a -- b )
 257     M: boii jeah* jeah ;""" eval( -- )
 258
 259     """IN: generic.standard.tests
 260     FORGET: boii""" eval( -- )
 261
 262     """IN: generic.standard.tests
 263     TUPLE: boii ;
 264     M: boii jeah ;""" eval( -- )
 265 ] unit-test
 266
 267 ! Testing next-method
 268 TUPLE: person ;
 269
 270 TUPLE: intern < person ;
 271
 272 TUPLE: employee < person ;
 273
 274 TUPLE: tape-monkey < employee ;
 275
 276 TUPLE: manager < employee ;
 277
 278 TUPLE: junior-manager < manager ;
 279
 280 TUPLE: middle-manager < manager ;
 281
 282 TUPLE: senior-manager < manager ;
 283
 284 TUPLE: executive < senior-manager ;
 285
 286 TUPLE: ceo < executive ;
 287
 288 GENERIC: salary ( person -- n )
 289
 290 M: intern salary
 291     #! Intentional mistake.
 292     call-next-method ;
 293
 294 M: employee salary drop 24000 ;
 295
 296 M: manager salary call-next-method 12000 + ;
 297
 298 M: middle-manager salary call-next-method 5000 + ;
 299
 300 M: senior-manager salary call-next-method 15000 + ;
 301
 302 M: executive salary call-next-method 2 * ;
 303
 304 M: ceo salary
 305     #! Intentional error.
 306     drop 5 call-next-method 3 * ;
 307
 308 [ salary ] must-infer
 309
 310 [ 24000 ] [ employee boa salary ] unit-test
 311
 312 [ 24000 ] [ tape-monkey boa salary ] unit-test
 313
 314 [ 36000 ] [ junior-manager boa salary ] unit-test
 315
 316 [ 41000 ] [ middle-manager boa salary ] unit-test
 317
 318 [ 51000 ] [ senior-manager boa salary ] unit-test
 319
 320 [ 102000 ] [ executive boa salary ] unit-test
 321
 322 [ ceo boa salary ]
 323 [ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
 324
 325 [ intern boa salary ]
 326 [ no-next-method? ] must-fail-with
 327
 328 ! Weird shit
 329 TUPLE: a ;
 330 TUPLE: b ;
 331 TUPLE: c ;
 332
 333 UNION: x a b ;
 334 UNION: y a c ;
 335
 336 UNION: z x y ;
 337
 338 GENERIC: funky* ( obj -- )
 339
 340 M: z funky* "z" , drop ;
 341
 342 M: x funky* "x" , call-next-method ;
 343
 344 M: y funky* "y" , call-next-method ;
 345
 346 M: a funky* "a" , call-next-method ;
 347
 348 M: b funky* "b" , call-next-method ;
 349
 350 M: c funky* "c" , call-next-method ;
 351
 352 : funky ( obj -- seq ) [ funky* ] { } make ;
 353
 354 [ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
 355
 356 [ { "c" "y" "z" } ] [ T{ c } funky ] unit-test
 357
 358 [ t ] [
 359     T{ a } funky
 360     { { "a" "x" "z" } { "a" "y" "z" } } member?
 361 ] unit-test
 362
 363 ! Changing method combination should not fail
 364 [ ] [ "IN: generic.standard.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test
 365 [ ] [ "IN: generic.standard.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test
 366
 367 [ f ] [ "xyz" "generic.standard.tests" lookup-word pic-def>> ] unit-test
 368 [ f ] [ "xyz" "generic.standard.tests" lookup-word "decision-tree" word-prop ] unit-test
 369
 370 ! Corner case
 371 [ "IN: generic.standard.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ]
 372 [ error>> bad-dispatch-position? ]
 373 must-fail-with
 374
 375 ! Generic words cannot be inlined
 376 [ ] [ "IN: generic.standard.tests GENERIC: foo ( -- x )" eval( -- ) ] unit-test
 377 [ "IN: generic.standard.tests GENERIC: foo ( -- x ) inline" eval( -- ) ] must-fail
 378
 379 ! Moving a method from one vocab to another didn't always work
 380 GENERIC: move-method-generic ( a -- b )
 381
 382 [ ] [ "IN: generic.standard.tests.a USE: strings USE: generic.standard.tests M: string move-method-generic ;" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
 383
 384 [ ] [ "IN: generic.standard.tests.b USE: strings USE: generic.standard.tests M: string move-method-generic ;" <string-reader> "move-method-test-2" parse-stream drop ] unit-test
 385
 386 [ ] [ "IN: generic.standard.tests.a" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
 387
 388 [ { string } ] [ \ move-method-generic order ] unit-test
 389
 390 ! FORGET: on method wrappers
 391 GENERIC: forget-test ( a -- b )
 392
 393 M: integer forget-test 3 + ;
 394
 395 [ ] [ "IN: generic.standard.tests USE: math FORGET: M\\ integer forget-test" eval( -- ) ] unit-test
 396
 397 [ { } ] [
 398     \ + effect-dependencies-of keys [ method? ] filter
 399     [ "method-generic" word-prop \ forget-test eq? ] filter
 400 ] unit-test
 401
 402 [ 10 forget-test ] [ no-method? ] must-fail-with
 403
 404 ! Declarations on methods
 405 GENERIC: flushable-generic ( a -- b ) flushable
 406 M: integer flushable-generic ;
 407
 408 [ t ] [ \ flushable-generic flushable? ] unit-test
 409 [ t ] [ M\ integer flushable-generic flushable? ] unit-test
 410
 411 GENERIC: non-flushable-generic ( a -- b )
 412 M: integer non-flushable-generic ; flushable
 413
 414 [ f ] [ \ non-flushable-generic flushable? ] unit-test
 415 [ t ] [ M\ integer non-flushable-generic flushable? ] unit-test
 416
 417 ! method-for-object, method-for-class, effective-method
 418 GENERIC: foozul ( a -- b )
 419 M: reversed foozul ;
 420 M: integer foozul ;
 421 M: slice foozul ;
 422
 423 [ ] [ reversed \ foozul method-for-class M\ reversed foozul assert= ] unit-test
 424 [ ] [ { 1 2 3 } <reversed> \ foozul method-for-object M\ reversed foozul assert= ] unit-test
 425 [ ] [ { 1 2 3 } <reversed> \ foozul effective-method M\ reversed foozul assert= drop ] unit-test
 426
 427 [ ] [ fixnum \ foozul method-for-class M\ integer foozul assert= ] unit-test
 428 [ ] [ 13 \ foozul method-for-object M\ integer foozul assert= ] unit-test
 429 [ ] [ 13 \ foozul effective-method M\ integer foozul assert= drop ] unit-test
 430
 431 ! Ensure dynamic and static dispatch match in ambiguous cases
 432 UNION: amb-union-1a integer float ;
 433 UNION: amb-union-1b float string ;
 434
 435 GENERIC: amb-generic-1 ( a -- b )
 436
 437 M: amb-union-1a amb-generic-1 drop "a" ;
 438 M: amb-union-1b amb-generic-1 drop "b" ;
 439
 440 [ ] [
 441     5.0 amb-generic-1
 442     5.0 \ amb-generic-1 effective-method execute( a -- b ) assert=
 443 ] unit-test
 444
 445 [ ] [
 446     5.0 amb-generic-1
 447     5.0 float \ amb-generic-1 method-for-class execute( a -- b ) assert=
 448 ] unit-test
 449
 450 UNION: amb-union-2a float string ;
 451 UNION: amb-union-2b integer float ;
 452
 453 GENERIC: amb-generic-2 ( a -- b )
 454
 455 M: amb-union-2a amb-generic-2 drop "a" ;
 456 M: amb-union-2b amb-generic-2 drop "b" ;
 457
 458 [ ] [
 459     5.0 amb-generic-1
 460     5.0 \ amb-generic-1 effective-method execute( a -- b ) assert=
 461 ] unit-test
 462
 463 [ ] [
 464     5.0 amb-generic-1
 465     5.0 float \ amb-generic-1 method-for-class execute( a -- b ) assert=
 466 ] unit-test
 467
 468 TUPLE: amb-tuple-a x ;
 469 TUPLE: amb-tuple-b < amb-tuple-a ;
 470 PREDICATE: amb-tuple-c < amb-tuple-a x>> 3 = ;
 471
 472 GENERIC: amb-generic-3 ( a -- b )
 473
 474 M: amb-tuple-b amb-generic-3 drop "b" ;
 475 M: amb-tuple-c amb-generic-3 drop "c" ;
 476
 477 [ ] [
 478     T{ amb-tuple-b f 3 } amb-generic-3
 479     T{ amb-tuple-b f 3 } \ amb-generic-3 effective-method execute( a -- b ) assert=
 480 ] unit-test
 481
 482 TUPLE: amb-tuple-d ;
 483 UNION: amb-union-4 amb-tuple-a amb-tuple-d ;
 484
 485 GENERIC: amb-generic-4 ( a -- b )
 486
 487 M: amb-tuple-b amb-generic-4 drop "b" ;
 488 M: amb-union-4 amb-generic-4 drop "4" ;
 489
 490 [ ] [
 491     T{ amb-tuple-b f 3 } amb-generic-4
 492     T{ amb-tuple-b f 3 } \ amb-generic-4 effective-method execute( a -- b ) assert=
 493 ] unit-test
 494
 495 [ ] [
 496     T{ amb-tuple-b f 3 } amb-generic-4
 497     T{ amb-tuple-b f 3 } amb-tuple-b \ amb-generic-4 method-for-class execute( a -- b ) assert=
 498 ] unit-test
 499
 500 MIXIN: amb-mixin-5
 501 INSTANCE: amb-tuple-a amb-mixin-5
 502 INSTANCE: amb-tuple-d amb-mixin-5
 503
 504 GENERIC: amb-generic-5 ( a -- b )
 505
 506 M: amb-tuple-b amb-generic-5 drop "b" ;
 507 M: amb-mixin-5 amb-generic-5 drop "5" ;
 508
 509 [ ] [
 510     T{ amb-tuple-b f 3 } amb-generic-5
 511     T{ amb-tuple-b f 3 } \ amb-generic-5 effective-method execute( a -- b ) assert=
 512 ] unit-test
 513
 514 [ ] [
 515     T{ amb-tuple-b f 3 } amb-generic-5
 516     T{ amb-tuple-b f 3 } amb-tuple-b \ amb-generic-5 method-for-class execute( a -- b ) assert=
 517 ] unit-test
 518
 519 UNION: amb-union-6 amb-tuple-b amb-tuple-d ;
 520
 521 GENERIC: amb-generic-6 ( a -- b )
 522
 523 M: amb-tuple-a amb-generic-6 drop "a" ;
 524 M: amb-union-6 amb-generic-6 drop "6" ;
 525
 526 [ ] [
 527     T{ amb-tuple-b f 3 } amb-generic-6
 528     T{ amb-tuple-b f 3 } \ amb-generic-6 effective-method execute( a -- b ) assert=
 529 ] unit-test
 530
 531 [ ] [
 532     T{ amb-tuple-b f 3 } amb-generic-6
 533     T{ amb-tuple-b f 3 } amb-tuple-b \ amb-generic-6 method-for-class execute( a -- b ) assert=
 534 ] unit-test
 535
 536 MIXIN: amb-mixin-7
 537 INSTANCE: amb-tuple-b amb-mixin-7
 538 INSTANCE: amb-tuple-d amb-mixin-7
 539
 540 GENERIC: amb-generic-7 ( a -- b )
 541
 542 M: amb-tuple-a amb-generic-7 drop "a" ;
 543 M: amb-mixin-7 amb-generic-7 drop "7" ;
 544
 545 [ ] [
 546     T{ amb-tuple-b f 3 } amb-generic-7
 547     T{ amb-tuple-b f 3 } \ amb-generic-7 effective-method execute( a -- b ) assert=
 548 ] unit-test
 549
 550 [ ] [
 551     T{ amb-tuple-b f 3 } amb-generic-7
 552     T{ amb-tuple-b f 3 } amb-tuple-b \ amb-generic-7 method-for-class execute( a -- b ) assert=
 553 ] unit-test
 554
 555 ! Same thing as above but with predicate classes
 556 PREDICATE: amb-predicate-a < integer 10 mod even? ;
 557 PREDICATE: amb-predicate-b < amb-predicate-a 10 mod 4 = ;
 558
 559 UNION: amb-union-8 amb-predicate-b string ;
 560
 561 GENERIC: amb-generic-8 ( a -- b )
 562
 563 M: amb-union-8 amb-generic-8 drop "8" ;
 564 M: amb-predicate-a amb-generic-8 drop "a" ;
 565
 566 [ ] [
 567     4 amb-generic-8
 568     4 \ amb-generic-8 effective-method execute( a -- b ) assert=
 569 ] unit-test