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