core/classes/tuple/tuple-tests.factor

   1 USING: accessors arrays assocs calendar classes classes.algebra
   2 classes.private classes.tuple classes.tuple.private columns
   3 compiler.errors compiler.units continuations definitions
   4 effects eval generic generic.single generic.standard grouping
   5 io.streams.string kernel kernel.private math math.constants
   6 math.order namespaces parser parser.notes prettyprint
   7 quotations random see sequences sequences.private slots
   8 slots.private splitting strings summary threads tools.test
   9 vectors vocabs words words.symbol fry literals memory ;
  10 IN: classes.tuple.tests
  11
  12 TUPLE: rect x y w h ;
  13 : <rect> ( x y w h -- rect ) rect boa ;
  14
  15 : move ( x rect -- rect )
  16     [ + ] change-x ;
  17
  18 [ f ] [ 10 20 30 40 <rect> dup clone 5 swap move = ] unit-test
  19
  20 [ t ] [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
  21
  22 ! Make sure we handle tuple class redefinition
  23 TUPLE: redefinition-test ;
  24
  25 C: <redefinition-test> redefinition-test
  26
  27 <redefinition-test> "redefinition-test" set
  28
  29 [ t ] [ "redefinition-test" get redefinition-test? ] unit-test
  30
  31 "IN: classes.tuple.tests TUPLE: redefinition-test ;" eval( -- )
  32
  33 [ t ] [ "redefinition-test" get redefinition-test? ] unit-test
  34
  35 ! Make sure we handle changing shapes!
  36 TUPLE: point x y ;
  37
  38 [ ] [ 100 200 point boa "p" set ] unit-test
  39
  40 ! Use eval to sequence parsing explicitly
  41 [ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval( -- ) ] unit-test
  42
  43 [ 100 ] [ "p" get x>> ] unit-test
  44 [ 200 ] [ "p" get y>> ] unit-test
  45 [ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
  46
  47 [ ] [ "p" get 300 ">>z" "accessors" lookup execute drop ] unit-test
  48
  49 [ 3 ] [ "p" get tuple-size ] unit-test
  50
  51 [ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
  52
  53 [ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval( -- ) ] unit-test
  54
  55 [ 2 ] [ "p" get tuple-size ] unit-test
  56
  57 [ "p" get x>> ] must-fail
  58 [ 200 ] [ "p" get y>> ] unit-test
  59 [ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
  60
  61 TUPLE: predicate-test ;
  62
  63 C: <predicate-test> predicate-test
  64
  65 : predicate-test ( a -- ? ) drop f ;
  66
  67 [ t ] [ <predicate-test> predicate-test? ] unit-test
  68
  69 PREDICATE: silly-pred < tuple
  70     class \ rect = ;
  71
  72 GENERIC: area ( obj -- n )
  73 M: silly-pred area dup w>> swap h>> * ;
  74
  75 TUPLE: circle radius ;
  76 M: circle area radius>> sq pi * ;
  77
  78 [ 200 ] [ T{ rect f 0 0 10 20 } area ] unit-test
  79
  80 ! Hashcode breakage
  81 TUPLE: empty ;
  82
  83 C: <empty> empty
  84
  85 [ t ] [ <empty> hashcode fixnum? ] unit-test
  86
  87 ! Compiler regression
  88 [ t length ] [ object>> t eq? ] must-fail-with
  89
  90 [ "<constructor-test>" ]
  91 [ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval( -- ) word name>> ] unit-test
  92
  93 TUPLE: size-test a b c d ;
  94
  95 [ t ] [
  96     T{ size-test } tuple-size
  97     size-test tuple-layout second =
  98 ] unit-test
  99
 100 GENERIC: <yo-momma> ( a -- b )
 101
 102 TUPLE: yo-momma ;
 103
 104 [ ] [ "IN: classes.tuple.tests C: <yo-momma> yo-momma" eval( -- ) ] unit-test
 105
 106 [ f ] [ \ <yo-momma> generic? ] unit-test
 107
 108 ! Test forget
 109 [
 110     [ t ] [ \ yo-momma class? ] unit-test
 111     [ ] [ \ yo-momma forget ] unit-test
 112     [ ] [ \ <yo-momma> forget ] unit-test
 113     [ f ] [ \ yo-momma update-map get values member-eq? ] unit-test
 114 ] with-compilation-unit
 115
 116 TUPLE: loc-recording ;
 117
 118 [ f ] [ \ loc-recording where not ] unit-test
 119
 120 ! 'forget' wasn't robust enough
 121
 122 TUPLE: forget-robustness ;
 123
 124 GENERIC: forget-robustness-generic ( a -- b )
 125
 126 M: forget-robustness forget-robustness-generic ;
 127
 128 M: integer forget-robustness-generic ;
 129
 130 [
 131     [ ] [ \ forget-robustness-generic forget ] unit-test
 132     [ ] [ \ forget-robustness forget ] unit-test
 133     [ ] [ M\ forget-robustness forget-robustness-generic forget ] unit-test
 134 ] with-compilation-unit
 135
 136 ! rapido found this one
 137 GENERIC# m1 0 ( s n -- n )
 138 GENERIC# m2 1 ( s n -- v )
 139
 140 TUPLE: t1 ;
 141
 142 M: t1 m1 drop ;
 143 M: t1 m2 nip ;
 144
 145 TUPLE: t2 ;
 146
 147 M: t2 m1 drop ;
 148 M: t2 m2 nip ;
 149
 150 TUPLE: t3 ;
 151
 152 M: t3 m1 drop ;
 153 M: t3 m2 nip ;
 154
 155 TUPLE: t4 ;
 156
 157 M: t4 m1 drop ;
 158 M: t4 m2 nip ;
 159
 160 C: <t4> t4
 161
 162 [ 1 ] [ 1 <t4> m1 ] unit-test
 163 [ 1 ] [ <t4> 1 m2 ] unit-test
 164
 165 ! another combination issue
 166 GENERIC: silly ( obj -- obj obj )
 167
 168 UNION: my-union slice repetition column array vector reversed ;
 169
 170 M: my-union silly "x" ;
 171
 172 M: array silly "y" ;
 173
 174 M: column silly "fdsfds" ;
 175
 176 M: repetition silly "zzz" ;
 177
 178 M: reversed silly "zz" ;
 179
 180 M: slice silly "tt" ;
 181
 182 M: string silly "t" ;
 183
 184 M: vector silly "z" ;
 185
 186 [ "zz" ] [ 123 <reversed> silly nip ] unit-test
 187
 188 ! Typo
 189 SYMBOL: not-a-tuple-class
 190
 191 ! Missing check
 192 [ not-a-tuple-class boa ] must-fail
 193 [ not-a-tuple-class new ] must-fail
 194
 195 TUPLE: erg's-reshape-problem a b c d ;
 196
 197 C: <erg's-reshape-problem> erg's-reshape-problem
 198
 199 ! Inheritance
 200 TUPLE: computer cpu ram ;
 201 C: <computer> computer
 202
 203 [ "TUPLE: computer cpu ram ;" ] [
 204     [ \ computer see ] with-string-writer string-lines second
 205 ] unit-test
 206
 207 TUPLE: laptop < computer battery ;
 208 C: <laptop> laptop
 209
 210 [ t ] [ laptop tuple-class? ] unit-test
 211 [ t ] [ laptop tuple class<= ] unit-test
 212 [ t ] [ laptop computer class<= ] unit-test
 213 [ t ] [ laptop computer classes-intersect? ] unit-test
 214
 215 [ ] [ "Pentium" 128 3 hours <laptop> "laptop" set ] unit-test
 216 [ t ] [ "laptop" get laptop? ] unit-test
 217 [ t ] [ "laptop" get computer? ] unit-test
 218 [ t ] [ "laptop" get tuple? ] unit-test
 219
 220 : test-laptop-slot-values ( -- )
 221     [ laptop ] [ "laptop" get class ] unit-test
 222     [ "Pentium" ] [ "laptop" get cpu>> ] unit-test
 223     [ 128 ] [ "laptop" get ram>> ] unit-test
 224     [ t ] [ "laptop" get battery>> 3 hours = ] unit-test ;
 225
 226 test-laptop-slot-values
 227
 228 [ "TUPLE: laptop < computer battery ;" ] [
 229     [ \ laptop see ] with-string-writer string-lines second
 230 ] unit-test
 231
 232 [ { tuple computer laptop } ] [ laptop superclasses ] unit-test
 233
 234 TUPLE: server < computer rackmount ;
 235 C: <server> server
 236
 237 [ t ] [ server tuple-class? ] unit-test
 238 [ t ] [ server tuple class<= ] unit-test
 239 [ t ] [ server computer class<= ] unit-test
 240 [ t ] [ server computer classes-intersect? ] unit-test
 241
 242 [ ] [ "PowerPC" 64 "1U" <server> "server" set ] unit-test
 243 [ t ] [ "server" get server? ] unit-test
 244 [ t ] [ "server" get computer? ] unit-test
 245 [ t ] [ "server" get tuple? ] unit-test
 246
 247 : test-server-slot-values ( -- )
 248     [ server ] [ "server" get class ] unit-test
 249     [ "PowerPC" ] [ "server" get cpu>> ] unit-test
 250     [ 64 ] [ "server" get ram>> ] unit-test
 251     [ "1U" ] [ "server" get rackmount>> ] unit-test ;
 252
 253 test-server-slot-values
 254
 255 [ f ] [ "server" get laptop? ] unit-test
 256 [ f ] [ "laptop" get server? ] unit-test
 257
 258 [ f ] [ server laptop class<= ] unit-test
 259 [ f ] [ laptop server class<= ] unit-test
 260 [ f ] [ laptop server classes-intersect? ] unit-test
 261
 262 [ f ] [ 1 2 <computer> laptop? ] unit-test
 263 [ f ] [ \ + server? ] unit-test
 264
 265 [ "TUPLE: server < computer rackmount ;" ] [
 266     [ \ server see ] with-string-writer string-lines second
 267 ] unit-test
 268
 269 [
 270     "IN: classes.tuple.tests TUPLE: invalid-superclass < word ;" eval( -- )
 271 ] must-fail
 272
 273 ! Dynamically changing inheritance hierarchy
 274 TUPLE: electronic-device ;
 275
 276 : computer?' ( a -- b ) computer? ;
 277
 278 [ t ] [ laptop new computer?' ] unit-test
 279
 280 [ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
 281
 282 [ t ] [ laptop new computer?' ] unit-test
 283
 284 [ f ] [ electronic-device laptop class<= ] unit-test
 285 [ t ] [ server electronic-device class<= ] unit-test
 286 [ t ] [ laptop server class-or electronic-device class<= ] unit-test
 287
 288 [ t ] [ "laptop" get electronic-device? ] unit-test
 289 [ t ] [ "laptop" get computer? ] unit-test
 290 [ t ] [ "laptop" get laptop? ] unit-test
 291 [ f ] [ "laptop" get server? ] unit-test
 292
 293 [ t ] [ "server" get electronic-device? ] unit-test
 294 [ t ] [ "server" get computer? ] unit-test
 295 [ f ] [ "server" get laptop? ] unit-test
 296 [ t ] [ "server" get server? ] unit-test
 297
 298 [ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
 299
 300 [ f ] [ "laptop" get electronic-device? ] unit-test
 301 [ t ] [ "laptop" get computer? ] unit-test
 302
 303 [ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
 304
 305 test-laptop-slot-values
 306 test-server-slot-values
 307
 308 [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
 309
 310 test-laptop-slot-values
 311 test-server-slot-values
 312
 313 TUPLE: make-me-some-accessors voltage grounded? ;
 314
 315 [ f ] [ "laptop" get voltage>> ] unit-test
 316 [ f ] [ "server" get voltage>> ] unit-test
 317
 318 [ ] [ "laptop" get 220 >>voltage drop ] unit-test
 319 [ ] [ "server" get 110 >>voltage drop ] unit-test
 320
 321 [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ; C: <computer> computer" eval( -- ) ] unit-test
 322
 323 test-laptop-slot-values
 324 test-server-slot-values
 325
 326 [ 220 ] [ "laptop" get voltage>> ] unit-test
 327 [ 110 ] [ "server" get voltage>> ] unit-test
 328
 329 [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
 330
 331 test-laptop-slot-values
 332 test-server-slot-values
 333
 334 [ 220 ] [ "laptop" get voltage>> ] unit-test
 335 [ 110 ] [ "server" get voltage>> ] unit-test
 336
 337 ! Reshaping superclass and subclass simultaneously
 338 [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
 339
 340 test-laptop-slot-values
 341 test-server-slot-values
 342
 343 [ 220 ] [ "laptop" get voltage>> ] unit-test
 344 [ 110 ] [ "server" get voltage>> ] unit-test
 345
 346 ! Reshape crash
 347 TUPLE: test1 a ; TUPLE: test2 < test1 b ;
 348
 349 "a" "b" test2 boa "test" set
 350
 351 : test-a/b ( -- )
 352     [ "a" ] [ "test" get a>> ] unit-test
 353     [ "b" ] [ "test" get b>> ] unit-test ;
 354
 355 test-a/b
 356
 357 [ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval( -- ) ] unit-test
 358
 359 test-a/b
 360
 361 [ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval( -- ) ] unit-test
 362
 363 test-a/b
 364
 365 ! Twice in the same compilation unit
 366 [
 367     test1 tuple { "a" "x" "y" } define-tuple-class
 368     test1 tuple { "a" "y" } define-tuple-class
 369 ] with-compilation-unit
 370
 371 test-a/b
 372
 373 ! Moving slots up and down
 374 TUPLE: move-up-1 a b ;
 375 TUPLE: move-up-2 < move-up-1 c ;
 376
 377 T{ move-up-2 f "a" "b" "c" } "move-up" set
 378
 379 : test-move-up ( -- )
 380     [ "a" ] [ "move-up" get a>> ] unit-test
 381     [ "b" ] [ "move-up" get b>> ] unit-test
 382     [ "c" ] [ "move-up" get c>> ] unit-test ;
 383
 384 test-move-up
 385
 386 [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval( -- ) ] unit-test
 387
 388 test-move-up
 389
 390 [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval( -- ) ] unit-test
 391
 392 test-move-up
 393
 394 [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval( -- ) ] unit-test
 395
 396 test-move-up
 397
 398 [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval( -- ) ] unit-test
 399
 400 ! Constructors must be recompiled when changing superclass
 401 TUPLE: constructor-update-1 xxx ;
 402
 403 TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ;
 404
 405 : <constructor-update-2> ( a b c -- tuple ) constructor-update-2 boa ;
 406
 407 { 3 1 } [ <constructor-update-2> ] must-infer-as
 408
 409 [ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval( -- ) ] unit-test
 410
 411 { 3 1 } [ <constructor-update-2> ] must-infer-as
 412
 413 [ 1 2 3 4 5 <constructor-update-2> ] [ not-compiled? ] must-fail-with
 414
 415 [ ] [ [ \ <constructor-update-2> forget ] with-compilation-unit ] unit-test
 416
 417 ! Redefinition problem
 418 TUPLE: redefinition-problem ;
 419
 420 UNION: redefinition-problem' redefinition-problem integer ;
 421
 422 [ t ] [ 3 redefinition-problem'? ] unit-test
 423
 424 TUPLE: redefinition-problem-2 ;
 425
 426 "IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" eval( -- )
 427
 428 [ t ] [ 3 redefinition-problem'? ] unit-test
 429
 430 ! Hardcore unit tests
 431
 432 \ thread "slots" word-prop "slots" set
 433
 434 [ ] [
 435     [
 436         \ thread tuple { "xxx" } "slots" get append
 437         define-tuple-class
 438     ] with-compilation-unit
 439
 440     [ 1337 sleep ] "Test" spawn drop
 441
 442     [
 443         \ thread tuple "slots" get
 444         define-tuple-class
 445     ] with-compilation-unit
 446 ] unit-test
 447
 448 \ vocab "slots" word-prop "slots" set
 449
 450 [ ] [
 451     [
 452         \ vocab identity-tuple { "xxx" } "slots" get append
 453         define-tuple-class
 454     ] with-compilation-unit
 455
 456     all-words drop
 457
 458     [
 459         \ vocab identity-tuple "slots" get
 460         define-tuple-class
 461     ] with-compilation-unit
 462 ] unit-test
 463
 464 [ "USE: words T{ word }" eval( -- ) ]
 465 [ error>> T{ no-method f word new } = ]
 466 must-fail-with
 467
 468 ! Accessors not being forgotten...
 469 [ [ ] ] [
 470     "IN: classes.tuple.tests TUPLE: forget-accessors-test x y z ;"
 471     <string-reader>
 472     "forget-accessors-test" parse-stream
 473 ] unit-test
 474
 475 [ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
 476
 477 : accessor-exists? ( name -- ? )
 478     [ "forget-accessors-test" "classes.tuple.tests" lookup ] dip
 479     ">>" append "accessors" lookup ?lookup-method >boolean ;
 480
 481 [ t ] [ "x" accessor-exists? ] unit-test
 482 [ t ] [ "y" accessor-exists? ] unit-test
 483 [ t ] [ "z" accessor-exists? ] unit-test
 484
 485 [ [ ] ] [
 486     "IN: classes.tuple.tests GENERIC: forget-accessors-test ( a -- b )"
 487     <string-reader>
 488     "forget-accessors-test" parse-stream
 489 ] unit-test
 490
 491 [ f ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
 492
 493 [ f ] [ "x" accessor-exists? ] unit-test
 494 [ f ] [ "y" accessor-exists? ] unit-test
 495 [ f ] [ "z" accessor-exists? ] unit-test
 496
 497 TUPLE: another-forget-accessors-test ;
 498
 499
 500 [ [ ] ] [
 501     "IN: classes.tuple.tests GENERIC: another-forget-accessors-test ( a -- b )"
 502     <string-reader>
 503     "another-forget-accessors-test" parse-stream
 504 ] unit-test
 505
 506 [ t ] [ \ another-forget-accessors-test class? ] unit-test
 507
 508 ! Shadowing test
 509 [ f ] [
 510     f parser-quiet? [
 511         [
 512             "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval( -- )
 513         ] with-string-writer empty?
 514     ] with-variable
 515 ] unit-test
 516
 517 ! Missing error check
 518 [ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval( -- ) ] must-fail
 519
 520 ! Insufficient type checking
 521 [ \ vocab tuple>array drop ] must-fail
 522
 523 ! Check type declarations
 524 TUPLE: declared-types { n fixnum } { m string } ;
 525
 526 [ T{ declared-types f 0 "hi" } ]
 527 [ { declared-types 0 "hi" } >tuple ]
 528 unit-test
 529
 530 [ { declared-types "hi" 0 } >tuple ]
 531 [ T{ bad-slot-value f "hi" fixnum } = ]
 532 must-fail-with
 533
 534 ! Check fixnum coercer
 535 [ 0 ] [ 0.0 "hi" declared-types boa n>> ] unit-test
 536
 537 [ 0 ] [ declared-types new 0.0 >>n n>> ] unit-test
 538
 539 ! Check bignum coercer
 540 TUPLE: bignum-coercer { n bignum initial: $[ 0 >bignum ] } ;
 541
 542 [ 13 bignum ] [ 13.5 bignum-coercer boa n>> dup class ] unit-test
 543
 544 [ 13 bignum ] [ bignum-coercer new 13.5 >>n n>> dup class ] unit-test
 545
 546 ! Check float coercer
 547 TUPLE: float-coercer { n float } ;
 548
 549 [ 13.0 float ] [ 13 float-coercer boa n>> dup class ] unit-test
 550
 551 [ 13.0 float ] [ float-coercer new 13 >>n n>> dup class ] unit-test
 552
 553 ! Check integer coercer
 554 TUPLE: integer-coercer { n integer } ;
 555
 556 [ 13 fixnum ] [ 13.5 integer-coercer boa n>> dup class ] unit-test
 557
 558 [ 13 fixnum ] [ integer-coercer new 13.5 >>n n>> dup class ] unit-test
 559
 560 : foo ( a b -- c ) declared-types boa ;
 561
 562 \ foo def>> must-infer
 563
 564 [ T{ declared-types f 0 "hi" } ] [ 0.0 "hi" foo ] unit-test
 565
 566 [ "hi" 0.0 declared-types boa ]
 567 [ T{ no-method f "hi" >fixnum } = ]
 568 must-fail-with
 569
 570 [ 0 { } declared-types boa ]
 571 [ T{ bad-slot-value f { } string } = ]
 572 must-fail-with
 573
 574 [ "hi" 0.0 foo ]
 575 [ T{ no-method f "hi" >fixnum } = ]
 576 must-fail-with
 577
 578 [ 0 { } foo ]
 579 [ T{ bad-slot-value f { } string } = ]
 580 must-fail-with
 581
 582 [ T{ declared-types f 0 "" } ] [ declared-types new ] unit-test
 583
 584 : blah ( -- vec ) vector new ;
 585
 586 [ vector new ] must-infer
 587
 588 [ V{ } ] [ blah ] unit-test
 589
 590 ! Test reshaping with type declarations and slot attributes
 591 TUPLE: reshape-test x ;
 592
 593 T{ reshape-test f "hi" } "tuple" set
 594
 595 [ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval( -- ) ] unit-test
 596
 597 [ f ] [ \ reshape-test \ x<< ?lookup-method ] unit-test
 598
 599 [ "tuple" get 5 >>x ] must-fail
 600
 601 [ "hi" ] [ "tuple" get x>> ] unit-test
 602
 603 [ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval( -- ) ] unit-test
 604
 605 [ 0 ] [ "tuple" get x>> ] unit-test
 606
 607 [ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval( -- ) ] unit-test
 608
 609 [ 0 ] [ "tuple" get x>> ] unit-test
 610
 611 TUPLE: boa-coercer-test { x array-capacity } ;
 612
 613 [ fixnum ] [ 0 >bignum boa-coercer-test boa x>> class ] unit-test
 614
 615 [ T{ boa-coercer-test f 0 } ] [ T{ boa-coercer-test } ] unit-test
 616
 617 ! Test error classes
 618 ERROR: error-class-test a b c ;
 619
 620 [ "( a b c -- * )" ] [ \ error-class-test stack-effect effect>string ] unit-test
 621 [ f ] [ \ error-class-test "inline" word-prop ] unit-test
 622
 623 [ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval( -- ) ]
 624 [ error>> error>> redefine-error? ] must-fail-with
 625
 626 DEFER: error-y
 627
 628 [ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test
 629
 630 [ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval( -- ) ] unit-test
 631
 632 [ f ] [ \ error-y tuple-class? ] unit-test
 633
 634 [ f ] [ \ error-y error-class? ] unit-test
 635
 636 [ t ] [ \ error-y generic? ] unit-test
 637
 638 [ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval( -- ) ] unit-test
 639
 640 [ t ] [ \ error-y tuple-class? ] unit-test
 641
 642 [ t ] [ \ error-y error-class? ] unit-test
 643
 644 [ f ] [ \ error-y generic? ] unit-test
 645
 646 [ ] [
 647     "IN: classes.tuple.tests TUPLE: forget-subclass-test ; TUPLE: forget-subclass-test' < forget-subclass-test ;"
 648     <string-reader> "forget-subclass-test" parse-stream
 649     drop
 650 ] unit-test
 651
 652 [ ] [ "forget-subclass-test'" "classes.tuple.tests" lookup new "bad-object" set ] unit-test
 653
 654 [ ] [
 655     "IN: classes.tuple.tests TUPLE: forget-subclass-test a ;"
 656     <string-reader> "forget-subclass-test" parse-stream
 657     drop
 658 ] unit-test
 659
 660 [ ] [
 661     "IN: sequences TUPLE: reversed { seq read-only } ;" eval( -- )
 662 ] unit-test
 663
 664 TUPLE: bogus-hashcode-1 x ;
 665
 666 TUPLE: bogus-hashcode-2 x ;
 667
 668 M: bogus-hashcode-1 hashcode* 2drop 0 >bignum ;
 669
 670 [ ] [ T{ bogus-hashcode-2 f T{ bogus-hashcode-1 } } hashcode drop ] unit-test
 671
 672 DEFER: change-slot-test
 673 SLOT: kex
 674
 675 [ ] [
 676     "IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; SLOT: kex M: change-slot-test kex>> drop 3 ;"
 677     <string-reader> "change-slot-test" parse-stream
 678     drop
 679 ] unit-test
 680
 681 [ t ] [ \ change-slot-test \ kex>> ?lookup-method >boolean ] unit-test
 682
 683 [ ] [
 684     "IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test kex ;"
 685     <string-reader> "change-slot-test" parse-stream
 686     drop
 687 ] unit-test
 688
 689 [ t ] [ \ change-slot-test \ kex>> ?lookup-method >boolean ] unit-test
 690
 691 [ ] [
 692     "IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; SLOT: kex M: change-slot-test kex>> drop 3 ;"
 693     <string-reader> "change-slot-test" parse-stream
 694     drop
 695 ] unit-test
 696
 697 [ t ] [ \ change-slot-test \ kex>> ?lookup-method >boolean ] unit-test
 698 [ f ] [ \ change-slot-test \ kex>> ?lookup-method "reading" word-prop ] unit-test
 699
 700 DEFER: redefine-tuple-twice
 701
 702 [ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
 703
 704 [ t ] [ \ redefine-tuple-twice symbol? ] unit-test
 705
 706 [ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval( -- ) ] unit-test
 707
 708 [ t ] [ \ redefine-tuple-twice deferred? ] unit-test
 709
 710 [ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
 711
 712 [ t ] [ \ redefine-tuple-twice symbol? ] unit-test
 713
 714 ERROR: base-error x y ;
 715 ERROR: derived-error < base-error z ;
 716
 717 [ (( x y z -- * )) ] [ \ derived-error stack-effect ] unit-test
 718
 719 ! Make sure that tuple reshaping updates code heap roots
 720 TUPLE: code-heap-ref ;
 721
 722 : code-heap-ref' ( -- a ) T{ code-heap-ref } ;
 723
 724 ! Push foo's literal to tenured space
 725 [ ] [ gc ] unit-test
 726
 727 ! Reshape!
 728 [ ] [ "IN: classes.tuple.tests USE: math TUPLE: code-heap-ref { x integer initial: 5 } ;" eval( -- ) ] unit-test
 729
 730 ! Code heap reference
 731 [ t ] [ code-heap-ref' code-heap-ref? ] unit-test
 732 [ 5 ] [ code-heap-ref' x>> ] unit-test
 733
 734 ! Data heap reference
 735 [ t ] [ \ code-heap-ref' def>> first code-heap-ref? ] unit-test
 736 [ 5 ] [ \ code-heap-ref' def>> first x>> ] unit-test
 737
 738 ! If the metaclass of a superclass changes into something other
 739 ! than a tuple class, the tuple needs to have its superclass reset
 740 TUPLE: metaclass-change ;
 741 TUPLE: metaclass-change-subclass < metaclass-change ;
 742
 743 [ metaclass-change ] [ metaclass-change-subclass superclass ] unit-test
 744
 745 [ ] [ "IN: classes.tuple.tests MIXIN: metaclass-change" eval( -- ) ] unit-test
 746
 747 [ t ] [ metaclass-change-subclass tuple-class? ] unit-test
 748 [ tuple ] [ metaclass-change-subclass superclass ] unit-test
 749
 750 ! Reshaping bug related to the above
 751 TUPLE: a-g ;
 752 TUPLE: g < a-g ;
 753
 754 [ ] [ g new "g" set ] unit-test
 755
 756 [ ] [ "IN: classes.tuple.tests MIXIN: a-g TUPLE: g ;" eval( -- ) ] unit-test
 757
 758 [ t ] [ g new layout-of "g" get layout-of eq? ] unit-test
 759
 760 ! Joe Groff discovered this bug
 761 DEFER: factor-crashes-anymore
 762
 763 [ ] [
 764     "IN: classes.tuple.tests
 765     TUPLE: unsafe-slot-access ;
 766     CONSTANT: unsafe-slot-access' T{ unsafe-slot-access }" eval( -- )
 767 ] unit-test
 768
 769 [ ] [
 770     "IN: classes.tuple.tests
 771     USE: accessors
 772     TUPLE: unsafe-slot-access { x read-only initial: 31337 } ;
 773     : factor-crashes-anymore ( -- x ) unsafe-slot-access' x>> ;" eval( -- )
 774 ] unit-test
 775
 776 [ 31337 ] [ factor-crashes-anymore ] unit-test
 777
 778 TUPLE: tuple-predicate-redefine-test ;
 779
 780 [ ] [ "IN: classes.tuple.tests TUPLE: tuple-predicate-redefine-test ;" eval( -- ) ] unit-test
 781
 782 [ t ] [ \ tuple-predicate-redefine-test? predicate? ] unit-test
 783
 784 ! Final classes
 785 TUPLE: final-superclass ;
 786 TUPLE: final-subclass < final-superclass ;
 787
 788 [ final-superclass ] [ final-subclass superclass ] unit-test
 789
 790 ! Making the superclass final should change the superclass of the subclass
 791 [ ] [ "IN: classes.tuple.tests TUPLE: final-superclass ; final" eval( -- ) ] unit-test
 792
 793 [ tuple ] [ final-subclass superclass ] unit-test
 794
 795 [ f ] [ \ final-subclass final-class? ] unit-test
 796
 797 ! Subclassing a final class should fail
 798 [ "IN: classes.tuple.tests TUPLE: final-subclass < final-superclass ;" eval( -- ) ]
 799 [ error>> bad-superclass? ] must-fail-with
 800
 801 ! Making a final class non-final should work
 802 [ ] [ "IN: classes.tuple.tests TUPLE: final-superclass ;" eval( -- ) ] unit-test
 803
 804 [ ] [ "IN: classes.tuple.tests TUPLE: final-subclass < final-superclass ; final" eval( -- ) ] unit-test
 805
 806 ! Changing a superclass should not change the final status of a subclass
 807 [ ] [ "IN: classes.tuple.tests TUPLE: final-superclass x ;" eval( -- ) ] unit-test
 808
 809 [ t ] [ \ final-subclass final-class? ] unit-test