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
11 : <rect> ( x y w h -- rect ) rect boa ;
13 : move ( x rect -- rect )
16 [ f ] [ 10 20 30 40 <rect> dup clone 5 swap move = ] unit-test
18 [ t ] [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
20 ! Make sure we handle tuple class redefinition
21 TUPLE: redefinition-test ;
23 C: <redefinition-test> redefinition-test
25 <redefinition-test> "redefinition-test" set
27 [ t ] [ "redefinition-test" get redefinition-test? ] unit-test
29 "IN: classes.tuple.tests TUPLE: redefinition-test ;" eval
31 [ t ] [ "redefinition-test" get redefinition-test? ] unit-test
33 ! Make sure we handle changing shapes!
38 [ ] [ 100 200 <point> "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 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 size>> =
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 memq? ] unit-test
115 [ f ] [ \ yo-momma crossref get at ] unit-test
116 ] with-compilation-unit
118 TUPLE: loc-recording ;
120 [ f ] [ \ loc-recording where not ] unit-test
122 ! 'forget' wasn't robust enough
124 TUPLE: forget-robustness ;
126 GENERIC: forget-robustness-generic
128 M: forget-robustness forget-robustness-generic ;
130 M: integer forget-robustness-generic ;
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
138 ! rapido found this one
139 GENERIC# m1 0 ( s n -- n )
140 GENERIC# m2 1 ( s n -- v )
164 [ 1 ] [ 1 <t4> m1 ] unit-test
165 [ 1 ] [ <t4> 1 m2 ] unit-test
167 ! another combination issue
168 GENERIC: silly ( obj -- obj obj )
170 UNION: my-union slice repetition column array vector reversed ;
172 M: my-union silly "x" ;
176 M: column silly "fdsfds" ;
178 M: repetition silly "zzz" ;
180 M: reversed silly "zz" ;
182 M: slice silly "tt" ;
184 M: string silly "t" ;
186 M: vector silly "z" ;
188 [ "zz" ] [ 123 <reversed> silly nip ] unit-test
191 SYMBOL: not-a-tuple-class
194 [ not-a-tuple-class boa ] must-fail
195 [ not-a-tuple-class new ] must-fail
197 TUPLE: erg's-reshape-problem a b c d ;
199 C: <erg's-reshape-problem> erg's-reshape-problem
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 ;
206 [ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval ] unit-test
208 [ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
210 [ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
213 TUPLE: computer cpu ram ;
214 C: <computer> computer
216 [ "TUPLE: computer cpu ram ;" ] [
217 [ \ computer see ] with-string-writer string-lines second
220 TUPLE: laptop < computer battery ;
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
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
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 ;
239 test-laptop-slot-values
247 [ "TUPLE: laptop < computer battery ;" ] [
248 [ \ laptop see ] with-string-writer string-lines second
251 [ { tuple computer laptop } ] [ laptop superclasses ] unit-test
253 TUPLE: server < computer rackmount ;
256 [ t ] [ server tuple-class? ] unit-test
257 [ t ] [ server tuple class<= ] unit-test
258 [ t ] [ server computer class<= ] unit-test
259 [ t ] [ server computer classes-intersect? ] unit-test
261 [ ] [ "PowerPC" 64 "1U" <server> "server" set ] unit-test
262 [ t ] [ "server" get server? ] unit-test
263 [ t ] [ "server" get computer? ] unit-test
264 [ t ] [ "server" get tuple? ] unit-test
266 : test-server-slot-values ( -- )
267 [ server ] [ "server" get class ] unit-test
268 [ "PowerPC" ] [ "server" get cpu>> ] unit-test
269 [ 64 ] [ "server" get ram>> ] unit-test
270 [ "1U" ] [ "server" get rackmount>> ] unit-test ;
272 test-server-slot-values
274 [ f ] [ "server" get laptop? ] unit-test
275 [ f ] [ "laptop" get server? ] unit-test
277 [ f ] [ server laptop class<= ] unit-test
278 [ f ] [ laptop server class<= ] unit-test
279 [ f ] [ laptop server classes-intersect? ] unit-test
281 [ f ] [ 1 2 <computer> laptop? ] unit-test
282 [ f ] [ \ + server? ] unit-test
284 [ "TUPLE: server < computer rackmount ;" ] [
285 [ \ server see ] with-string-writer string-lines second
289 "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval
292 ! Dynamically changing inheritance hierarchy
293 TUPLE: electronic-device ;
295 [ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
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
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
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
311 [ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval ] unit-test
313 [ f ] [ "laptop" get electronic-device? ] unit-test
314 [ t ] [ "laptop" get computer? ] unit-test
316 [ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval ] unit-test
318 test-laptop-slot-values
319 test-server-slot-values
321 [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval ] unit-test
323 test-laptop-slot-values
324 test-server-slot-values
326 TUPLE: make-me-some-accessors voltage grounded? ;
328 [ f ] [ "laptop" get voltage>> ] unit-test
329 [ f ] [ "server" get voltage>> ] unit-test
331 [ ] [ "laptop" get 220 >>voltage drop ] unit-test
332 [ ] [ "server" get 110 >>voltage drop ] unit-test
334 [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval ] unit-test
336 test-laptop-slot-values
337 test-server-slot-values
339 [ 220 ] [ "laptop" get voltage>> ] unit-test
340 [ 110 ] [ "server" get voltage>> ] unit-test
342 [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval ] unit-test
344 test-laptop-slot-values
345 test-server-slot-values
347 [ 220 ] [ "laptop" get voltage>> ] unit-test
348 [ 110 ] [ "server" get voltage>> ] unit-test
350 ! Reshaping superclass and subclass simultaneously
351 [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
353 test-laptop-slot-values
354 test-server-slot-values
356 [ 220 ] [ "laptop" get voltage>> ] unit-test
357 [ 110 ] [ "server" get voltage>> ] unit-test
360 TUPLE: test1 a ; TUPLE: test2 < test1 b ;
364 "a" "b" <test2> "test" set
367 [ "a" ] [ "test" get a>> ] unit-test
368 [ "b" ] [ "test" get b>> ] unit-test ;
372 [ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval ] unit-test
376 [ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval ] unit-test
380 ! Twice in the same compilation unit
382 test1 tuple { "a" "x" "y" } define-tuple-class
383 test1 tuple { "a" "y" } define-tuple-class
384 ] with-compilation-unit
388 ! Moving slots up and down
389 TUPLE: move-up-1 a b ;
390 TUPLE: move-up-2 < move-up-1 c ;
392 T{ move-up-2 f "a" "b" "c" } "move-up" set
394 : test-move-up ( -- )
395 [ "a" ] [ "move-up" get a>> ] unit-test
396 [ "b" ] [ "move-up" get b>> ] unit-test
397 [ "c" ] [ "move-up" get c>> ] unit-test ;
401 [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval ] unit-test
405 [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval ] unit-test
409 [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval ] unit-test
413 [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval ] unit-test
415 ! Constructors must be recompiled when changing superclass
416 TUPLE: constructor-update-1 xxx ;
418 TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ;
420 C: <constructor-update-2> constructor-update-2
422 { 3 1 } [ <constructor-update-2> ] must-infer-as
424 [ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval ] unit-test
426 { 5 1 } [ <constructor-update-2> ] must-infer-as
428 [ { 1 2 3 4 5 } ] [ 1 2 3 4 5 <constructor-update-2> tuple-slots ] unit-test
430 ! Redefinition problem
431 TUPLE: redefinition-problem ;
433 UNION: redefinition-problem' redefinition-problem integer ;
435 [ t ] [ 3 redefinition-problem'? ] unit-test
437 TUPLE: redefinition-problem-2 ;
439 "IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" eval
441 [ t ] [ 3 redefinition-problem'? ] unit-test
443 ! Hardcore unit tests
446 \ thread "slots" word-prop "slots" set
450 \ thread tuple { "xxx" } "slots" get append
452 ] with-compilation-unit
454 [ 1337 sleep ] "Test" spawn drop
457 \ thread tuple "slots" get
459 ] with-compilation-unit
464 \ vocab "slots" word-prop "slots" set
468 \ vocab tuple { "xxx" } "slots" get append
470 ] with-compilation-unit
475 \ vocab tuple "slots" get
477 ] with-compilation-unit
480 [ "USE: words T{ word }" eval ]
481 [ error>> T{ no-method f word new } = ]
484 ! Accessors not being forgotten...
486 "IN: classes.tuple.tests TUPLE: forget-accessors-test x y z ;"
488 "forget-accessors-test" parse-stream
491 [ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
493 : accessor-exists? ( class name -- ? )
494 >r "forget-accessors-test" "classes.tuple.tests" lookup r>
495 ">>" append "accessors" lookup method >boolean ;
497 [ t ] [ "x" accessor-exists? ] unit-test
498 [ t ] [ "y" accessor-exists? ] unit-test
499 [ t ] [ "z" accessor-exists? ] unit-test
502 "IN: classes.tuple.tests GENERIC: forget-accessors-test"
504 "forget-accessors-test" parse-stream
507 [ f ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
509 [ f ] [ "x" accessor-exists? ] unit-test
510 [ f ] [ "y" accessor-exists? ] unit-test
511 [ f ] [ "z" accessor-exists? ] unit-test
513 TUPLE: another-forget-accessors-test ;
517 "IN: classes.tuple.tests GENERIC: another-forget-accessors-test"
519 "another-forget-accessors-test" parse-stream
522 [ t ] [ \ another-forget-accessors-test class? ] unit-test
528 "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval
529 ] with-string-writer empty?
533 ! Missing error check
534 [ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
536 ! Class forget messyness
537 TUPLE: subclass-forget-test ;
539 TUPLE: subclass-forget-test-1 < subclass-forget-test ;
540 TUPLE: subclass-forget-test-2 < subclass-forget-test ;
541 TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
543 [ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
545 [ { subclass-forget-test-2 } ]
546 [ subclass-forget-test-2 class-usages ]
549 [ { subclass-forget-test-3 } ]
550 [ subclass-forget-test-3 class-usages ]
553 [ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
554 [ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
555 [ subclass-forget-test-3 new ] must-fail
557 [ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval ] must-fail
560 DEFER: subclass-reset-test
561 DEFER: subclass-reset-test-1
562 DEFER: subclass-reset-test-2
563 DEFER: subclass-reset-test-3
565 GENERIC: break-me ( obj -- )
567 [ ] [ [ { integer break-me } forget ] with-compilation-unit ] unit-test
569 [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
570 [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval ] unit-test
571 [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval ] unit-test
572 [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval ] unit-test
574 [ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval ] unit-test
576 [ ] [ "IN: classes.tuple.tests : subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
578 [ f ] [ subclass-reset-test-1 tuple-class? ] unit-test
579 [ f ] [ subclass-reset-test-2 tuple-class? ] unit-test
580 [ subclass-forget-test-3 new ] must-fail
582 [ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
584 [ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test
586 [ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
588 ! Insufficient type checking
589 [ \ vocab tuple>array drop ] must-fail
591 ! Check type declarations
592 TUPLE: declared-types { n fixnum } { m string } ;
594 [ T{ declared-types f 0 "hi" } ]
595 [ { declared-types 0 "hi" } >tuple ]
598 [ { declared-types "hi" 0 } >tuple ]
599 [ T{ bad-slot-value f "hi" fixnum } = ]
602 [ T{ declared-types f 0 "hi" } ]
603 [ 0.0 "hi" declared-types boa ] unit-test
605 : foo ( a b -- c ) declared-types boa ;
609 [ T{ declared-types f 0 "hi" } ] [ 0.0 "hi" foo ] unit-test
611 [ "hi" 0.0 declared-types boa ]
612 [ T{ no-method f "hi" >fixnum } = ]
615 [ 0 { } declared-types boa ]
616 [ T{ bad-slot-value f { } string } = ]
620 [ T{ no-method f "hi" >fixnum } = ]
624 [ T{ bad-slot-value f { } string } = ]
627 [ T{ declared-types f 0 "" } ] [ declared-types new ] unit-test
629 : blah ( -- vec ) vector new ;
633 [ V{ } ] [ blah ] unit-test
635 ! Test reshaping with type declarations and slot attributes
636 TUPLE: reshape-test x ;
638 T{ reshape-test f "hi" } "tuple" set
640 [ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval ] unit-test
642 [ f ] [ \ reshape-test \ (>>x) method ] unit-test
644 [ "tuple" get 5 >>x ] must-fail
646 [ "hi" ] [ "tuple" get x>> ] unit-test
648 [ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval ] unit-test
650 [ 0 ] [ "tuple" get x>> ] unit-test
652 [ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval ] unit-test
654 [ 0 ] [ "tuple" get x>> ] unit-test
656 TUPLE: boa-coercer-test { x array-capacity } ;
658 [ fixnum ] [ 0 >bignum boa-coercer-test boa x>> class ] unit-test
660 [ T{ boa-coercer-test f 0 } ] [ T{ boa-coercer-test } ] unit-test
663 ERROR: error-class-test a b c ;
665 [ "( a b c -- * )" ] [ \ error-class-test stack-effect effect>string ] unit-test
666 [ f ] [ \ error-class-test "inline" word-prop ] unit-test
668 [ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval ]
669 [ error>> error>> redefine-error? ] must-fail-with
673 [ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test
675 [ ] [ "IN: classes.tuple.tests GENERIC: error-y" eval ] unit-test
677 [ f ] [ \ error-y tuple-class? ] unit-test
679 [ t ] [ \ error-y generic? ] unit-test
681 [ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval ] unit-test
683 [ t ] [ \ error-y tuple-class? ] unit-test
685 [ f ] [ \ error-y generic? ] unit-test
688 "IN: classes.tuple.tests TUPLE: forget-subclass-test ; TUPLE: forget-subclass-test' < forget-subclass-test ;"
689 <string-reader> "forget-subclass-test" parse-stream
693 [ ] [ "forget-subclass-test'" "classes.tuple.tests" lookup new "bad-object" set ] unit-test
696 "IN: classes.tuple.tests TUPLE: forget-subclass-test a ;"
697 <string-reader> "forget-subclass-test" parse-stream
702 "IN: sequences TUPLE: reversed { seq read-only } ;" eval
705 TUPLE: bogus-hashcode-1 x ;
707 TUPLE: bogus-hashcode-2 x ;
709 M: bogus-hashcode-1 hashcode* 2drop 0 >bignum ;
711 [ ] [ T{ bogus-hashcode-2 f T{ bogus-hashcode-1 } } hashcode drop ] unit-test