core/generic/standard/standard-tests.factor

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