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