core/classes/tuple/tuple-tests.factor

   1 USING: definitions generic kernel kernel.private math
   2 math.constants parser sequences tools.test words assocs
   3 namespaces quotations sequences.private classes continuations
   4 generic.standard effects classes.tuple classes.tuple.private
   5 arrays vectors strings compiler.units accessors classes.algebra
   6 calendar prettyprint io.streams.string splitting summary
   7 columns math.order classes.private slots slots.private eval ;
   8 IN: classes.tuple.tests
   9
  10 TUPLE: rect x y w h ;
  11 : <rect> ( x y w h -- rect ) rect boa ;
  12
  13 : move ( x rect -- rect )
  14     [ + ] change-x ;
  15
  16 [ f ] [ 10 20 30 40 <rect> dup clone 5 swap move = ] unit-test
  17
  18 [ t ] [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
  19
  20 ! Make sure we handle tuple class redefinition
  21 TUPLE: redefinition-test ;
  22
  23 C: <redefinition-test> redefinition-test
  24
  25 <redefinition-test> "redefinition-test" set
  26
  27 [ t ] [ "redefinition-test" get redefinition-test? ] unit-test
  28
  29 "IN: classes.tuple.tests TUPLE: redefinition-test ;" eval
  30
  31 [ t ] [ "redefinition-test" get redefinition-test? ] unit-test
  32
  33 ! Make sure we handle changing shapes!
  34 TUPLE: point x y ;
  35
  36 C: <point> point
  37
  38 [ ] [ 100 200 <point> "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 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>
 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 memq? ] unit-test
 114
 115     [ f ] [ \ yo-momma crossref get at ] unit-test
 116 ] with-compilation-unit
 117
 118 TUPLE: loc-recording ;
 119
 120 [ f ] [ \ loc-recording where not ] unit-test
 121
 122 ! 'forget' wasn't robust enough
 123
 124 TUPLE: forget-robustness ;
 125
 126 GENERIC: forget-robustness-generic
 127
 128 M: forget-robustness forget-robustness-generic ;
 129
 130 M: integer forget-robustness-generic ;
 131
 132 [
 133     [ ] [ \ forget-robustness-generic forget ] unit-test
 134     [ ] [ \ forget-robustness forget ] unit-test
 135     [ ] [ { forget-robustness forget-robustness-generic } forget ] unit-test
 136 ] with-compilation-unit
 137
 138 ! rapido found this one
 139 GENERIC# m1 0 ( s n -- n )
 140 GENERIC# m2 1 ( s n -- v )
 141
 142 TUPLE: t1 ;
 143
 144 M: t1 m1 drop ;
 145 M: t1 m2 nip ;
 146
 147 TUPLE: t2 ;
 148
 149 M: t2 m1 drop ;
 150 M: t2 m2 nip ;
 151
 152 TUPLE: t3 ;
 153
 154 M: t3 m1 drop ;
 155 M: t3 m2 nip ;
 156
 157 TUPLE: t4 ;
 158
 159 M: t4 m1 drop ;
 160 M: t4 m2 nip ;
 161
 162 C: <t4> t4
 163
 164 [ 1 ] [ 1 <t4> m1 ] unit-test
 165 [ 1 ] [ <t4> 1 m2 ] unit-test
 166
 167 ! another combination issue
 168 GENERIC: silly ( obj -- obj obj )
 169
 170 UNION: my-union slice repetition column array vector reversed ;
 171
 172 M: my-union silly "x" ;
 173
 174 M: array silly "y" ;
 175
 176 M: column silly "fdsfds" ;
 177
 178 M: repetition silly "zzz" ;
 179
 180 M: reversed silly "zz" ;
 181
 182 M: slice silly "tt" ;
 183
 184 M: string silly "t" ;
 185
 186 M: vector silly "z" ;
 187
 188 [ "zz" ] [ 123 <reversed> silly nip ] unit-test
 189
 190 ! Typo
 191 SYMBOL: not-a-tuple-class
 192
 193 ! Missing check
 194 [ not-a-tuple-class boa ] must-fail
 195 [ not-a-tuple-class new ] must-fail
 196
 197 TUPLE: erg's-reshape-problem a b c d ;
 198
 199 C: <erg's-reshape-problem> erg's-reshape-problem
 200
 201 ! We want to make sure constructors are recompiled when
 202 ! tuples are reshaped
 203 : cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ;
 204 : cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ;
 205
 206 [ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval ] unit-test
 207
 208 [ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
 209
 210 [ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
 211
 212 ! Inheritance
 213 TUPLE: computer cpu ram ;
 214 C: <computer> computer
 215
 216 [ "TUPLE: computer cpu ram ;" ] [
 217     [ \ computer see ] with-string-writer string-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 ] 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 string-lines second
 243 ] unit-test
 244
 245 [ { tuple computer laptop } ] [ laptop superclasses ] 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 ] 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 string-lines second
 280 ] unit-test
 281
 282 [
 283     "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval
 284 ] must-fail
 285
 286 ! Dynamically changing inheritance hierarchy
 287 TUPLE: electronic-device ;
 288
 289 [ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] 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 ;" 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 ;" eval ] unit-test
 311
 312 test-laptop-slot-values
 313 test-server-slot-values
 314
 315 [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" 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? ;" 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 ;" 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 ;" 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 C: <test2> test2
 357
 358 "a" "b" <test2> "test" set
 359
 360 : test-a/b ( -- )
 361     [ "a" ] [ "test" get a>> ] unit-test
 362     [ "b" ] [ "test" get b>> ] unit-test ;
 363
 364 test-a/b
 365
 366 [ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval ] unit-test
 367
 368 test-a/b
 369
 370 [ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval ] unit-test
 371
 372 test-a/b
 373
 374 ! Twice in the same compilation unit
 375 [
 376     test1 tuple { "a" "x" "y" } define-tuple-class
 377     test1 tuple { "a" "y" } define-tuple-class
 378 ] with-compilation-unit
 379
 380 test-a/b
 381
 382 ! Moving slots up and down
 383 TUPLE: move-up-1 a b ;
 384 TUPLE: move-up-2 < move-up-1 c ;
 385
 386 T{ move-up-2 f "a" "b" "c" } "move-up" set
 387
 388 : test-move-up ( -- )
 389     [ "a" ] [ "move-up" get a>> ] unit-test
 390     [ "b" ] [ "move-up" get b>> ] unit-test
 391     [ "c" ] [ "move-up" get c>> ] unit-test ;
 392
 393 test-move-up
 394
 395 [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval ] unit-test
 396
 397 test-move-up
 398
 399 [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval ] unit-test
 400
 401 test-move-up
 402
 403 [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval ] unit-test
 404
 405 test-move-up
 406
 407 [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval ] unit-test
 408
 409 ! Constructors must be recompiled when changing superclass
 410 TUPLE: constructor-update-1 xxx ;
 411
 412 TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ;
 413
 414 C: <constructor-update-2> constructor-update-2
 415
 416 { 3 1 } [ <constructor-update-2> ] must-infer-as
 417
 418 [ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval ] unit-test
 419
 420 { 5 1 } [ <constructor-update-2> ] must-infer-as
 421
 422 [ { 1 2 3 4 5 } ] [ 1 2 3 4 5 <constructor-update-2> tuple-slots ] 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 USE: threads
 439
 440 \ thread "slots" word-prop "slots" set
 441
 442 [ ] [
 443     [
 444         \ thread tuple { "xxx" } "slots" get append
 445         define-tuple-class
 446     ] with-compilation-unit
 447
 448     [ 1337 sleep ] "Test" spawn drop
 449
 450     [
 451         \ thread tuple "slots" get
 452         define-tuple-class
 453     ] with-compilation-unit
 454 ] unit-test
 455
 456 USE: vocabs
 457
 458 \ vocab "slots" word-prop "slots" set
 459
 460 [ ] [
 461     [
 462         \ vocab tuple { "xxx" } "slots" get append
 463         define-tuple-class
 464     ] with-compilation-unit
 465
 466     all-words drop
 467
 468     [
 469         \ vocab tuple "slots" get
 470         define-tuple-class
 471     ] with-compilation-unit
 472 ] unit-test
 473
 474 [ "USE: words T{ word }" eval ]
 475 [ error>> T{ no-method f word new } = ]
 476 must-fail-with
 477
 478 ! Accessors not being forgotten...
 479 [ [ ] ] [
 480     "IN: classes.tuple.tests TUPLE: forget-accessors-test x y z ;"
 481     <string-reader>
 482     "forget-accessors-test" parse-stream
 483 ] unit-test
 484
 485 [ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
 486
 487 : accessor-exists? ( class name -- ? )
 488     [ "forget-accessors-test" "classes.tuple.tests" lookup ] dip
 489     ">>" append "accessors" lookup method >boolean ;
 490
 491 [ t ] [ "x" accessor-exists? ] unit-test
 492 [ t ] [ "y" accessor-exists? ] unit-test
 493 [ t ] [ "z" accessor-exists? ] unit-test
 494
 495 [ [ ] ] [
 496     "IN: classes.tuple.tests GENERIC: forget-accessors-test"
 497     <string-reader>
 498     "forget-accessors-test" parse-stream
 499 ] unit-test
 500
 501 [ f ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
 502
 503 [ f ] [ "x" accessor-exists? ] unit-test
 504 [ f ] [ "y" accessor-exists? ] unit-test
 505 [ f ] [ "z" accessor-exists? ] unit-test
 506
 507 TUPLE: another-forget-accessors-test ;
 508
 509
 510 [ [ ] ] [
 511     "IN: classes.tuple.tests GENERIC: another-forget-accessors-test"
 512     <string-reader>
 513     "another-forget-accessors-test" parse-stream
 514 ] unit-test
 515
 516 [ t ] [ \ another-forget-accessors-test class? ] unit-test
 517
 518 ! Shadowing test
 519 [ f ] [
 520     t parser-notes? [
 521         [
 522             "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval
 523         ] with-string-writer empty?
 524     ] with-variable
 525 ] unit-test
 526
 527 ! Missing error check
 528 [ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
 529
 530 ! Class forget messyness
 531 TUPLE: subclass-forget-test ;
 532
 533 TUPLE: subclass-forget-test-1 < subclass-forget-test ;
 534 TUPLE: subclass-forget-test-2 < subclass-forget-test ;
 535 TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
 536
 537 [ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
 538
 539 [ { subclass-forget-test-2 } ]
 540 [ subclass-forget-test-2 class-usages ]
 541 unit-test
 542
 543 [ { subclass-forget-test-3 } ]
 544 [ subclass-forget-test-3 class-usages ]
 545 unit-test
 546
 547 [ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
 548 [ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
 549 [ subclass-forget-test-3 new ] must-fail
 550
 551 [ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval ] must-fail
 552
 553 ! More
 554 DEFER: subclass-reset-test
 555 DEFER: subclass-reset-test-1
 556 DEFER: subclass-reset-test-2
 557 DEFER: subclass-reset-test-3
 558
 559 GENERIC: break-me ( obj -- )
 560
 561 [ ] [ [ { integer break-me } forget ] with-compilation-unit ] unit-test
 562
 563 [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
 564 [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval ] unit-test
 565 [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval ] unit-test
 566 [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval ] unit-test
 567
 568 [ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval ] unit-test
 569
 570 [ ] [ "IN: classes.tuple.tests : subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
 571
 572 [ f ] [ subclass-reset-test-1 tuple-class? ] unit-test
 573 [ f ] [ subclass-reset-test-2 tuple-class? ] unit-test
 574 [ subclass-forget-test-3 new ] must-fail
 575
 576 [ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
 577
 578 [ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test
 579
 580 [ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
 581
 582 ! Insufficient type checking
 583 [ \ vocab tuple>array drop ] must-fail
 584
 585 ! Check type declarations
 586 TUPLE: declared-types { n fixnum } { m string } ;
 587
 588 [ T{ declared-types f 0 "hi" } ]
 589 [ { declared-types 0 "hi" } >tuple ]
 590 unit-test
 591
 592 [ { declared-types "hi" 0 } >tuple ]
 593 [ T{ bad-slot-value f "hi" fixnum } = ]
 594 must-fail-with
 595
 596 [ T{ declared-types f 0 "hi" } ]
 597 [ 0.0 "hi" declared-types boa ] unit-test
 598
 599 : foo ( a b -- c ) declared-types boa ;
 600
 601 \ foo must-infer
 602
 603 [ T{ declared-types f 0 "hi" } ] [ 0.0 "hi" foo ] unit-test
 604
 605 [ "hi" 0.0 declared-types boa ]
 606 [ T{ no-method f "hi" >fixnum } = ]
 607 must-fail-with
 608
 609 [ 0 { } declared-types boa ]
 610 [ T{ bad-slot-value f { } string } = ]
 611 must-fail-with
 612
 613 [ "hi" 0.0 foo ]
 614 [ T{ no-method f "hi" >fixnum } = ]
 615 must-fail-with
 616
 617 [ 0 { } foo ]
 618 [ T{ bad-slot-value f { } string } = ]
 619 must-fail-with
 620
 621 [ T{ declared-types f 0 "" } ] [ declared-types new ] unit-test
 622
 623 : blah ( -- vec ) vector new ;
 624
 625 \ blah must-infer
 626
 627 [ V{ } ] [ blah ] unit-test
 628
 629 ! Test reshaping with type declarations and slot attributes
 630 TUPLE: reshape-test x ;
 631
 632 T{ reshape-test f "hi" } "tuple" set
 633
 634 [ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval ] unit-test
 635
 636 [ f ] [ \ reshape-test \ (>>x) method ] unit-test
 637
 638 [ "tuple" get 5 >>x ] must-fail
 639
 640 [ "hi" ] [ "tuple" get x>> ] unit-test
 641
 642 [ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval ] unit-test
 643
 644 [ 0 ] [ "tuple" get x>> ] unit-test
 645
 646 [ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval ] unit-test
 647
 648 [ 0 ] [ "tuple" get x>> ] unit-test
 649
 650 TUPLE: boa-coercer-test { x array-capacity } ;
 651
 652 [ fixnum ] [ 0 >bignum boa-coercer-test boa x>> class ] unit-test
 653
 654 [ T{ boa-coercer-test f 0 } ] [ T{ boa-coercer-test } ] unit-test
 655
 656 ! Test error classes
 657 ERROR: error-class-test a b c ;
 658
 659 [ "( a b c -- * )" ] [ \ error-class-test stack-effect effect>string ] unit-test
 660 [ f ] [ \ error-class-test "inline" word-prop ] unit-test
 661
 662 [ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval ]
 663 [ error>> error>> redefine-error? ] must-fail-with
 664
 665 DEFER: error-y
 666
 667 [ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test
 668
 669 [ ] [ "IN: classes.tuple.tests GENERIC: error-y" eval ] unit-test
 670
 671 [ f ] [ \ error-y tuple-class? ] unit-test
 672
 673 [ t ] [ \ error-y generic? ] unit-test
 674
 675 [ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval ] unit-test
 676
 677 [ t ] [ \ error-y tuple-class? ] unit-test
 678
 679 [ f ] [ \ error-y generic? ] unit-test
 680
 681 [ ] [
 682     "IN: classes.tuple.tests TUPLE: forget-subclass-test ; TUPLE: forget-subclass-test' < forget-subclass-test ;"
 683     <string-reader> "forget-subclass-test" parse-stream
 684     drop
 685 ] unit-test
 686
 687 [ ] [ "forget-subclass-test'" "classes.tuple.tests" lookup new "bad-object" set ] unit-test
 688
 689 [ ] [
 690     "IN: classes.tuple.tests TUPLE: forget-subclass-test a ;"
 691     <string-reader> "forget-subclass-test" parse-stream
 692     drop
 693 ] unit-test
 694
 695 [ ] [
 696     "IN: sequences TUPLE: reversed { seq read-only } ;" eval
 697 ] unit-test
 698
 699 TUPLE: bogus-hashcode-1 x ;
 700
 701 TUPLE: bogus-hashcode-2 x ;
 702
 703 M: bogus-hashcode-1 hashcode* 2drop 0 >bignum ;
 704
 705 [ ] [ T{ bogus-hashcode-2 f T{ bogus-hashcode-1 } } hashcode drop ] unit-test
 706
 707 DEFER: change-slot-test
 708 SLOT: kex
 709
 710 [ ] [
 711     "IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; SLOT: kex M: change-slot-test kex>> drop 3 ;"
 712     <string-reader> "change-slot-test" parse-stream
 713     drop
 714 ] unit-test
 715
 716 [ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
 717
 718 [ ] [
 719     "IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test kex ;"
 720     <string-reader> "change-slot-test" parse-stream
 721     drop
 722 ] unit-test
 723
 724 [ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
 725
 726 [ ] [
 727     "IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; SLOT: kex M: change-slot-test kex>> drop 3 ;"
 728     <string-reader> "change-slot-test" parse-stream
 729     drop
 730 ] unit-test
 731
 732 [ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
 733 [ f ] [ \ change-slot-test \ kex>> method "reading" word-prop ] unit-test