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
14 : <rect> ( x y w h -- rect ) rect boa ;
16 : move ( x rect -- rect )
19 { f } [ 10 20 30 40 <rect> dup clone 5 swap move = ] unit-test
21 { t } [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
23 ! Make sure we handle tuple class redefinition
24 TUPLE: redefinition-test ;
26 C: <redefinition-test> redefinition-test
28 <redefinition-test> "redefinition-test" set
30 { t } [ "redefinition-test" get redefinition-test? ] unit-test
32 "IN: classes.tuple.tests TUPLE: redefinition-test ;" eval( -- )
34 { t } [ "redefinition-test" get redefinition-test? ] unit-test
36 ! Make sure we handle changing shapes!
39 { } [ 100 200 point boa "p" set ] unit-test
41 ! Use eval to sequence parsing explicitly
42 { } [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval( -- ) ] unit-test
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
48 { } [ "p" get 300 ">>z" "accessors" lookup-word execute drop ] unit-test
50 { 3 } [ "p" get tuple-size ] unit-test
52 { 300 } [ "p" get "z>>" "accessors" lookup-word execute ] unit-test
54 { } [ "IN: classes.tuple.tests TUPLE: point z y ;" eval( -- ) ] unit-test
56 { 2 } [ "p" get tuple-size ] unit-test
58 [ "p" get x>> ] must-fail
59 { 200 } [ "p" get y>> ] unit-test
60 { 300 } [ "p" get "z>>" "accessors" lookup-word execute ] unit-test
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
68 TUPLE: predicate-test ;
70 C: <predicate-test> predicate-test
72 : predicate-test ( a -- ? ) drop f ;
74 { t } [ <predicate-test> predicate-test? ] unit-test
76 PREDICATE: silly-pred < tuple
79 GENERIC: area ( obj -- n )
80 M: silly-pred area dup w>> swap h>> * ;
82 TUPLE: circle radius ;
83 M: circle area radius>> sq pi * ;
85 { 200 } [ T{ rect f 0 0 10 20 } area ] unit-test
92 { t } [ <empty> hashcode fixnum? ] unit-test
95 [ t length ] [ object>> t eq? ] must-fail-with
97 { "<constructor-test>" }
98 [ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval( -- ) last-word name>> ] unit-test
100 TUPLE: size-test a b c d ;
103 T{ size-test } tuple-size
104 size-test tuple-layout second =
107 GENERIC: <yo-momma> ( a -- b )
111 { } [ "IN: classes.tuple.tests C: <yo-momma> yo-momma" eval( -- ) ] unit-test
113 { f } [ \ <yo-momma> generic? ] unit-test
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
123 TUPLE: loc-recording ;
125 { f } [ \ loc-recording where not ] unit-test
127 ! 'forget' wasn't robust enough
129 TUPLE: forget-robustness ;
131 GENERIC: forget-robustness-generic ( a -- b )
133 M: forget-robustness forget-robustness-generic ;
135 M: integer forget-robustness-generic ;
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
143 ! rapido found this one
144 GENERIC# m1 0 ( s n -- n )
145 GENERIC# m2 1 ( s n -- v )
169 { 1 } [ 1 <t4> m1 ] unit-test
170 { 1 } [ <t4> 1 m2 ] unit-test
172 ! another combination issue
173 GENERIC: silly ( obj -- obj obj )
175 UNION: my-union slice repetition column array vector reversed ;
177 M: my-union silly "x" ;
181 M: column silly "fdsfds" ;
183 M: repetition silly "zzz" ;
185 M: reversed silly "zz" ;
187 M: slice silly "tt" ;
189 M: string silly "t" ;
191 M: vector silly "z" ;
193 { "zz" } [ 123 <reversed> silly nip ] unit-test
196 SYMBOL: not-a-tuple-class
199 [ not-a-tuple-class boa ] must-fail
200 [ not-a-tuple-class new ] must-fail
202 TUPLE: erg's-reshape-problem a b c d ;
204 C: <erg's-reshape-problem> erg's-reshape-problem
207 TUPLE: computer cpu ram ;
208 C: <computer> computer
210 { "TUPLE: computer cpu ram ;" } [
211 [ \ computer see ] with-string-writer string-lines second
214 TUPLE: laptop < computer battery ;
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
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
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 ;
233 test-laptop-slot-values
235 { "TUPLE: laptop < computer battery ;" } [
236 [ \ laptop see ] with-string-writer string-lines second
239 { { tuple computer laptop } } [ laptop superclasses ] unit-test
241 TUPLE: server < computer rackmount ;
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
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
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 ;
260 test-server-slot-values
262 { f } [ "server" get laptop? ] unit-test
263 { f } [ "laptop" get server? ] unit-test
265 { f } [ server laptop class<= ] unit-test
266 { f } [ laptop server class<= ] unit-test
267 { f } [ laptop server classes-intersect? ] unit-test
269 { f } [ 1 2 <computer> laptop? ] unit-test
270 { f } [ \ + server? ] unit-test
272 { "TUPLE: server < computer rackmount ;" } [
273 [ \ server see ] with-string-writer string-lines second
277 "IN: classes.tuple.tests TUPLE: invalid-superclass < word ;" eval( -- )
280 ! Dynamically changing inheritance hierarchy
281 TUPLE: electronic-device ;
283 : computer?' ( a -- b ) computer? ;
285 { t } [ laptop new computer?' ] unit-test
287 { } [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
289 { t } [ laptop new computer?' ] unit-test
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
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
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
305 { } [ "IN: classes.tuple.tests TUPLE: computer cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
307 { f } [ "laptop" get electronic-device? ] unit-test
308 { t } [ "laptop" get computer? ] unit-test
310 { } [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
312 test-laptop-slot-values
313 test-server-slot-values
315 { } [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
317 test-laptop-slot-values
318 test-server-slot-values
320 TUPLE: make-me-some-accessors voltage grounded? ;
322 { f } [ "laptop" get voltage>> ] unit-test
323 { f } [ "server" get voltage>> ] unit-test
325 { } [ "laptop" get 220 >>voltage drop ] unit-test
326 { } [ "server" get 110 >>voltage drop ] unit-test
328 { } [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ; C: <computer> computer" eval( -- ) ] unit-test
330 test-laptop-slot-values
331 test-server-slot-values
333 { 220 } [ "laptop" get voltage>> ] unit-test
334 { 110 } [ "server" get voltage>> ] unit-test
336 { } [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
338 test-laptop-slot-values
339 test-server-slot-values
341 { 220 } [ "laptop" get voltage>> ] unit-test
342 { 110 } [ "server" get voltage>> ] unit-test
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
347 test-laptop-slot-values
348 test-server-slot-values
350 { 220 } [ "laptop" get voltage>> ] unit-test
351 { 110 } [ "server" get voltage>> ] unit-test
354 TUPLE: test1 a ; TUPLE: test2 < test1 b ;
356 "a" "b" test2 boa "test" set
359 [ "a" ] [ "test" get a>> ] unit-test
360 [ "b" ] [ "test" get b>> ] unit-test ;
364 { } [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval( -- ) ] unit-test
368 { } [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval( -- ) ] unit-test
372 ! Twice in the same compilation unit
374 test1 tuple { "a" "x" "y" } define-tuple-class
375 test1 tuple { "a" "y" } define-tuple-class
376 ] with-compilation-unit
380 ! Moving slots up and down
381 TUPLE: move-up-1 a b ;
382 TUPLE: move-up-2 < move-up-1 c ;
384 T{ move-up-2 f "a" "b" "c" } "move-up" set
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 ;
393 { } [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval( -- ) ] unit-test
397 { } [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval( -- ) ] unit-test
401 { } [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval( -- ) ] unit-test
405 { } [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval( -- ) ] unit-test
407 ! Constructors must be recompiled when changing superclass
408 TUPLE: constructor-update-1 xxx ;
410 TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ;
412 : <constructor-update-2> ( a b c -- tuple ) constructor-update-2 boa ;
414 { 3 1 } [ <constructor-update-2> ] must-infer-as
416 { } [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval( -- ) ] unit-test
418 { 3 1 } [ <constructor-update-2> ] must-infer-as
420 [ 1 2 3 4 5 <constructor-update-2> ] [ not-compiled? ] must-fail-with
422 { } [ [ \ <constructor-update-2> forget ] with-compilation-unit ] unit-test
424 ! Redefinition problem
425 TUPLE: redefinition-problem ;
427 UNION: redefinition-problem' redefinition-problem integer ;
429 { t } [ 3 redefinition-problem'? ] unit-test
431 TUPLE: redefinition-problem-2 ;
433 "IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" eval( -- )
435 { t } [ 3 redefinition-problem'? ] unit-test
437 ! Hardcore unit tests
439 \ thread "slots" word-prop "slots" set
443 \ thread tuple { "xxx" } "slots" get append
445 ] with-compilation-unit
447 [ 1337 sleep ] "Test" spawn drop
450 \ thread tuple "slots" get
452 ] with-compilation-unit
455 \ vocab "slots" word-prop "slots" set
459 \ vocab identity-tuple { "xxx" } "slots" get append
461 ] with-compilation-unit
466 \ vocab identity-tuple "slots" get
468 ] with-compilation-unit
471 [ "USE: words T{ word }" eval( -- ) ]
472 [ error>> T{ no-method f word new } = ]
475 ! Accessors not being forgotten...
477 "IN: classes.tuple.tests TUPLE: forget-accessors-test x y z ;"
479 "forget-accessors-test" parse-stream
482 { t } [ "forget-accessors-test" "classes.tuple.tests" lookup-word class? ] unit-test
484 : accessor-exists? ( name -- ? )
485 [ "forget-accessors-test" "classes.tuple.tests" lookup-word ] dip
486 ">>" append "accessors" lookup-word ?lookup-method >boolean ;
488 { t } [ "x" accessor-exists? ] unit-test
489 { t } [ "y" accessor-exists? ] unit-test
490 { t } [ "z" accessor-exists? ] unit-test
493 "IN: classes.tuple.tests GENERIC: forget-accessors-test ( a -- b )"
495 "forget-accessors-test" parse-stream
498 { f } [ "forget-accessors-test" "classes.tuple.tests" lookup-word class? ] unit-test
500 { f } [ "x" accessor-exists? ] unit-test
501 { f } [ "y" accessor-exists? ] unit-test
502 { f } [ "z" accessor-exists? ] unit-test
504 TUPLE: another-forget-accessors-test ;
508 "IN: classes.tuple.tests GENERIC: another-forget-accessors-test ( a -- b )"
510 "another-forget-accessors-test" parse-stream
513 { t } [ \ another-forget-accessors-test class? ] unit-test
519 "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval( -- )
520 ] with-string-writer empty?
524 ! Missing error check
525 [ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval( -- ) ] must-fail
527 ! Insufficient type checking
528 [ \ vocab tuple>array drop ] must-fail
530 ! Check type declarations
531 TUPLE: declared-types { n fixnum } { m string } ;
533 { T{ declared-types f 0 "hi" } }
534 [ { declared-types 0 "hi" } >tuple ]
537 [ { declared-types "hi" 0 } >tuple ]
538 [ T{ bad-slot-value f "hi" fixnum } = ]
541 ! Check fixnum coercer
542 [ 0.0 "hi" declared-types boa n>> ] [ T{ no-method f 0.0 integer>fixnum-strict } = ] must-fail-with
544 [ declared-types new 0.0 >>n n>> ] [ T{ no-method f 0.0 integer>fixnum-strict } = ] must-fail-with
546 { T{ declared-types f 33333 "asdf" } }
547 [ 33333 >bignum "asdf" declared-types boa ] unit-test
549 [ 444444444444444444444444444444444444444444444444433333 >bignum "asdf" declared-types boa ]
551 ${ "kernel-error" ERROR-OUT-OF-FIXNUM-RANGE 444444444444444444444444444444444444444444444444433333 f } =
554 ! Check bignum coercer
555 TUPLE: bignum-coercer { n bignum initial: $[ 0 >bignum ] } ;
557 { 13 bignum } [ 13.5 bignum-coercer boa n>> dup class-of ] unit-test
559 { 13 bignum } [ bignum-coercer new 13.5 >>n n>> dup class-of ] unit-test
561 ! Check float coercer
562 TUPLE: float-coercer { n float } ;
564 { 13.0 float } [ 13 float-coercer boa n>> dup class-of ] unit-test
566 { 13.0 float } [ float-coercer new 13 >>n n>> dup class-of ] unit-test
568 ! Check integer coercer
569 TUPLE: integer-coercer { n integer } ;
571 [ 13.5 integer-coercer boa n>> dup class-of ] [ T{ bad-slot-value f 13.5 integer } = ] must-fail-with
573 [ integer-coercer new 13.5 >>n n>> dup class-of ] [ T{ bad-slot-value f 13.5 integer } = ] must-fail-with
575 : foo ( a b -- c ) declared-types boa ;
577 \ foo def>> must-infer
579 [ 0.0 "hi" foo ] [ T{ no-method f 0.0 integer>fixnum-strict } = ] must-fail-with
581 [ "hi" 0.0 declared-types boa ]
582 [ T{ no-method f "hi" integer>fixnum-strict } = ]
585 [ 0 { } declared-types boa ]
586 [ T{ bad-slot-value f { } string } = ]
590 [ T{ no-method f "hi" integer>fixnum-strict } = ]
594 [ T{ bad-slot-value f { } string } = ]
597 { T{ declared-types f 0 "" } } [ declared-types new ] unit-test
599 : blah ( -- vec ) vector new ;
601 [ vector new ] must-infer
603 { V{ } } [ blah ] unit-test
605 ! Test reshaping with type declarations and slot attributes
606 TUPLE: reshape-test x ;
608 T{ reshape-test f "hi" } "tuple" set
610 { } [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval( -- ) ] unit-test
612 { f } [ \ reshape-test \ x<< ?lookup-method ] unit-test
614 [ "tuple" get 5 >>x ] must-fail
616 { "hi" } [ "tuple" get x>> ] unit-test
618 { } [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval( -- ) ] unit-test
620 { 0 } [ "tuple" get x>> ] unit-test
622 { } [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval( -- ) ] unit-test
624 { 0 } [ "tuple" get x>> ] unit-test
626 TUPLE: boa-coercer-test { x array-capacity } ;
628 { fixnum } [ 0 >bignum boa-coercer-test boa x>> class-of ] unit-test
630 { T{ boa-coercer-test f 0 } } [ T{ boa-coercer-test } ] unit-test
633 ERROR: error-class-test a b c ;
635 { "( a b c -- * )" } [ \ error-class-test stack-effect effect>string ] unit-test
636 { f } [ \ error-class-test "inline" word-prop ] unit-test
638 [ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval( -- ) ]
639 [ error>> error>> redefine-error? ] must-fail-with
643 { } [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test
645 { } [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval( -- ) ] unit-test
647 { f } [ \ error-y tuple-class? ] unit-test
649 { f } [ \ error-y error-class? ] unit-test
651 { t } [ \ error-y generic? ] unit-test
653 { } [ "IN: classes.tuple.tests ERROR: error-y ;" eval( -- ) ] unit-test
655 { t } [ \ error-y tuple-class? ] unit-test
657 { t } [ \ error-y error-class? ] unit-test
659 { f } [ \ error-y generic? ] unit-test
662 "IN: classes.tuple.tests TUPLE: forget-subclass-test ; TUPLE: forget-subclass-test' < forget-subclass-test ;"
663 <string-reader> "forget-subclass-test" parse-stream
667 { } [ "forget-subclass-test'" "classes.tuple.tests" lookup-word new "bad-object" set ] unit-test
670 "IN: classes.tuple.tests TUPLE: forget-subclass-test a ;"
671 <string-reader> "forget-subclass-test" parse-stream
676 "IN: sequences TUPLE: reversed { seq read-only } ;" eval( -- )
679 TUPLE: bogus-hashcode-1 x ;
681 TUPLE: bogus-hashcode-2 x ;
683 M: bogus-hashcode-1 hashcode* 2drop 0 >bignum ;
685 { } [ T{ bogus-hashcode-2 f T{ bogus-hashcode-1 } } hashcode drop ] unit-test
687 DEFER: change-slot-test
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
696 { t } [ \ change-slot-test \ kex>> ?lookup-method >boolean ] unit-test
699 "IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test kex ;"
700 <string-reader> "change-slot-test" parse-stream
704 { t } [ \ change-slot-test \ kex>> ?lookup-method >boolean ] unit-test
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
712 { t } [ \ change-slot-test \ kex>> ?lookup-method >boolean ] unit-test
713 { f } [ \ change-slot-test \ kex>> ?lookup-method "reading" word-prop ] unit-test
715 DEFER: redefine-tuple-twice
717 { } [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
719 { t } [ \ redefine-tuple-twice symbol? ] unit-test
721 { } [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval( -- ) ] unit-test
723 { t } [ \ redefine-tuple-twice deferred? ] unit-test
725 { } [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
727 { t } [ \ redefine-tuple-twice symbol? ] unit-test
729 ERROR: base-error x y ;
730 ERROR: derived-error < base-error z ;
732 { ( x y z -- * ) } [ \ derived-error stack-effect ] unit-test
734 ! Make sure that tuple reshaping updates code heap roots
735 TUPLE: code-heap-ref ;
737 : code-heap-ref' ( -- a ) T{ code-heap-ref } ;
739 ! Push foo's literal to tenured space
743 { } [ "IN: classes.tuple.tests USE: math TUPLE: code-heap-ref { x integer initial: 5 } ;" eval( -- ) ] unit-test
745 ! Code heap reference
746 { t } [ code-heap-ref' code-heap-ref? ] unit-test
747 { 5 } [ code-heap-ref' x>> ] unit-test
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
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 ;
758 { metaclass-change } [ metaclass-change-subclass superclass ] unit-test
760 { } [ "IN: classes.tuple.tests MIXIN: metaclass-change" eval( -- ) ] unit-test
762 { t } [ metaclass-change-subclass tuple-class? ] unit-test
763 { tuple } [ metaclass-change-subclass superclass ] unit-test
765 ! Reshaping bug related to the above
769 { } [ g new "g" set ] unit-test
771 { } [ "IN: classes.tuple.tests MIXIN: a-g TUPLE: g ;" eval( -- ) ] unit-test
773 { t } [ g new layout-of "g" get layout-of eq? ] unit-test
775 ! Joe Groff discovered this bug
776 DEFER: factor-crashes-anymore
779 "IN: classes.tuple.tests
780 TUPLE: unsafe-slot-access ;
781 CONSTANT: unsafe-slot-access' T{ unsafe-slot-access }" eval( -- )
785 "IN: classes.tuple.tests
787 TUPLE: unsafe-slot-access { x read-only initial: 31337 } ;
788 : factor-crashes-anymore ( -- x ) unsafe-slot-access' x>> ;" eval( -- )
791 { 31337 } [ factor-crashes-anymore ] unit-test
793 TUPLE: tuple-predicate-redefine-test ;
795 { } [ "IN: classes.tuple.tests TUPLE: tuple-predicate-redefine-test ;" eval( -- ) ] unit-test
797 { t } [ \ tuple-predicate-redefine-test? predicate? ] unit-test
800 TUPLE: final-superclass ;
801 TUPLE: final-subclass < final-superclass ;
803 { final-superclass } [ final-subclass superclass ] unit-test
805 ! Making the superclass final should change the superclass of the subclass
806 { } [ "IN: classes.tuple.tests TUPLE: final-superclass ; final" eval( -- ) ] unit-test
808 { tuple } [ final-subclass superclass ] unit-test
810 { f } [ \ final-subclass final-class? ] unit-test
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
816 ! Making a final class non-final should work
817 { } [ "IN: classes.tuple.tests TUPLE: final-superclass ;" eval( -- ) ] unit-test
819 { } [ "IN: classes.tuple.tests TUPLE: final-subclass < final-superclass ; final" eval( -- ) ] unit-test
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
824 { t } [ \ final-subclass final-class? ] unit-test
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
835 << \ rclasstest forget >>
837 ! initial: should type check
838 TUPLE: initial-class ;
842 { } [ "IN: classes.tuple.tests TUPLE: initial-slot { x initial-class } ;" eval( -- ) ] unit-test
844 { t } [ initial-slot new x>> initial-class? ] unit-test
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
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
852 [ "IN: classes.tuple.tests USE: math TUPLE: foo < foo ;" eval( -- ) ] [ error>> bad-superclass? ] must-fail-with
854 [ "IN: classes.tuple.tests USE: math TUPLE: foo < + ;" eval( -- ) ] [ error>> bad-superclass? ] must-fail-with
857 ! Test no-slot error and get/set-slot-named
859 TUPLE: no-slot-tuple0 a b c ;
860 C: <no-slot-tuple0> no-slot-tuple0
862 [ 1 2 3 <no-slot-tuple0> "d" over get-slot-named ]
866 [ tuple>> no-slot-tuple0? ]
872 [ 1 2 3 <no-slot-tuple0> "a" swap get-slot-named ] unit-test
875 [ 1 2 3 <no-slot-tuple0> "b" swap get-slot-named ] unit-test
878 [ 1 2 3 <no-slot-tuple0> "c" swap get-slot-named ] unit-test
881 1 2 3 <no-slot-tuple0> 4 "a" pick set-slot-named
882 "a" swap get-slot-named
885 [ 1 2 3 <no-slot-tuple0> 4 "d" pick set-slot-named ]
889 [ tuple>> no-slot-tuple0? ]