: move ( x rect -- rect )
[ + ] change-x ;
-[ f ] [ 10 20 30 40 <rect> dup clone 5 swap move = ] unit-test
+{ f } [ 10 20 30 40 <rect> dup clone 5 swap move = ] unit-test
-[ t ] [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
+{ t } [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
! Make sure we handle tuple class redefinition
TUPLE: redefinition-test ;
<redefinition-test> "redefinition-test" set
-[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
+{ t } [ "redefinition-test" get redefinition-test? ] unit-test
"IN: classes.tuple.tests TUPLE: redefinition-test ;" eval( -- )
-[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
+{ t } [ "redefinition-test" get redefinition-test? ] unit-test
! Make sure we handle changing shapes!
TUPLE: point x y ;
-[ ] [ 100 200 point boa "p" set ] unit-test
+{ } [ 100 200 point boa "p" set ] unit-test
! Use eval to sequence parsing explicitly
-[ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval( -- ) ] unit-test
-[ 100 ] [ "p" get x>> ] unit-test
-[ 200 ] [ "p" get y>> ] unit-test
-[ f ] [ "p" get "z>>" "accessors" lookup-word execute ] unit-test
+{ 100 } [ "p" get x>> ] unit-test
+{ 200 } [ "p" get y>> ] unit-test
+{ f } [ "p" get "z>>" "accessors" lookup-word execute ] unit-test
-[ ] [ "p" get 300 ">>z" "accessors" lookup-word execute drop ] unit-test
+{ } [ "p" get 300 ">>z" "accessors" lookup-word execute drop ] unit-test
-[ 3 ] [ "p" get tuple-size ] unit-test
+{ 3 } [ "p" get tuple-size ] unit-test
-[ 300 ] [ "p" get "z>>" "accessors" lookup-word execute ] unit-test
+{ 300 } [ "p" get "z>>" "accessors" lookup-word execute ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: point z y ;" eval( -- ) ] unit-test
-[ 2 ] [ "p" get tuple-size ] unit-test
+{ 2 } [ "p" get tuple-size ] unit-test
[ "p" get x>> ] must-fail
-[ 200 ] [ "p" get y>> ] unit-test
-[ 300 ] [ "p" get "z>>" "accessors" lookup-word execute ] unit-test
+{ 200 } [ "p" get y>> ] unit-test
+{ 300 } [ "p" get "z>>" "accessors" lookup-word execute ] unit-test
TUPLE: slotty a b c ;
-[ T{ slotty } ] [ H{ } slotty from-slots ] unit-test
-[ T{ slotty f 1 2 f } ] [ H{ { "a" 1 } { "b" 2 } } slotty from-slots ] unit-test
+{ T{ slotty } } [ H{ } slotty from-slots ] unit-test
+{ T{ slotty f 1 2 f } } [ H{ { "a" 1 } { "b" 2 } } slotty from-slots ] unit-test
[ H{ { "d" 0 } } slotty new set-slots ] must-fail
TUPLE: predicate-test ;
: predicate-test ( a -- ? ) drop f ;
-
[ t ] [ <predicate-test> predicate-test? ] unit-test
+
{ t } [ <predicate-test> predicate-test? ] unit-test
PREDICATE: silly-pred < tuple
class-of \ rect = ;
TUPLE: circle radius ;
M: circle area radius>> sq pi * ;
-[ 200 ] [ T{ rect f 0 0 10 20 } area ] unit-test
+{ 200 } [ T{ rect f 0 0 10 20 } area ] unit-test
! Hashcode breakage
TUPLE: empty ;
C: <empty> empty
-[ t ] [ <empty> hashcode fixnum? ] unit-test
+{ t } [ <empty> hashcode fixnum? ] unit-test
! Compiler regression
[ t length ] [ object>> t eq? ] must-fail-with
-[ "<constructor-test>" ]
+{ "<constructor-test>" }
[ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval( -- ) last-word name>> ] unit-test
TUPLE: size-test a b c d ;
-[ t ] [
+{ t } [
T{ size-test } tuple-size
size-test tuple-layout second =
] unit-test
TUPLE: yo-momma ;
-[ ] [ "IN: classes.tuple.tests C: <yo-momma> yo-momma" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests C: <yo-momma> yo-momma" eval( -- ) ] unit-test
-[ f ] [ \ <yo-momma> generic? ] unit-test
+{ f } [ \ <yo-momma> generic? ] unit-test
! Test forget
[
TUPLE: loc-recording ;
-[ f ] [ \ loc-recording where not ] unit-test
+{ f } [ \ loc-recording where not ] unit-test
! 'forget' wasn't robust enough
C: <t4> t4
-[ 1 ] [ 1 <t4> m1 ] unit-test
-[ 1 ] [ <t4> 1 m2 ] unit-test
+{ 1 } [ 1 <t4> m1 ] unit-test
+{ 1 } [ <t4> 1 m2 ] unit-test
! another combination issue
GENERIC: silly ( obj -- obj obj )
M: vector silly "z" ;
-[ "zz" ] [ 123 <reversed> silly nip ] unit-test
+{ "zz" } [ 123 <reversed> silly nip ] unit-test
! Typo
SYMBOL: not-a-tuple-class
TUPLE: computer cpu ram ;
C: <computer> computer
-[ "TUPLE: computer cpu ram ;" ] [
+{ "TUPLE: computer cpu ram ;" } [
[ \ computer see ] with-string-writer string-lines second
] unit-test
TUPLE: laptop < computer battery ;
C: <laptop> laptop
-[ t ] [ laptop tuple-class? ] unit-test
-[ t ] [ laptop tuple class<= ] unit-test
-[ t ] [ laptop computer class<= ] unit-test
-[ t ] [ laptop computer classes-intersect? ] unit-test
+{ t } [ laptop tuple-class? ] unit-test
+{ t } [ laptop tuple class<= ] unit-test
+{ t } [ laptop computer class<= ] unit-test
+{ t } [ laptop computer classes-intersect? ] unit-test
-[ ] [ "Pentium" 128 3 hours <laptop> "laptop" set ] unit-test
-[ t ] [ "laptop" get laptop? ] unit-test
-[ t ] [ "laptop" get computer? ] unit-test
-[ t ] [ "laptop" get tuple? ] unit-test
+{ } [ "Pentium" 128 3 hours <laptop> "laptop" set ] unit-test
+{ t } [ "laptop" get laptop? ] unit-test
+{ t } [ "laptop" get computer? ] unit-test
+{ t } [ "laptop" get tuple? ] unit-test
: test-laptop-slot-values ( -- )
[ laptop ] [ "laptop" get class-of ] unit-test
test-laptop-slot-values
-[ "TUPLE: laptop < computer battery ;" ] [
+{ "TUPLE: laptop < computer battery ;" } [
[ \ laptop see ] with-string-writer string-lines second
] unit-test
-[ { tuple computer laptop } ] [ laptop superclasses ] unit-test
+{ { tuple computer laptop } } [ laptop superclasses ] unit-test
TUPLE: server < computer rackmount ;
C: <server> server
-[ t ] [ server tuple-class? ] unit-test
-[ t ] [ server tuple class<= ] unit-test
-[ t ] [ server computer class<= ] unit-test
-[ t ] [ server computer classes-intersect? ] unit-test
+{ t } [ server tuple-class? ] unit-test
+{ t } [ server tuple class<= ] unit-test
+{ t } [ server computer class<= ] unit-test
+{ t } [ server computer classes-intersect? ] unit-test
-[ ] [ "PowerPC" 64 "1U" <server> "server" set ] unit-test
-[ t ] [ "server" get server? ] unit-test
-[ t ] [ "server" get computer? ] unit-test
-[ t ] [ "server" get tuple? ] unit-test
+{ } [ "PowerPC" 64 "1U" <server> "server" set ] unit-test
+{ t } [ "server" get server? ] unit-test
+{ t } [ "server" get computer? ] unit-test
+{ t } [ "server" get tuple? ] unit-test
: test-server-slot-values ( -- )
[ server ] [ "server" get class-of ] unit-test
test-server-slot-values
-[ f ] [ "server" get laptop? ] unit-test
-[ f ] [ "laptop" get server? ] unit-test
+{ f } [ "server" get laptop? ] unit-test
+{ f } [ "laptop" get server? ] unit-test
-[ f ] [ server laptop class<= ] unit-test
-[ f ] [ laptop server class<= ] unit-test
-[ f ] [ laptop server classes-intersect? ] unit-test
+{ f } [ server laptop class<= ] unit-test
+{ f } [ laptop server class<= ] unit-test
+{ f } [ laptop server classes-intersect? ] unit-test
-[ f ] [ 1 2 <computer> laptop? ] unit-test
-[ f ] [ \ + server? ] unit-test
+{ f } [ 1 2 <computer> laptop? ] unit-test
+{ f } [ \ + server? ] unit-test
-[ "TUPLE: server < computer rackmount ;" ] [
+{ "TUPLE: server < computer rackmount ;" } [
[ \ server see ] with-string-writer string-lines second
] unit-test
: computer?' ( a -- b ) computer? ;
-[ t ] [ laptop new computer?' ] unit-test
+{ t } [ laptop new computer?' ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
-[ t ] [ laptop new computer?' ] unit-test
+{ t } [ laptop new computer?' ] unit-test
-[ f ] [ electronic-device laptop class<= ] unit-test
-[ t ] [ server electronic-device class<= ] unit-test
-[ t ] [ laptop server class-or electronic-device class<= ] unit-test
+{ f } [ electronic-device laptop class<= ] unit-test
+{ t } [ server electronic-device class<= ] unit-test
+{ t } [ laptop server class-or electronic-device class<= ] unit-test
-[ t ] [ "laptop" get electronic-device? ] unit-test
-[ t ] [ "laptop" get computer? ] unit-test
-[ t ] [ "laptop" get laptop? ] unit-test
-[ f ] [ "laptop" get server? ] unit-test
+{ t } [ "laptop" get electronic-device? ] unit-test
+{ t } [ "laptop" get computer? ] unit-test
+{ t } [ "laptop" get laptop? ] unit-test
+{ f } [ "laptop" get server? ] unit-test
-[ t ] [ "server" get electronic-device? ] unit-test
-[ t ] [ "server" get computer? ] unit-test
-[ f ] [ "server" get laptop? ] unit-test
-[ t ] [ "server" get server? ] unit-test
+{ t } [ "server" get electronic-device? ] unit-test
+{ t } [ "server" get computer? ] unit-test
+{ f } [ "server" get laptop? ] unit-test
+{ t } [ "server" get server? ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: computer cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
-[ f ] [ "laptop" get electronic-device? ] unit-test
-[ t ] [ "laptop" get computer? ] unit-test
+{ f } [ "laptop" get electronic-device? ] unit-test
+{ t } [ "laptop" get computer? ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
-[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
TUPLE: make-me-some-accessors voltage grounded? ;
-[ f ] [ "laptop" get voltage>> ] unit-test
-[ f ] [ "server" get voltage>> ] unit-test
+{ f } [ "laptop" get voltage>> ] unit-test
+{ f } [ "server" get voltage>> ] unit-test
-[ ] [ "laptop" get 220 >>voltage drop ] unit-test
-[ ] [ "server" get 110 >>voltage drop ] unit-test
+{ } [ "laptop" get 220 >>voltage drop ] unit-test
+{ } [ "server" get 110 >>voltage drop ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ; C: <computer> computer" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ; C: <computer> computer" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
-[ 220 ] [ "laptop" get voltage>> ] unit-test
-[ 110 ] [ "server" get voltage>> ] unit-test
+{ 220 } [ "laptop" get voltage>> ] unit-test
+{ 110 } [ "server" get voltage>> ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
-[ 220 ] [ "laptop" get voltage>> ] unit-test
-[ 110 ] [ "server" get voltage>> ] unit-test
+{ 220 } [ "laptop" get voltage>> ] unit-test
+{ 110 } [ "server" get voltage>> ] unit-test
! Reshaping superclass and subclass simultaneously
-[ ] [ "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
+{ } [ "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
test-laptop-slot-values
test-server-slot-values
-[ 220 ] [ "laptop" get voltage>> ] unit-test
-[ 110 ] [ "server" get voltage>> ] unit-test
+{ 220 } [ "laptop" get voltage>> ] unit-test
+{ 110 } [ "server" get voltage>> ] unit-test
! Reshape crash
TUPLE: test1 a ; TUPLE: test2 < test1 b ;
test-a/b
-[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval( -- ) ] unit-test
test-a/b
-[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval( -- ) ] unit-test
test-a/b
test-move-up
-[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval( -- ) ] unit-test
test-move-up
-[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval( -- ) ] unit-test
test-move-up
-[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval( -- ) ] unit-test
test-move-up
-[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval( -- ) ] unit-test
! Constructors must be recompiled when changing superclass
TUPLE: constructor-update-1 xxx ;
{ 3 1 } [ <constructor-update-2> ] must-infer-as
-[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval( -- ) ] unit-test
{ 3 1 } [ <constructor-update-2> ] must-infer-as
[ 1 2 3 4 5 <constructor-update-2> ] [ not-compiled? ] must-fail-with
-[ ] [ [ \ <constructor-update-2> forget ] with-compilation-unit ] unit-test
+{ } [ [ \ <constructor-update-2> forget ] with-compilation-unit ] unit-test
! Redefinition problem
TUPLE: redefinition-problem ;
UNION: redefinition-problem' redefinition-problem integer ;
-[ t ] [ 3 redefinition-problem'? ] unit-test
+{ t } [ 3 redefinition-problem'? ] unit-test
TUPLE: redefinition-problem-2 ;
"IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" eval( -- )
-[ t ] [ 3 redefinition-problem'? ] unit-test
+{ t } [ 3 redefinition-problem'? ] unit-test
! Hardcore unit tests
\ thread "slots" word-prop "slots" set
-[ ] [
+{ } [
[
\ thread tuple { "xxx" } "slots" get append
define-tuple-class
\ vocab "slots" word-prop "slots" set
-[ ] [
+{ } [
[
\ vocab identity-tuple { "xxx" } "slots" get append
define-tuple-class
must-fail-with
! Accessors not being forgotten...
-[ [ ] ] [
+{ [ ] } [
"IN: classes.tuple.tests TUPLE: forget-accessors-test x y z ;"
<string-reader>
"forget-accessors-test" parse-stream
] unit-test
-[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup-word class? ] unit-test
+{ t } [ "forget-accessors-test" "classes.tuple.tests" lookup-word class? ] unit-test
: accessor-exists? ( name -- ? )
[ "forget-accessors-test" "classes.tuple.tests" lookup-word ] dip
">>" append "accessors" lookup-word ?lookup-method >boolean ;
-[ t ] [ "x" accessor-exists? ] unit-test
-[ t ] [ "y" accessor-exists? ] unit-test
-[ t ] [ "z" accessor-exists? ] unit-test
+{ t } [ "x" accessor-exists? ] unit-test
+{ t } [ "y" accessor-exists? ] unit-test
+{ t } [ "z" accessor-exists? ] unit-test
-[ [ ] ] [
+{ [ ] } [
"IN: classes.tuple.tests GENERIC: forget-accessors-test ( a -- b )"
<string-reader>
"forget-accessors-test" parse-stream
] unit-test
-[ f ] [ "forget-accessors-test" "classes.tuple.tests" lookup-word class? ] unit-test
+{ f } [ "forget-accessors-test" "classes.tuple.tests" lookup-word class? ] unit-test
-[ f ] [ "x" accessor-exists? ] unit-test
-[ f ] [ "y" accessor-exists? ] unit-test
-[ f ] [ "z" accessor-exists? ] unit-test
+{ f } [ "x" accessor-exists? ] unit-test
+{ f } [ "y" accessor-exists? ] unit-test
+{ f } [ "z" accessor-exists? ] unit-test
TUPLE: another-forget-accessors-test ;
-[ [ ] ] [
+{ [ ] } [
"IN: classes.tuple.tests GENERIC: another-forget-accessors-test ( a -- b )"
<string-reader>
"another-forget-accessors-test" parse-stream
] unit-test
-[ t ] [ \ another-forget-accessors-test class? ] unit-test
+{ t } [ \ another-forget-accessors-test class? ] unit-test
! Shadowing test
-[ f ] [
+{ f } [
f parser-quiet? [
[
"IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval( -- )
! Check type declarations
TUPLE: declared-types { n fixnum } { m string } ;
-[ T{ declared-types f 0 "hi" } ]
+{ T{ declared-types f 0 "hi" } }
[ { declared-types 0 "hi" } >tuple ]
unit-test
[ declared-types new 0.0 >>n n>> ] [ T{ no-method f 0.0 integer>fixnum-strict } = ] must-fail-with
-[ T{ declared-types f 33333 "asdf" } ]
+{ T{ declared-types f 33333 "asdf" } }
[ 33333 >bignum "asdf" declared-types boa ] unit-test
[ 444444444444444444444444444444444444444444444444433333 >bignum "asdf" declared-types boa ]
! Check bignum coercer
TUPLE: bignum-coercer { n bignum initial: $[ 0 >bignum ] } ;
-[ 13 bignum ] [ 13.5 bignum-coercer boa n>> dup class-of ] unit-test
+{ 13 bignum } [ 13.5 bignum-coercer boa n>> dup class-of ] unit-test
-[ 13 bignum ] [ bignum-coercer new 13.5 >>n n>> dup class-of ] unit-test
+{ 13 bignum } [ bignum-coercer new 13.5 >>n n>> dup class-of ] unit-test
! Check float coercer
TUPLE: float-coercer { n float } ;
-[ 13.0 float ] [ 13 float-coercer boa n>> dup class-of ] unit-test
+{ 13.0 float } [ 13 float-coercer boa n>> dup class-of ] unit-test
-[ 13.0 float ] [ float-coercer new 13 >>n n>> dup class-of ] unit-test
+{ 13.0 float } [ float-coercer new 13 >>n n>> dup class-of ] unit-test
! Check integer coercer
TUPLE: integer-coercer { n integer } ;
[ T{ bad-slot-value f { } string } = ]
must-fail-with
-[ T{ declared-types f 0 "" } ] [ declared-types new ] unit-test
+{ T{ declared-types f 0 "" } } [ declared-types new ] unit-test
: blah ( -- vec ) vector new ;
[ vector new ] must-infer
-[ V{ } ] [ blah ] unit-test
+{ V{ } } [ blah ] unit-test
! Test reshaping with type declarations and slot attributes
TUPLE: reshape-test x ;
T{ reshape-test f "hi" } "tuple" set
-[ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval( -- ) ] unit-test
-[ f ] [ \ reshape-test \ x<< ?lookup-method ] unit-test
+{ f } [ \ reshape-test \ x<< ?lookup-method ] unit-test
[ "tuple" get 5 >>x ] must-fail
-[ "hi" ] [ "tuple" get x>> ] unit-test
+{ "hi" } [ "tuple" get x>> ] unit-test
-[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval( -- ) ] unit-test
-[ 0 ] [ "tuple" get x>> ] unit-test
+{ 0 } [ "tuple" get x>> ] unit-test
-[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval( -- ) ] unit-test
-[ 0 ] [ "tuple" get x>> ] unit-test
+{ 0 } [ "tuple" get x>> ] unit-test
TUPLE: boa-coercer-test { x array-capacity } ;
-[ fixnum ] [ 0 >bignum boa-coercer-test boa x>> class-of ] unit-test
+{ fixnum } [ 0 >bignum boa-coercer-test boa x>> class-of ] unit-test
-[ T{ boa-coercer-test f 0 } ] [ T{ boa-coercer-test } ] unit-test
+{ T{ boa-coercer-test f 0 } } [ T{ boa-coercer-test } ] unit-test
! Test error classes
ERROR: error-class-test a b c ;
-[ "( a b c -- * )" ] [ \ error-class-test stack-effect effect>string ] unit-test
-[ f ] [ \ error-class-test "inline" word-prop ] unit-test
+{ "( a b c -- * )" } [ \ error-class-test stack-effect effect>string ] unit-test
+{ f } [ \ error-class-test "inline" word-prop ] unit-test
[ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval( -- ) ]
[ error>> error>> redefine-error? ] must-fail-with
DEFER: error-y
-[ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test
+{ } [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test
-[ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval( -- ) ] unit-test
-[ f ] [ \ error-y tuple-class? ] unit-test
+{ f } [ \ error-y tuple-class? ] unit-test
-[ f ] [ \ error-y error-class? ] unit-test
+{ f } [ \ error-y error-class? ] unit-test
-[ t ] [ \ error-y generic? ] unit-test
+{ t } [ \ error-y generic? ] unit-test
-[ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests ERROR: error-y ;" eval( -- ) ] unit-test
-[ t ] [ \ error-y tuple-class? ] unit-test
+{ t } [ \ error-y tuple-class? ] unit-test
-[ t ] [ \ error-y error-class? ] unit-test
+{ t } [ \ error-y error-class? ] unit-test
-[ f ] [ \ error-y generic? ] unit-test
+{ f } [ \ error-y generic? ] unit-test
-[ ] [
+{ } [
"IN: classes.tuple.tests TUPLE: forget-subclass-test ; TUPLE: forget-subclass-test' < forget-subclass-test ;"
<string-reader> "forget-subclass-test" parse-stream
drop
] unit-test
-[ ] [ "forget-subclass-test'" "classes.tuple.tests" lookup-word new "bad-object" set ] unit-test
+{ } [ "forget-subclass-test'" "classes.tuple.tests" lookup-word new "bad-object" set ] unit-test
-[ ] [
+{ } [
"IN: classes.tuple.tests TUPLE: forget-subclass-test a ;"
<string-reader> "forget-subclass-test" parse-stream
drop
] unit-test
-[ ] [
+{ } [
"IN: sequences TUPLE: reversed { seq read-only } ;" eval( -- )
] unit-test
M: bogus-hashcode-1 hashcode* 2drop 0 >bignum ;
-[ ] [ T{ bogus-hashcode-2 f T{ bogus-hashcode-1 } } hashcode drop ] unit-test
+{ } [ T{ bogus-hashcode-2 f T{ bogus-hashcode-1 } } hashcode drop ] unit-test
DEFER: change-slot-test
SLOT: kex
-[ ] [
+{ } [
"IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; SLOT: kex M: change-slot-test kex>> drop 3 ;"
<string-reader> "change-slot-test" parse-stream
drop
] unit-test
-[ t ] [ \ change-slot-test \ kex>> ?lookup-method >boolean ] unit-test
+{ t } [ \ change-slot-test \ kex>> ?lookup-method >boolean ] unit-test
-[ ] [
+{ } [
"IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test kex ;"
<string-reader> "change-slot-test" parse-stream
drop
] unit-test
-[ t ] [ \ change-slot-test \ kex>> ?lookup-method >boolean ] unit-test
+{ t } [ \ change-slot-test \ kex>> ?lookup-method >boolean ] unit-test
-[ ] [
+{ } [
"IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; SLOT: kex M: change-slot-test kex>> drop 3 ;"
<string-reader> "change-slot-test" parse-stream
drop
] unit-test
-[ t ] [ \ change-slot-test \ kex>> ?lookup-method >boolean ] unit-test
-[ f ] [ \ change-slot-test \ kex>> ?lookup-method "reading" word-prop ] unit-test
+{ t } [ \ change-slot-test \ kex>> ?lookup-method >boolean ] unit-test
+{ f } [ \ change-slot-test \ kex>> ?lookup-method "reading" word-prop ] unit-test
DEFER: redefine-tuple-twice
-[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
-[ t ] [ \ redefine-tuple-twice symbol? ] unit-test
+{ t } [ \ redefine-tuple-twice symbol? ] unit-test
-[ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval( -- ) ] unit-test
-[ t ] [ \ redefine-tuple-twice deferred? ] unit-test
+{ t } [ \ redefine-tuple-twice deferred? ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
-[ t ] [ \ redefine-tuple-twice symbol? ] unit-test
+{ t } [ \ redefine-tuple-twice symbol? ] unit-test
ERROR: base-error x y ;
ERROR: derived-error < base-error z ;
-[ ( x y z -- * ) ] [ \ derived-error stack-effect ] unit-test
+{ ( x y z -- * ) } [ \ derived-error stack-effect ] unit-test
! Make sure that tuple reshaping updates code heap roots
TUPLE: code-heap-ref ;
: code-heap-ref' ( -- a ) T{ code-heap-ref } ;
! Push foo's literal to tenured space
-[ ] [ gc ] unit-test
+{ } [ gc ] unit-test
! Reshape!
-[ ] [ "IN: classes.tuple.tests USE: math TUPLE: code-heap-ref { x integer initial: 5 } ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests USE: math TUPLE: code-heap-ref { x integer initial: 5 } ;" eval( -- ) ] unit-test
! Code heap reference
-[ t ] [ code-heap-ref' code-heap-ref? ] unit-test
-[ 5 ] [ code-heap-ref' x>> ] unit-test
+{ t } [ code-heap-ref' code-heap-ref? ] unit-test
+{ 5 } [ code-heap-ref' x>> ] unit-test
! Data heap reference
-[ t ] [ \ code-heap-ref' def>> first code-heap-ref? ] unit-test
-[ 5 ] [ \ code-heap-ref' def>> first x>> ] unit-test
+{ t } [ \ code-heap-ref' def>> first code-heap-ref? ] unit-test
+{ 5 } [ \ code-heap-ref' def>> first x>> ] unit-test
! If the metaclass of a superclass changes into something other
! than a tuple class, the tuple needs to have its superclass reset
TUPLE: metaclass-change ;
TUPLE: metaclass-change-subclass < metaclass-change ;
-[ metaclass-change ] [ metaclass-change-subclass superclass ] unit-test
+{ metaclass-change } [ metaclass-change-subclass superclass ] unit-test
-[ ] [ "IN: classes.tuple.tests MIXIN: metaclass-change" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests MIXIN: metaclass-change" eval( -- ) ] unit-test
-[ t ] [ metaclass-change-subclass tuple-class? ] unit-test
-[ tuple ] [ metaclass-change-subclass superclass ] unit-test
+{ t } [ metaclass-change-subclass tuple-class? ] unit-test
+{ tuple } [ metaclass-change-subclass superclass ] unit-test
! Reshaping bug related to the above
TUPLE: a-g ;
TUPLE: g < a-g ;
-[ ] [ g new "g" set ] unit-test
+{ } [ g new "g" set ] unit-test
-[ ] [ "IN: classes.tuple.tests MIXIN: a-g TUPLE: g ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests MIXIN: a-g TUPLE: g ;" eval( -- ) ] unit-test
-[ t ] [ g new layout-of "g" get layout-of eq? ] unit-test
+{ t } [ g new layout-of "g" get layout-of eq? ] unit-test
! Joe Groff discovered this bug
DEFER: factor-crashes-anymore
-[ ] [
+{ } [
"IN: classes.tuple.tests
TUPLE: unsafe-slot-access ;
CONSTANT: unsafe-slot-access' T{ unsafe-slot-access }" eval( -- )
] unit-test
-[ ] [
+{ } [
"IN: classes.tuple.tests
USE: accessors
TUPLE: unsafe-slot-access { x read-only initial: 31337 } ;
: factor-crashes-anymore ( -- x ) unsafe-slot-access' x>> ;" eval( -- )
] unit-test
-[ 31337 ] [ factor-crashes-anymore ] unit-test
+{ 31337 } [ factor-crashes-anymore ] unit-test
TUPLE: tuple-predicate-redefine-test ;
-[ ] [ "IN: classes.tuple.tests TUPLE: tuple-predicate-redefine-test ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: tuple-predicate-redefine-test ;" eval( -- ) ] unit-test
-[ t ] [ \ tuple-predicate-redefine-test? predicate? ] unit-test
+{ t } [ \ tuple-predicate-redefine-test? predicate? ] unit-test
! Final classes
TUPLE: final-superclass ;
TUPLE: final-subclass < final-superclass ;
-[ final-superclass ] [ final-subclass superclass ] unit-test
+{ final-superclass } [ final-subclass superclass ] unit-test
! Making the superclass final should change the superclass of the subclass
-[ ] [ "IN: classes.tuple.tests TUPLE: final-superclass ; final" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: final-superclass ; final" eval( -- ) ] unit-test
-[ tuple ] [ final-subclass superclass ] unit-test
+{ tuple } [ final-subclass superclass ] unit-test
-[ f ] [ \ final-subclass final-class? ] unit-test
+{ f } [ \ final-subclass final-class? ] unit-test
! Subclassing a final class should fail
[ "IN: classes.tuple.tests TUPLE: final-subclass < final-superclass ;" eval( -- ) ]
[ error>> bad-superclass? ] must-fail-with
! Making a final class non-final should work
-[ ] [ "IN: classes.tuple.tests TUPLE: final-superclass ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: final-superclass ;" eval( -- ) ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: final-subclass < final-superclass ; final" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: final-subclass < final-superclass ; final" eval( -- ) ] unit-test
! Changing a superclass should not change the final status of a subclass
-[ ] [ "IN: classes.tuple.tests TUPLE: final-superclass x ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: final-superclass x ;" eval( -- ) ] unit-test
-[ t ] [ \ final-subclass final-class? ] unit-test
+{ t } [ \ final-subclass final-class? ] unit-test
! Test reset-class on tuples
! Should forget all accessors on rclasstest
TUPLE: rclasstest a b ;
-[ ] [ [ \ rclasstest reset-class ] with-compilation-unit ] unit-test
-[ f ] [ \ rclasstest \ a>> ?lookup-method ] unit-test
-[ f ] [ \ rclasstest \ a<< ?lookup-method ] unit-test
-[ f ] [ \ rclasstest \ b>> ?lookup-method ] unit-test
-[ f ] [ \ rclasstest \ b<< ?lookup-method ] unit-test
+{ } [ [ \ rclasstest reset-class ] with-compilation-unit ] unit-test
+{ f } [ \ rclasstest \ a>> ?lookup-method ] unit-test
+{ f } [ \ rclasstest \ a<< ?lookup-method ] unit-test
+{ f } [ \ rclasstest \ b>> ?lookup-method ] unit-test
+{ f } [ \ rclasstest \ b<< ?lookup-method ] unit-test
<< \ rclasstest forget >>
DEFER: initial-slot
-[ ] [ "IN: classes.tuple.tests TUPLE: initial-slot { x initial-class } ;" eval( -- ) ] unit-test
+{ } [ "IN: classes.tuple.tests TUPLE: initial-slot { x initial-class } ;" eval( -- ) ] unit-test
-[ t ] [ initial-slot new x>> initial-class? ] unit-test
+{ t } [ initial-slot new x>> initial-class? ] unit-test
[ "IN: classes.tuple.tests TUPLE: initial-slot { x initial-class initial: f } ;" eval( -- ) ]
[ error>> T{ bad-initial-value f "x" f initial-class } = ] must-fail-with
projects / factor.git / blobdiff