1 USING: accessors arrays assocs calendar classes classes.algebra
2 classes.private classes.tuple classes.tuple.private columns
3 compiler.errors compiler.units continuations definitions
4 effects eval generic generic.single generic.standard grouping
5 io.streams.string kernel kernel.private math math.constants
6 math.order namespaces parser parser.notes prettyprint
7 quotations random see sequences sequences.private slots
8 slots.private splitting strings summary threads tools.test
9 vectors vocabs words words.symbol fry literals memory ;
10 IN: classes.tuple.tests
13 : <rect> ( x y w h -- rect ) rect boa ;
15 : move ( x rect -- rect )
18 [ f ] [ 10 20 30 40 <rect> dup clone 5 swap move = ] unit-test
20 [ t ] [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
22 ! Make sure we handle tuple class redefinition
23 TUPLE: redefinition-test ;
25 C: <redefinition-test> redefinition-test
27 <redefinition-test> "redefinition-test" set
29 [ t ] [ "redefinition-test" get redefinition-test? ] unit-test
31 "IN: classes.tuple.tests TUPLE: redefinition-test ;" eval( -- )
33 [ t ] [ "redefinition-test" get redefinition-test? ] unit-test
35 ! Make sure we handle changing shapes!
38 [ ] [ 100 200 point boa "p" set ] unit-test
40 ! Use eval to sequence parsing explicitly
41 [ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval( -- ) ] unit-test
43 [ 100 ] [ "p" get x>> ] unit-test
44 [ 200 ] [ "p" get y>> ] unit-test
45 [ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
47 [ ] [ "p" get 300 ">>z" "accessors" lookup execute drop ] unit-test
49 [ 3 ] [ "p" get tuple-size ] unit-test
51 [ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
53 [ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval( -- ) ] unit-test
55 [ 2 ] [ "p" get tuple-size ] unit-test
57 [ "p" get x>> ] must-fail
58 [ 200 ] [ "p" get y>> ] unit-test
59 [ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
61 TUPLE: predicate-test ;
63 C: <predicate-test> predicate-test
65 : predicate-test ( a -- ? ) drop f ;
67 [ t ] [ <predicate-test> predicate-test? ] unit-test
69 PREDICATE: silly-pred < tuple
72 GENERIC: area ( obj -- n )
73 M: silly-pred area dup w>> swap h>> * ;
75 TUPLE: circle radius ;
76 M: circle area radius>> sq pi * ;
78 [ 200 ] [ T{ rect f 0 0 10 20 } area ] unit-test
85 [ t ] [ <empty> hashcode fixnum? ] unit-test
88 [ t length ] [ object>> t eq? ] must-fail-with
90 [ "<constructor-test>" ]
91 [ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval( -- ) word name>> ] unit-test
93 TUPLE: size-test a b c d ;
96 T{ size-test } tuple-size
97 size-test tuple-layout second =
100 GENERIC: <yo-momma> ( a -- b )
104 [ ] [ "IN: classes.tuple.tests C: <yo-momma> yo-momma" eval( -- ) ] unit-test
106 [ f ] [ \ <yo-momma> generic? ] unit-test
110 [ t ] [ \ yo-momma class? ] unit-test
111 [ ] [ \ yo-momma forget ] unit-test
112 [ ] [ \ <yo-momma> forget ] unit-test
113 [ f ] [ \ yo-momma update-map get values member-eq? ] unit-test
114 ] with-compilation-unit
116 TUPLE: loc-recording ;
118 [ f ] [ \ loc-recording where not ] unit-test
120 ! 'forget' wasn't robust enough
122 TUPLE: forget-robustness ;
124 GENERIC: forget-robustness-generic ( a -- b )
126 M: forget-robustness forget-robustness-generic ;
128 M: integer forget-robustness-generic ;
131 [ ] [ \ forget-robustness-generic forget ] unit-test
132 [ ] [ \ forget-robustness forget ] unit-test
133 [ ] [ M\ forget-robustness forget-robustness-generic forget ] unit-test
134 ] with-compilation-unit
136 ! rapido found this one
137 GENERIC# m1 0 ( s n -- n )
138 GENERIC# m2 1 ( s n -- v )
162 [ 1 ] [ 1 <t4> m1 ] unit-test
163 [ 1 ] [ <t4> 1 m2 ] unit-test
165 ! another combination issue
166 GENERIC: silly ( obj -- obj obj )
168 UNION: my-union slice repetition column array vector reversed ;
170 M: my-union silly "x" ;
174 M: column silly "fdsfds" ;
176 M: repetition silly "zzz" ;
178 M: reversed silly "zz" ;
180 M: slice silly "tt" ;
182 M: string silly "t" ;
184 M: vector silly "z" ;
186 [ "zz" ] [ 123 <reversed> silly nip ] unit-test
189 SYMBOL: not-a-tuple-class
192 [ not-a-tuple-class boa ] must-fail
193 [ not-a-tuple-class new ] must-fail
195 TUPLE: erg's-reshape-problem a b c d ;
197 C: <erg's-reshape-problem> erg's-reshape-problem
200 TUPLE: computer cpu ram ;
201 C: <computer> computer
203 [ "TUPLE: computer cpu ram ;" ] [
204 [ \ computer see ] with-string-writer string-lines second
207 TUPLE: laptop < computer battery ;
210 [ t ] [ laptop tuple-class? ] unit-test
211 [ t ] [ laptop tuple class<= ] unit-test
212 [ t ] [ laptop computer class<= ] unit-test
213 [ t ] [ laptop computer classes-intersect? ] unit-test
215 [ ] [ "Pentium" 128 3 hours <laptop> "laptop" set ] unit-test
216 [ t ] [ "laptop" get laptop? ] unit-test
217 [ t ] [ "laptop" get computer? ] unit-test
218 [ t ] [ "laptop" get tuple? ] unit-test
220 : test-laptop-slot-values ( -- )
221 [ laptop ] [ "laptop" get class ] unit-test
222 [ "Pentium" ] [ "laptop" get cpu>> ] unit-test
223 [ 128 ] [ "laptop" get ram>> ] unit-test
224 [ t ] [ "laptop" get battery>> 3 hours = ] unit-test ;
226 test-laptop-slot-values
228 [ "TUPLE: laptop < computer battery ;" ] [
229 [ \ laptop see ] with-string-writer string-lines second
232 [ { tuple computer laptop } ] [ laptop superclasses ] unit-test
234 TUPLE: server < computer rackmount ;
237 [ t ] [ server tuple-class? ] unit-test
238 [ t ] [ server tuple class<= ] unit-test
239 [ t ] [ server computer class<= ] unit-test
240 [ t ] [ server computer classes-intersect? ] unit-test
242 [ ] [ "PowerPC" 64 "1U" <server> "server" set ] unit-test
243 [ t ] [ "server" get server? ] unit-test
244 [ t ] [ "server" get computer? ] unit-test
245 [ t ] [ "server" get tuple? ] unit-test
247 : test-server-slot-values ( -- )
248 [ server ] [ "server" get class ] unit-test
249 [ "PowerPC" ] [ "server" get cpu>> ] unit-test
250 [ 64 ] [ "server" get ram>> ] unit-test
251 [ "1U" ] [ "server" get rackmount>> ] unit-test ;
253 test-server-slot-values
255 [ f ] [ "server" get laptop? ] unit-test
256 [ f ] [ "laptop" get server? ] unit-test
258 [ f ] [ server laptop class<= ] unit-test
259 [ f ] [ laptop server class<= ] unit-test
260 [ f ] [ laptop server classes-intersect? ] unit-test
262 [ f ] [ 1 2 <computer> laptop? ] unit-test
263 [ f ] [ \ + server? ] unit-test
265 [ "TUPLE: server < computer rackmount ;" ] [
266 [ \ server see ] with-string-writer string-lines second
270 "IN: classes.tuple.tests TUPLE: invalid-superclass < word ;" eval( -- )
273 ! Dynamically changing inheritance hierarchy
274 TUPLE: electronic-device ;
276 : computer?' ( a -- b ) computer? ;
278 [ t ] [ laptop new computer?' ] unit-test
280 [ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
282 [ t ] [ laptop new computer?' ] unit-test
284 [ f ] [ electronic-device laptop class<= ] unit-test
285 [ t ] [ server electronic-device class<= ] unit-test
286 [ t ] [ laptop server class-or electronic-device class<= ] unit-test
288 [ t ] [ "laptop" get electronic-device? ] unit-test
289 [ t ] [ "laptop" get computer? ] unit-test
290 [ t ] [ "laptop" get laptop? ] unit-test
291 [ f ] [ "laptop" get server? ] unit-test
293 [ t ] [ "server" get electronic-device? ] unit-test
294 [ t ] [ "server" get computer? ] unit-test
295 [ f ] [ "server" get laptop? ] unit-test
296 [ t ] [ "server" get server? ] unit-test
298 [ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
300 [ f ] [ "laptop" get electronic-device? ] unit-test
301 [ t ] [ "laptop" get computer? ] unit-test
303 [ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
305 test-laptop-slot-values
306 test-server-slot-values
308 [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
310 test-laptop-slot-values
311 test-server-slot-values
313 TUPLE: make-me-some-accessors voltage grounded? ;
315 [ f ] [ "laptop" get voltage>> ] unit-test
316 [ f ] [ "server" get voltage>> ] unit-test
318 [ ] [ "laptop" get 220 >>voltage drop ] unit-test
319 [ ] [ "server" get 110 >>voltage drop ] unit-test
321 [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ; C: <computer> computer" eval( -- ) ] unit-test
323 test-laptop-slot-values
324 test-server-slot-values
326 [ 220 ] [ "laptop" get voltage>> ] unit-test
327 [ 110 ] [ "server" get voltage>> ] unit-test
329 [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
331 test-laptop-slot-values
332 test-server-slot-values
334 [ 220 ] [ "laptop" get voltage>> ] unit-test
335 [ 110 ] [ "server" get voltage>> ] unit-test
337 ! Reshaping superclass and subclass simultaneously
338 [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
340 test-laptop-slot-values
341 test-server-slot-values
343 [ 220 ] [ "laptop" get voltage>> ] unit-test
344 [ 110 ] [ "server" get voltage>> ] unit-test
347 TUPLE: test1 a ; TUPLE: test2 < test1 b ;
349 "a" "b" test2 boa "test" set
352 [ "a" ] [ "test" get a>> ] unit-test
353 [ "b" ] [ "test" get b>> ] unit-test ;
357 [ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval( -- ) ] unit-test
361 [ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval( -- ) ] unit-test
365 ! Twice in the same compilation unit
367 test1 tuple { "a" "x" "y" } define-tuple-class
368 test1 tuple { "a" "y" } define-tuple-class
369 ] with-compilation-unit
373 ! Moving slots up and down
374 TUPLE: move-up-1 a b ;
375 TUPLE: move-up-2 < move-up-1 c ;
377 T{ move-up-2 f "a" "b" "c" } "move-up" set
379 : test-move-up ( -- )
380 [ "a" ] [ "move-up" get a>> ] unit-test
381 [ "b" ] [ "move-up" get b>> ] unit-test
382 [ "c" ] [ "move-up" get c>> ] unit-test ;
386 [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval( -- ) ] unit-test
390 [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval( -- ) ] unit-test
394 [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval( -- ) ] unit-test
398 [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval( -- ) ] unit-test
400 ! Constructors must be recompiled when changing superclass
401 TUPLE: constructor-update-1 xxx ;
403 TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ;
405 : <constructor-update-2> ( a b c -- tuple ) constructor-update-2 boa ;
407 { 3 1 } [ <constructor-update-2> ] must-infer-as
409 [ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval( -- ) ] unit-test
411 { 3 1 } [ <constructor-update-2> ] must-infer-as
413 [ 1 2 3 4 5 <constructor-update-2> ] [ not-compiled? ] must-fail-with
415 [ ] [ [ \ <constructor-update-2> forget ] with-compilation-unit ] unit-test
417 ! Redefinition problem
418 TUPLE: redefinition-problem ;
420 UNION: redefinition-problem' redefinition-problem integer ;
422 [ t ] [ 3 redefinition-problem'? ] unit-test
424 TUPLE: redefinition-problem-2 ;
426 "IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" eval( -- )
428 [ t ] [ 3 redefinition-problem'? ] unit-test
430 ! Hardcore unit tests
432 \ thread "slots" word-prop "slots" set
436 \ thread tuple { "xxx" } "slots" get append
438 ] with-compilation-unit
440 [ 1337 sleep ] "Test" spawn drop
443 \ thread tuple "slots" get
445 ] with-compilation-unit
448 \ vocab "slots" word-prop "slots" set
452 \ vocab identity-tuple { "xxx" } "slots" get append
454 ] with-compilation-unit
459 \ vocab identity-tuple "slots" get
461 ] with-compilation-unit
464 [ "USE: words T{ word }" eval( -- ) ]
465 [ error>> T{ no-method f word new } = ]
468 ! Accessors not being forgotten...
470 "IN: classes.tuple.tests TUPLE: forget-accessors-test x y z ;"
472 "forget-accessors-test" parse-stream
475 [ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
477 : accessor-exists? ( name -- ? )
478 [ "forget-accessors-test" "classes.tuple.tests" lookup ] dip
479 ">>" append "accessors" lookup method >boolean ;
481 [ t ] [ "x" accessor-exists? ] unit-test
482 [ t ] [ "y" accessor-exists? ] unit-test
483 [ t ] [ "z" accessor-exists? ] unit-test
486 "IN: classes.tuple.tests GENERIC: forget-accessors-test ( a -- b )"
488 "forget-accessors-test" parse-stream
491 [ f ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
493 [ f ] [ "x" accessor-exists? ] unit-test
494 [ f ] [ "y" accessor-exists? ] unit-test
495 [ f ] [ "z" accessor-exists? ] unit-test
497 TUPLE: another-forget-accessors-test ;
501 "IN: classes.tuple.tests GENERIC: another-forget-accessors-test ( a -- b )"
503 "another-forget-accessors-test" parse-stream
506 [ t ] [ \ another-forget-accessors-test class? ] unit-test
512 "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval( -- )
513 ] with-string-writer empty?
517 ! Missing error check
518 [ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval( -- ) ] must-fail
520 ! Insufficient type checking
521 [ \ vocab tuple>array drop ] must-fail
523 ! Check type declarations
524 TUPLE: declared-types { n fixnum } { m string } ;
526 [ T{ declared-types f 0 "hi" } ]
527 [ { declared-types 0 "hi" } >tuple ]
530 [ { declared-types "hi" 0 } >tuple ]
531 [ T{ bad-slot-value f "hi" fixnum } = ]
534 ! Check fixnum coercer
535 [ 0 ] [ 0.0 "hi" declared-types boa n>> ] unit-test
537 [ 0 ] [ declared-types new 0.0 >>n n>> ] unit-test
539 ! Check bignum coercer
540 TUPLE: bignum-coercer { n bignum initial: $[ 0 >bignum ] } ;
542 [ 13 bignum ] [ 13.5 bignum-coercer boa n>> dup class ] unit-test
544 [ 13 bignum ] [ bignum-coercer new 13.5 >>n n>> dup class ] unit-test
546 ! Check float coercer
547 TUPLE: float-coercer { n float } ;
549 [ 13.0 float ] [ 13 float-coercer boa n>> dup class ] unit-test
551 [ 13.0 float ] [ float-coercer new 13 >>n n>> dup class ] unit-test
553 ! Check integer coercer
554 TUPLE: integer-coercer { n integer } ;
556 [ 13 fixnum ] [ 13.5 integer-coercer boa n>> dup class ] unit-test
558 [ 13 fixnum ] [ integer-coercer new 13.5 >>n n>> dup class ] unit-test
560 : foo ( a b -- c ) declared-types boa ;
562 \ foo def>> must-infer
564 [ T{ declared-types f 0 "hi" } ] [ 0.0 "hi" foo ] unit-test
566 [ "hi" 0.0 declared-types boa ]
567 [ T{ no-method f "hi" >fixnum } = ]
570 [ 0 { } declared-types boa ]
571 [ T{ bad-slot-value f { } string } = ]
575 [ T{ no-method f "hi" >fixnum } = ]
579 [ T{ bad-slot-value f { } string } = ]
582 [ T{ declared-types f 0 "" } ] [ declared-types new ] unit-test
584 : blah ( -- vec ) vector new ;
586 [ vector new ] must-infer
588 [ V{ } ] [ blah ] unit-test
590 ! Test reshaping with type declarations and slot attributes
591 TUPLE: reshape-test x ;
593 T{ reshape-test f "hi" } "tuple" set
595 [ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval( -- ) ] unit-test
597 [ f ] [ \ reshape-test \ x<< method ] unit-test
599 [ "tuple" get 5 >>x ] must-fail
601 [ "hi" ] [ "tuple" get x>> ] unit-test
603 [ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval( -- ) ] unit-test
605 [ 0 ] [ "tuple" get x>> ] unit-test
607 [ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval( -- ) ] unit-test
609 [ 0 ] [ "tuple" get x>> ] unit-test
611 TUPLE: boa-coercer-test { x array-capacity } ;
613 [ fixnum ] [ 0 >bignum boa-coercer-test boa x>> class ] unit-test
615 [ T{ boa-coercer-test f 0 } ] [ T{ boa-coercer-test } ] unit-test
618 ERROR: error-class-test a b c ;
620 [ "( a b c -- * )" ] [ \ error-class-test stack-effect effect>string ] unit-test
621 [ f ] [ \ error-class-test "inline" word-prop ] unit-test
623 [ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval( -- ) ]
624 [ error>> error>> redefine-error? ] must-fail-with
628 [ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test
630 [ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval( -- ) ] unit-test
632 [ f ] [ \ error-y tuple-class? ] unit-test
634 [ f ] [ \ error-y error-class? ] unit-test
636 [ t ] [ \ error-y generic? ] unit-test
638 [ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval( -- ) ] unit-test
640 [ t ] [ \ error-y tuple-class? ] unit-test
642 [ t ] [ \ error-y error-class? ] unit-test
644 [ f ] [ \ error-y generic? ] unit-test
647 "IN: classes.tuple.tests TUPLE: forget-subclass-test ; TUPLE: forget-subclass-test' < forget-subclass-test ;"
648 <string-reader> "forget-subclass-test" parse-stream
652 [ ] [ "forget-subclass-test'" "classes.tuple.tests" lookup new "bad-object" set ] unit-test
655 "IN: classes.tuple.tests TUPLE: forget-subclass-test a ;"
656 <string-reader> "forget-subclass-test" parse-stream
661 "IN: sequences TUPLE: reversed { seq read-only } ;" eval( -- )
664 TUPLE: bogus-hashcode-1 x ;
666 TUPLE: bogus-hashcode-2 x ;
668 M: bogus-hashcode-1 hashcode* 2drop 0 >bignum ;
670 [ ] [ T{ bogus-hashcode-2 f T{ bogus-hashcode-1 } } hashcode drop ] unit-test
672 DEFER: change-slot-test
676 "IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; SLOT: kex M: change-slot-test kex>> drop 3 ;"
677 <string-reader> "change-slot-test" parse-stream
681 [ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
684 "IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test kex ;"
685 <string-reader> "change-slot-test" parse-stream
689 [ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
692 "IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; SLOT: kex M: change-slot-test kex>> drop 3 ;"
693 <string-reader> "change-slot-test" parse-stream
697 [ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
698 [ f ] [ \ change-slot-test \ kex>> method "reading" word-prop ] unit-test
700 DEFER: redefine-tuple-twice
702 [ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
704 [ t ] [ \ redefine-tuple-twice symbol? ] unit-test
706 [ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval( -- ) ] unit-test
708 [ t ] [ \ redefine-tuple-twice deferred? ] unit-test
710 [ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
712 [ t ] [ \ redefine-tuple-twice symbol? ] unit-test
714 ERROR: base-error x y ;
715 ERROR: derived-error < base-error z ;
717 [ (( x y z -- * )) ] [ \ derived-error stack-effect ] unit-test
719 ! Make sure that tuple reshaping updates code heap roots
720 TUPLE: code-heap-ref ;
722 : code-heap-ref' ( -- a ) T{ code-heap-ref } ;
724 ! Push foo's literal to tenured space
728 [ ] [ "IN: classes.tuple.tests USE: math TUPLE: code-heap-ref { x integer initial: 5 } ;" eval( -- ) ] unit-test
730 ! Code heap reference
731 [ t ] [ code-heap-ref' code-heap-ref? ] unit-test
732 [ 5 ] [ code-heap-ref' x>> ] unit-test
734 ! Data heap reference
735 [ t ] [ \ code-heap-ref' def>> first code-heap-ref? ] unit-test
736 [ 5 ] [ \ code-heap-ref' def>> first x>> ] unit-test
738 ! If the metaclass of a superclass changes into something other
739 ! than a tuple class, the tuple needs to have its superclass reset
740 TUPLE: metaclass-change ;
741 TUPLE: metaclass-change-subclass < metaclass-change ;
743 [ metaclass-change ] [ metaclass-change-subclass superclass ] unit-test
745 [ ] [ "IN: classes.tuple.tests MIXIN: metaclass-change" eval( -- ) ] unit-test
747 [ t ] [ metaclass-change-subclass tuple-class? ] unit-test
748 [ tuple ] [ metaclass-change-subclass superclass ] unit-test
750 ! Reshaping bug related to the above
754 [ ] [ g new "g" set ] unit-test
756 [ ] [ "IN: classes.tuple.tests MIXIN: a-g TUPLE: g ;" eval( -- ) ] unit-test
758 [ t ] [ g new layout-of "g" get layout-of eq? ] unit-test
760 ! Joe Groff discovered this bug
761 DEFER: factor-crashes-anymore
764 "IN: classes.tuple.tests
765 TUPLE: unsafe-slot-access ;
766 CONSTANT: unsafe-slot-access' T{ unsafe-slot-access }" eval( -- )
770 "IN: classes.tuple.tests
772 TUPLE: unsafe-slot-access { x read-only initial: 31337 } ;
773 : factor-crashes-anymore ( -- x ) unsafe-slot-access' x>> ;" eval( -- )
776 [ 31337 ] [ factor-crashes-anymore ] unit-test
778 TUPLE: tuple-predicate-redefine-test ;
780 [ ] [ "IN: classes.tuple.tests TUPLE: tuple-predicate-redefine-test ;" eval( -- ) ] unit-test
782 [ t ] [ \ tuple-predicate-redefine-test? predicate? ] unit-test
785 TUPLE: final-superclass ;
786 TUPLE: final-subclass < final-superclass ;
788 [ final-superclass ] [ final-subclass superclass ] unit-test
790 ! Making the superclass final should change the superclass of the subclass
791 [ ] [ "IN: classes.tuple.tests TUPLE: final-superclass ; final" eval( -- ) ] unit-test
793 [ tuple ] [ final-subclass superclass ] unit-test
795 [ f ] [ \ final-subclass final-class? ] unit-test
797 ! Subclassing a final class should fail
798 [ "IN: classes.tuple.tests TUPLE: final-subclass < final-superclass ;" eval( -- ) ]
799 [ error>> bad-superclass? ] must-fail-with
801 ! Making a final class non-final should work
802 [ ] [ "IN: classes.tuple.tests TUPLE: final-superclass ;" eval( -- ) ] unit-test
804 [ ] [ "IN: classes.tuple.tests TUPLE: final-subclass < final-superclass ; final" eval( -- ) ] unit-test
806 ! Changing a superclass should not change the final status of a subclass
807 [ ] [ "IN: classes.tuple.tests TUPLE: final-superclass x ;" eval( -- ) ] unit-test
809 [ t ] [ \ final-subclass final-class? ] unit-test