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