fixing compiler error in core
Doug Coleman
parent
e85d8c17ac
commit
aad6a3d504
|
|
@ -29,10 +29,10 @@ M: method-forget-class method-forget-test ;
|
|||
] unit-test
|
||||
|
||||
! Minor leak
|
||||
[ ] [ "IN: classes.tests TUPLE: forget-me ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tests TUPLE: forget-me ;" (( -- )) eval ] unit-test
|
||||
[ ] [ f \ word set-global ] unit-test
|
||||
[ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" eval ] unit-test
|
||||
[ ] [ "IN: classes.tests FORGET: forget-me" eval ] unit-test
|
||||
[ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" (( -- )) eval ] unit-test
|
||||
[ ] [ "IN: classes.tests FORGET: forget-me" (( -- )) eval ] unit-test
|
||||
[ 0 ] [
|
||||
[ word? ] instances
|
||||
[ [ name>> "forget-me" = ] [ vocabulary>> "classes.tests" = ] bi and ] count
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@ INSTANCE: integer mx1
|
|||
[ t ] [ mx1 integer class<= ] unit-test
|
||||
[ t ] [ mx1 number class<= ] unit-test
|
||||
|
||||
"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval
|
||||
"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" (( -- )) eval
|
||||
|
||||
[ t ] [ array mx1 class<= ] unit-test
|
||||
[ f ] [ mx1 number class<= ] unit-test
|
||||
|
|
@ -118,4 +118,4 @@ MIXIN: move-instance-declaration-mixin
|
|||
|
||||
[ ] [ "IN: classes.mixin.tests.a" <string-reader> "move-mixin-test-1" parse-stream drop ] unit-test
|
||||
|
||||
[ { string } ] [ move-instance-declaration-mixin members ] unit-test
|
||||
[ { string } ] [ move-instance-declaration-mixin members ] unit-test
|
||||
|
|
|
|||
|
|
@ -50,20 +50,20 @@ TUPLE: test-8 { b integer read-only } ;
|
|||
|
||||
DEFER: foo
|
||||
|
||||
[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ]
|
||||
[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" (( -- )) eval ]
|
||||
[ error>> invalid-slot-name? ]
|
||||
must-fail-with
|
||||
|
||||
[ "IN: classes.tuple.parser.tests TUPLE: foo :" eval ]
|
||||
[ "IN: classes.tuple.parser.tests TUPLE: foo :" (( -- )) eval ]
|
||||
[ error>> invalid-slot-name? ]
|
||||
must-fail-with
|
||||
|
||||
[ "IN: classes.tuple.parser.tests TUPLE: foo" eval ]
|
||||
[ "IN: classes.tuple.parser.tests TUPLE: foo" (( -- )) eval ]
|
||||
[ error>> unexpected-eof? ]
|
||||
must-fail-with
|
||||
|
||||
2 [
|
||||
[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ]
|
||||
[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" (( -- )) eval ]
|
||||
[ error>> no-initial-value? ]
|
||||
must-fail-with
|
||||
|
||||
|
|
@ -71,14 +71,14 @@ must-fail-with
|
|||
] times
|
||||
|
||||
2 [
|
||||
[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ]
|
||||
[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" (( -- )) eval ]
|
||||
[ error>> bad-initial-value? ]
|
||||
must-fail-with
|
||||
|
||||
[ f ] [ \ foo tuple-class? ] unit-test
|
||||
] times
|
||||
|
||||
[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" eval ]
|
||||
[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" (( -- )) eval ]
|
||||
[ error>> duplicate-slot-names? ]
|
||||
must-fail-with
|
||||
|
||||
|
|
@ -107,7 +107,7 @@ TUPLE: parsing-corner-case x ;
|
|||
" f"
|
||||
" 3"
|
||||
"}"
|
||||
} "\n" join eval
|
||||
} "\n" join (( -- tuple )) eval
|
||||
] unit-test
|
||||
|
||||
[ T{ parsing-corner-case f 3 } ] [
|
||||
|
|
@ -116,7 +116,7 @@ TUPLE: parsing-corner-case x ;
|
|||
"T{ parsing-corner-case"
|
||||
" { x 3 }"
|
||||
"}"
|
||||
} "\n" join eval
|
||||
} "\n" join (( -- tuple )) eval
|
||||
] unit-test
|
||||
|
||||
[ T{ parsing-corner-case f 3 } ] [
|
||||
|
|
@ -125,7 +125,7 @@ TUPLE: parsing-corner-case x ;
|
|||
"T{ parsing-corner-case {"
|
||||
" x 3 }"
|
||||
"}"
|
||||
} "\n" join eval
|
||||
} "\n" join (( -- tuple )) eval
|
||||
] unit-test
|
||||
|
||||
|
||||
|
|
@ -133,12 +133,12 @@ TUPLE: parsing-corner-case x ;
|
|||
{
|
||||
"USE: classes.tuple.parser.tests T{ parsing-corner-case"
|
||||
" { x 3 }"
|
||||
} "\n" join eval
|
||||
} "\n" join (( -- tuple )) eval
|
||||
] [ error>> unexpected-eof? ] must-fail-with
|
||||
|
||||
[
|
||||
{
|
||||
"USE: classes.tuple.parser.tests T{ parsing-corner-case {"
|
||||
" x 3 }"
|
||||
} "\n" join eval
|
||||
} "\n" join (( -- tuple )) eval
|
||||
] [ error>> unexpected-eof? ] must-fail-with
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ C: <redefinition-test> redefinition-test
|
|||
|
||||
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
|
||||
|
||||
"IN: classes.tuple.tests TUPLE: redefinition-test ;" eval
|
||||
"IN: classes.tuple.tests TUPLE: redefinition-test ;" (( -- )) eval
|
||||
|
||||
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
|
||||
|
||||
|
|
@ -39,7 +39,7 @@ C: <point> point
|
|||
[ ] [ 100 200 <point> "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
|
||||
|
|
@ -51,7 +51,7 @@ C: <point> point
|
|||
|
||||
[ 300 ] [ "p" get "z>>" "accessors" lookup 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
|
||||
|
||||
|
|
@ -89,7 +89,7 @@ C: <empty> empty
|
|||
[ t length ] [ object>> t eq? ] must-fail-with
|
||||
|
||||
[ "<constructor-test>" ]
|
||||
[ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word name>> ] unit-test
|
||||
[ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" (( -- )) eval word name>> ] unit-test
|
||||
|
||||
TUPLE: size-test a b c d ;
|
||||
|
||||
|
|
@ -102,7 +102,7 @@ GENERIC: <yo-momma> ( a -- b )
|
|||
|
||||
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
|
||||
|
||||
|
|
@ -204,7 +204,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
|
|||
: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ;
|
||||
: cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ;
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" (( -- )) eval ] unit-test
|
||||
|
||||
[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
|
||||
|
||||
|
|
@ -281,13 +281,13 @@ test-server-slot-values
|
|||
] unit-test
|
||||
|
||||
[
|
||||
"IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval
|
||||
"IN: classes.tuple.tests TUPLE: bad-superclass < word ;" (( -- )) eval
|
||||
] must-fail
|
||||
|
||||
! Dynamically changing inheritance hierarchy
|
||||
TUPLE: electronic-device ;
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" (( -- )) eval ] unit-test
|
||||
|
||||
[ f ] [ electronic-device laptop class<= ] unit-test
|
||||
[ t ] [ server electronic-device class<= ] unit-test
|
||||
|
|
@ -303,17 +303,17 @@ TUPLE: electronic-device ;
|
|||
[ f ] [ "server" get laptop? ] unit-test
|
||||
[ t ] [ "server" get server? ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" (( -- )) eval ] 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 ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" (( -- )) eval ] unit-test
|
||||
|
||||
test-laptop-slot-values
|
||||
test-server-slot-values
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" (( -- )) eval ] unit-test
|
||||
|
||||
test-laptop-slot-values
|
||||
test-server-slot-values
|
||||
|
|
@ -326,7 +326,7 @@ TUPLE: make-me-some-accessors voltage grounded? ;
|
|||
[ ] [ "laptop" get 220 >>voltage drop ] unit-test
|
||||
[ ] [ "server" get 110 >>voltage drop ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" (( -- )) eval ] unit-test
|
||||
|
||||
test-laptop-slot-values
|
||||
test-server-slot-values
|
||||
|
|
@ -334,7 +334,7 @@ test-server-slot-values
|
|||
[ 220 ] [ "laptop" get voltage>> ] unit-test
|
||||
[ 110 ] [ "server" get voltage>> ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" (( -- )) eval ] unit-test
|
||||
|
||||
test-laptop-slot-values
|
||||
test-server-slot-values
|
||||
|
|
@ -343,7 +343,7 @@ test-server-slot-values
|
|||
[ 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 ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" (( -- )) eval ] unit-test
|
||||
|
||||
test-laptop-slot-values
|
||||
test-server-slot-values
|
||||
|
|
@ -364,11 +364,11 @@ C: <test2> test2
|
|||
|
||||
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
|
||||
|
||||
|
|
@ -393,19 +393,19 @@ T{ move-up-2 f "a" "b" "c" } "move-up" set
|
|||
|
||||
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 ;
|
||||
|
|
@ -416,7 +416,7 @@ C: <constructor-update-2> constructor-update-2
|
|||
|
||||
{ 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
|
||||
|
||||
{ 5 1 } [ <constructor-update-2> ] must-infer-as
|
||||
|
||||
|
|
@ -431,7 +431,7 @@ UNION: redefinition-problem' redefinition-problem integer ;
|
|||
|
||||
TUPLE: redefinition-problem-2 ;
|
||||
|
||||
"IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" eval
|
||||
"IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" (( -- )) eval
|
||||
|
||||
[ t ] [ 3 redefinition-problem'? ] unit-test
|
||||
|
||||
|
|
@ -472,7 +472,7 @@ USE: vocabs
|
|||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
[ "USE: words T{ word }" eval ]
|
||||
[ "USE: words T{ word }" (( -- )) eval ]
|
||||
[ error>> T{ no-method f word new } = ]
|
||||
must-fail-with
|
||||
|
||||
|
|
@ -485,7 +485,7 @@ must-fail-with
|
|||
|
||||
[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
|
||||
|
||||
: accessor-exists? ( class name -- ? )
|
||||
: accessor-exists? ( name -- ? )
|
||||
[ "forget-accessors-test" "classes.tuple.tests" lookup ] dip
|
||||
">>" append "accessors" lookup method >boolean ;
|
||||
|
||||
|
|
@ -520,13 +520,13 @@ TUPLE: another-forget-accessors-test ;
|
|||
[ f ] [
|
||||
t parser-notes? [
|
||||
[
|
||||
"IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval
|
||||
"IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" (( -- )) eval
|
||||
] with-string-writer empty?
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
! Missing error check
|
||||
[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
|
||||
[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" (( -- )) eval ] must-fail
|
||||
|
||||
! Class forget messyness
|
||||
TUPLE: subclass-forget-test ;
|
||||
|
|
@ -535,7 +535,7 @@ TUPLE: subclass-forget-test-1 < subclass-forget-test ;
|
|||
TUPLE: subclass-forget-test-2 < subclass-forget-test ;
|
||||
TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" (( -- )) eval ] unit-test
|
||||
|
||||
[ { subclass-forget-test-2 } ]
|
||||
[ subclass-forget-test-2 class-usages ]
|
||||
|
|
@ -549,7 +549,7 @@ unit-test
|
|||
[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
|
||||
[ subclass-forget-test-3 new ] must-fail
|
||||
|
||||
[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval ] must-fail
|
||||
[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" (( -- )) eval ] must-fail
|
||||
|
||||
! More
|
||||
DEFER: subclass-reset-test
|
||||
|
|
@ -562,11 +562,11 @@ GENERIC: break-me ( obj -- )
|
|||
[ ] [ [ M\ integer break-me forget ] with-compilation-unit ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" (( -- )) eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" (( -- )) eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" (( -- )) eval ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" (( -- )) eval ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests : subclass-reset-test ( -- ) ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
|
||||
|
||||
|
|
@ -576,7 +576,7 @@ GENERIC: break-me ( obj -- )
|
|||
|
||||
[ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" (( -- )) eval ] unit-test
|
||||
|
||||
[ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
|
||||
|
||||
|
|
@ -632,7 +632,7 @@ 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) method ] unit-test
|
||||
|
||||
|
|
@ -640,11 +640,11 @@ T{ reshape-test f "hi" } "tuple" set
|
|||
|
||||
[ "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
|
||||
|
||||
[ ] [ "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
|
||||
|
||||
|
|
@ -660,20 +660,20 @@ 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
|
||||
|
||||
[ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval ]
|
||||
[ "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
|
||||
|
||||
[ ] [ "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
|
||||
|
||||
[ 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
|
||||
|
||||
|
|
@ -694,7 +694,7 @@ DEFER: error-y
|
|||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: sequences TUPLE: reversed { seq read-only } ;" eval
|
||||
"IN: sequences TUPLE: reversed { seq read-only } ;" (( -- )) eval
|
||||
] unit-test
|
||||
|
||||
TUPLE: bogus-hashcode-1 x ;
|
||||
|
|
@ -735,14 +735,14 @@ SLOT: kex
|
|||
|
||||
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
|
||||
|
||||
[ ] [ "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
|
||||
|
||||
[ ] [ "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
|
||||
|
|
|
|||
|
|
@ -26,13 +26,13 @@ M: union-1 generic-update-test drop "union-1" ;
|
|||
[ t ] [ union-1 number class<= ] unit-test
|
||||
[ "union-1" ] [ 1.0 generic-update-test ] unit-test
|
||||
|
||||
"IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
|
||||
"IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" (( -- )) eval
|
||||
|
||||
[ t ] [ bignum union-1 class<= ] unit-test
|
||||
[ f ] [ union-1 number class<= ] unit-test
|
||||
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
|
||||
|
||||
"IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" eval
|
||||
"IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" (( -- )) eval
|
||||
|
||||
[ f ] [ union-1 union-class? ] unit-test
|
||||
[ t ] [ union-1 predicate-class? ] unit-test
|
||||
|
|
@ -58,7 +58,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
|
|||
[ t ] [ fixnum redefine-bug-2 class<= ] unit-test
|
||||
[ t ] [ quotation redefine-bug-2 class<= ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" (( -- )) eval ] unit-test
|
||||
|
||||
[ t ] [ bignum redefine-bug-1 class<= ] unit-test
|
||||
[ f ] [ fixnum redefine-bug-2 class<= ] unit-test
|
||||
|
|
|
|||
|
|
@ -56,6 +56,6 @@ observer add-definition-observer
|
|||
|
||||
DEFER: nesting-test
|
||||
|
||||
[ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" eval ] unit-test
|
||||
[ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" (( -- )) eval ] unit-test
|
||||
|
||||
observer remove-definition-observer
|
||||
observer remove-definition-observer
|
||||
|
|
|
|||
|
|
@ -65,11 +65,11 @@ M: number union-containment drop 2 ;
|
|||
[ 2 ] [ 1.0 union-containment ] unit-test
|
||||
|
||||
! Testing recovery from bad method definitions
|
||||
"IN: generic.tests GENERIC: unhappy ( x -- x )" eval
|
||||
"IN: generic.tests GENERIC: unhappy ( x -- x )" (( -- )) eval
|
||||
[
|
||||
"IN: generic.tests M: dictionary unhappy ;" eval
|
||||
"IN: generic.tests M: dictionary unhappy ;" (( -- )) eval
|
||||
] must-fail
|
||||
[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval ] unit-test
|
||||
[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" (( -- )) eval ] unit-test
|
||||
|
||||
GENERIC# complex-combination 1 ( a b -- c )
|
||||
M: string complex-combination drop ;
|
||||
|
|
@ -177,7 +177,7 @@ M: f generic-forget-test-3 ;
|
|||
|
||||
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
|
||||
|
||||
[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval ] unit-test
|
||||
[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" (( -- )) eval ] unit-test
|
||||
|
||||
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
|
||||
|
||||
|
|
@ -193,7 +193,7 @@ M: integer a-generic a-word ;
|
|||
|
||||
[ t ] [ "m" get \ a-word usage memq? ] unit-test
|
||||
|
||||
[ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval ] unit-test
|
||||
[ ] [ "IN: generic.tests : a-generic ( -- ) ;" (( -- )) eval ] unit-test
|
||||
|
||||
[ f ] [ "m" get \ a-word usage memq? ] unit-test
|
||||
|
||||
|
|
@ -207,25 +207,25 @@ M: integer a-generic a-word ;
|
|||
M: boii jeah ;
|
||||
GENERIC: jeah* ( a -- b )
|
||||
M: boii jeah* jeah ;
|
||||
"> eval
|
||||
"> (( -- )) eval
|
||||
|
||||
<"
|
||||
IN: compiler.tests
|
||||
FORGET: boii
|
||||
"> eval
|
||||
"> (( -- )) eval
|
||||
|
||||
<"
|
||||
IN: compiler.tests
|
||||
TUPLE: boii ;
|
||||
M: boii jeah ;
|
||||
"> eval
|
||||
"> (( -- )) eval
|
||||
] unit-test
|
||||
|
||||
! call-next-method cache test
|
||||
GENERIC: c-n-m-cache ( a -- b )
|
||||
|
||||
! Force it to be unoptimized
|
||||
M: fixnum c-n-m-cache { } [ ] like call call-next-method ;
|
||||
M: fixnum c-n-m-cache { } [ ] like call( -- ) call-next-method ;
|
||||
M: integer c-n-m-cache 1 + ;
|
||||
M: number c-n-m-cache ;
|
||||
|
||||
|
|
@ -244,4 +244,4 @@ GENERIC: move-method-generic ( a -- b )
|
|||
|
||||
[ ] [ "IN: generic.tests.a" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
|
||||
|
||||
[ { string } ] [ \ move-method-generic order ] unit-test
|
||||
[ { string } ] [ \ move-method-generic order ] unit-test
|
||||
|
|
|
|||
|
|
@ -66,7 +66,7 @@ M: circle area radius>> sq pi * ;
|
|||
|
||||
GENERIC: perimiter ( shape -- n )
|
||||
|
||||
: rectangle-perimiter ( n -- n ) + 2 * ;
|
||||
: rectangle-perimiter ( l w -- n ) + 2 * ;
|
||||
|
||||
M: rectangle perimiter
|
||||
[ width>> ] [ height>> ] bi
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ IN: memory.tests
|
|||
[ [ ] instances ] must-infer
|
||||
|
||||
! Code GC wasn't kicking in when needed
|
||||
: leak-step ( -- ) 800000 f <array> 1quotation call drop ;
|
||||
: leak-step ( -- ) 800000 f <array> 1quotation call( -- obj ) drop ;
|
||||
|
||||
: leak-loop ( -- ) 100 [ leak-step ] times ;
|
||||
|
||||
|
|
|
|||
|
|
@ -10,43 +10,43 @@ IN: parser.tests
|
|||
|
||||
[
|
||||
[ 1 [ 2 [ 3 ] 4 ] 5 ]
|
||||
[ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ]
|
||||
[ "1\n[\n2\n[\n3\n]\n4\n]\n5" (( -- a b c )) eval ]
|
||||
unit-test
|
||||
|
||||
[ t t f f ]
|
||||
[ "t t f f" eval ]
|
||||
[ "t t f f" (( -- ? ? ? ? )) eval ]
|
||||
unit-test
|
||||
|
||||
[ "hello world" ]
|
||||
[ "\"hello world\"" eval ]
|
||||
[ "\"hello world\"" (( -- string )) eval ]
|
||||
unit-test
|
||||
|
||||
[ "\n\r\t\\" ]
|
||||
[ "\"\\n\\r\\t\\\\\"" eval ]
|
||||
[ "\"\\n\\r\\t\\\\\"" (( -- string )) eval ]
|
||||
unit-test
|
||||
|
||||
[ "hello world" ]
|
||||
[
|
||||
"IN: parser.tests : hello ( -- str ) \"hello world\" ;"
|
||||
eval "USE: parser.tests hello" eval
|
||||
(( -- )) eval "USE: parser.tests hello" (( -- string )) eval
|
||||
] unit-test
|
||||
|
||||
[ ]
|
||||
[ "! This is a comment, people." eval ]
|
||||
[ "! This is a comment, people." (( -- )) eval ]
|
||||
unit-test
|
||||
|
||||
! Test escapes
|
||||
|
||||
[ " " ]
|
||||
[ "\"\\u000020\"" eval ]
|
||||
[ "\"\\u000020\"" (( -- string )) eval ]
|
||||
unit-test
|
||||
|
||||
[ "'" ]
|
||||
[ "\"\\u000027\"" eval ]
|
||||
[ "\"\\u000027\"" (( -- string )) eval ]
|
||||
unit-test
|
||||
|
||||
! Test EOL comments in multiline strings.
|
||||
[ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval ] unit-test
|
||||
[ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" (( -- string )) eval ] unit-test
|
||||
|
||||
[ word ] [ \ f class ] unit-test
|
||||
|
||||
|
|
@ -68,7 +68,7 @@ IN: parser.tests
|
|||
[ \ baz "declared-effect" word-prop terminated?>> ]
|
||||
unit-test
|
||||
|
||||
[ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test
|
||||
[ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" (( -- )) eval ] unit-test
|
||||
|
||||
[ t ] [
|
||||
"effect-parsing-test" "parser.tests" lookup
|
||||
|
|
@ -79,14 +79,14 @@ IN: parser.tests
|
|||
[ \ effect-parsing-test "declared-effect" word-prop ] unit-test
|
||||
|
||||
! Funny bug
|
||||
[ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval ] unit-test
|
||||
[ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." (( -- n )) eval ] unit-test
|
||||
|
||||
[ "IN: parser.tests : missing-- ( a b ) ;" eval ] must-fail
|
||||
[ "IN: parser.tests : missing-- ( a b ) ;" (( -- )) eval ] must-fail
|
||||
|
||||
! These should throw errors
|
||||
[ "HEX: zzz" eval ] must-fail
|
||||
[ "OCT: 999" eval ] must-fail
|
||||
[ "BIN: --0" eval ] must-fail
|
||||
[ "HEX: zzz" (( -- obj )) eval ] must-fail
|
||||
[ "OCT: 999" (( -- obj )) eval ] must-fail
|
||||
[ "BIN: --0" (( -- obj )) eval ] must-fail
|
||||
|
||||
! Another funny bug
|
||||
[ t ] [
|
||||
|
|
@ -102,14 +102,14 @@ IN: parser.tests
|
|||
] unit-test
|
||||
DEFER: foo
|
||||
|
||||
"IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval
|
||||
"IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" (( -- )) eval
|
||||
|
||||
[ ] [ "USE: parser.tests foo" eval ] unit-test
|
||||
[ ] [ "USE: parser.tests foo" (( -- )) eval ] unit-test
|
||||
|
||||
"IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval
|
||||
"IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" (( -- )) eval
|
||||
|
||||
[ t ] [
|
||||
"USE: parser.tests \\ foo" eval
|
||||
"USE: parser.tests \\ foo" (( -- word )) eval
|
||||
"foo" "parser.tests" lookup eq?
|
||||
] unit-test
|
||||
|
||||
|
|
@ -269,12 +269,12 @@ IN: parser.tests
|
|||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests : <bogus-error> ( -- ) ; : bogus ( -- ) <bogus-error> ;"
|
||||
"IN: parser.tests : <bogus-error> ( -- ) ; : bogus ( -- error ) <bogus-error> ;"
|
||||
<string-reader> "bogus-error" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus ( -- ) <bogus-error> ;"
|
||||
"IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus ( -- error ) <bogus-error> ;"
|
||||
<string-reader> "bogus-error" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
|
|
@ -339,16 +339,16 @@ IN: parser.tests
|
|||
] [ error>> error>> error>> redefine-error? ] must-fail-with
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval
|
||||
"IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" (( -- )) eval
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval
|
||||
"IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" (( -- )) eval
|
||||
] must-fail
|
||||
] with-file-vocabs
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval
|
||||
"IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" (( -- )) eval
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
|
|
@ -422,31 +422,31 @@ IN: parser.tests
|
|||
] unit-test
|
||||
|
||||
[
|
||||
"USE: this-better-not-exist" eval
|
||||
"USE: this-better-not-exist" (( -- )) eval
|
||||
] must-fail
|
||||
|
||||
[ ": foo ;" eval ] [ error>> error>> no-current-vocab? ] must-fail-with
|
||||
[ ": foo ;" (( -- )) eval ] [ error>> error>> no-current-vocab? ] must-fail-with
|
||||
|
||||
[ 92 ] [ "CHAR: \\" eval ] unit-test
|
||||
[ 92 ] [ "CHAR: \\\\" eval ] unit-test
|
||||
[ 92 ] [ "CHAR: \\" (( -- n )) eval ] unit-test
|
||||
[ 92 ] [ "CHAR: \\\\" (( -- n )) eval ] unit-test
|
||||
|
||||
[ ] [
|
||||
{
|
||||
"IN: parser.tests"
|
||||
"USING: math arrays ;"
|
||||
"GENERIC: change-combination ( a -- b )"
|
||||
"M: integer change-combination 1 ;"
|
||||
"M: array change-combination 2 ;"
|
||||
"USING: math arrays kernel ;"
|
||||
"GENERIC: change-combination ( obj a -- b )"
|
||||
"M: integer change-combination 2drop 1 ;"
|
||||
"M: array change-combination 2drop 2 ;"
|
||||
} "\n" join <string-reader> "change-combination-test" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
{
|
||||
"IN: parser.tests"
|
||||
"USING: math arrays ;"
|
||||
"GENERIC# change-combination 1 ( a -- b )"
|
||||
"M: integer change-combination 1 ;"
|
||||
"M: array change-combination 2 ;"
|
||||
"USING: math arrays kernel ;"
|
||||
"GENERIC# change-combination 1 ( obj a -- b )"
|
||||
"M: integer change-combination 2drop 1 ;"
|
||||
"M: array change-combination 2drop 2 ;"
|
||||
} "\n" join <string-reader> "change-combination-test" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
|
|
@ -463,7 +463,7 @@ IN: parser.tests
|
|||
] unit-test
|
||||
|
||||
[ [ ] ] [
|
||||
"IN: parser.tests : staging-problem-test-1 ( -- ) 1 ; : staging-problem-test-2 ( -- ) staging-problem-test-1 ;"
|
||||
"IN: parser.tests : staging-problem-test-1 ( -- a ) 1 ; : staging-problem-test-2 ( -- a ) staging-problem-test-1 ;"
|
||||
<string-reader> "staging-problem-test" parse-stream
|
||||
] unit-test
|
||||
|
||||
|
|
@ -472,7 +472,7 @@ IN: parser.tests
|
|||
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
|
||||
|
||||
[ [ ] ] [
|
||||
"IN: parser.tests << : staging-problem-test-1 ( -- ) 1 ; >> : staging-problem-test-2 ( -- ) staging-problem-test-1 ;"
|
||||
"IN: parser.tests << : staging-problem-test-1 ( -- a ) 1 ; >> : staging-problem-test-2 ( -- a ) staging-problem-test-1 ;"
|
||||
<string-reader> "staging-problem-test" parse-stream
|
||||
] unit-test
|
||||
|
||||
|
|
@ -480,10 +480,10 @@ IN: parser.tests
|
|||
|
||||
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
|
||||
|
||||
[ "DEFER: blahy" eval ] [ error>> error>> no-current-vocab? ] must-fail-with
|
||||
[ "DEFER: blahy" (( -- )) eval ] [ error>> error>> no-current-vocab? ] must-fail-with
|
||||
|
||||
[
|
||||
"IN: parser.tests SYNTAX: blahy ; FORGET: blahy" eval
|
||||
"IN: parser.tests SYNTAX: blahy ; FORGET: blahy" (( -- )) eval
|
||||
] [
|
||||
error>> staging-violation?
|
||||
] must-fail-with
|
||||
|
|
@ -491,12 +491,12 @@ IN: parser.tests
|
|||
! Bogus error message
|
||||
DEFER: blahy
|
||||
|
||||
[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" eval ]
|
||||
[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" (( -- )) eval ]
|
||||
[ error>> error>> def>> \ blahy eq? ] must-fail-with
|
||||
|
||||
[ ] [ f lexer set f file set "Hello world" note. ] unit-test
|
||||
|
||||
[ "CHAR: \\u9999999999999" eval ] must-fail
|
||||
[ "CHAR: \\u9999999999999" (( -- n )) eval ] must-fail
|
||||
|
||||
SYMBOLS: a b c ;
|
||||
|
||||
|
|
@ -506,15 +506,15 @@ SYMBOLS: a b c ;
|
|||
|
||||
DEFER: blah
|
||||
|
||||
[ ] [ "IN: parser.tests GENERIC: blah ( -- )" eval ] unit-test
|
||||
[ ] [ "IN: parser.tests SYMBOLS: blah ;" eval ] unit-test
|
||||
[ ] [ "IN: parser.tests GENERIC: blah ( -- )" (( -- )) eval ] unit-test
|
||||
[ ] [ "IN: parser.tests SYMBOLS: blah ;" (( -- )) eval ] unit-test
|
||||
|
||||
[ f ] [ \ blah generic? ] unit-test
|
||||
[ t ] [ \ blah symbol? ] unit-test
|
||||
|
||||
DEFER: blah1
|
||||
|
||||
[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" eval ]
|
||||
[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" (( -- )) eval ]
|
||||
[ error>> error>> def>> \ blah1 eq? ]
|
||||
must-fail-with
|
||||
|
||||
|
|
@ -545,10 +545,10 @@ EXCLUDE: qualified.tests.bar => x ;
|
|||
[ 3 ] [ x ] unit-test
|
||||
[ 4 ] [ y ] unit-test
|
||||
|
||||
[ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ]
|
||||
[ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" (( -- )) eval ]
|
||||
[ error>> no-word-error? ] must-fail-with
|
||||
|
||||
[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval ]
|
||||
[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" (( -- )) eval ]
|
||||
[ error>> no-word-error? ] must-fail-with
|
||||
|
||||
! Two similar bugs
|
||||
|
|
|
|||
|
|
@ -25,12 +25,12 @@ TUPLE: hello length ;
|
|||
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
|
||||
|
||||
! See if declarations are cleared on redefinition
|
||||
[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval ] unit-test
|
||||
[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" (( -- )) eval ] unit-test
|
||||
|
||||
[ t ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
|
||||
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
|
||||
|
||||
[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval ] unit-test
|
||||
[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" (( -- )) eval ] unit-test
|
||||
|
||||
[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
|
||||
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
|
||||
|
|
|
|||
|
|
@ -143,7 +143,7 @@ IN: vocabs.loader.tests
|
|||
forget-junk
|
||||
|
||||
[ { } ] [
|
||||
"IN: xabbabbja" eval "xabbabbja" vocab-files
|
||||
"IN: xabbabbja" (( -- )) eval "xabbabbja" vocab-files
|
||||
] unit-test
|
||||
|
||||
[ "xabbabbja" forget-vocab ] with-compilation-unit
|
||||
|
|
|
|||
|
|
@ -2,5 +2,5 @@ USING: math eval tools.test effects ;
|
|||
IN: words.alias.tests
|
||||
|
||||
ALIAS: foo +
|
||||
[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval ] unit-test
|
||||
[ (( -- value )) ] [ \ foo stack-effect ] unit-test
|
||||
[ ] [ "IN: words.alias.tests CONSTANT: foo 5" (( -- )) eval ] unit-test
|
||||
[ (( -- value )) ] [ \ foo stack-effect ] unit-test
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ IN: words.tests
|
|||
|
||||
[ 4 ] [
|
||||
[
|
||||
"poo" "words.tests" create [ 2 2 + ] define
|
||||
"poo" "words.tests" create [ 2 2 + ] (( -- n )) define-declared
|
||||
] with-compilation-unit
|
||||
"poo" "words.tests" lookup execute
|
||||
] unit-test
|
||||
|
|
@ -51,7 +51,7 @@ SYMBOL: a-symbol
|
|||
! See if redefining a generic as a colon def clears some
|
||||
! word props.
|
||||
GENERIC: testing ( a -- b )
|
||||
"IN: words.tests : testing ( -- ) ;" eval
|
||||
"IN: words.tests : testing ( -- ) ;" (( -- )) eval
|
||||
|
||||
[ f ] [ \ testing generic? ] unit-test
|
||||
|
||||
|
|
@ -88,7 +88,7 @@ DEFER: calls-a-gensym
|
|||
[
|
||||
\ calls-a-gensym
|
||||
gensym dup "x" set 1quotation
|
||||
define
|
||||
(( x -- x )) define-declared
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
|
|
@ -116,10 +116,10 @@ DEFER: x
|
|||
[ ] [ "no-loc" "words.tests" create drop ] unit-test
|
||||
[ f ] [ "no-loc" "words.tests" lookup where ] unit-test
|
||||
|
||||
[ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" eval ] unit-test
|
||||
[ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" (( -- )) eval ] unit-test
|
||||
[ f ] [ "no-loc-2" "words.tests" lookup where ] unit-test
|
||||
|
||||
[ ] [ "IN: words.tests : test-last ( -- ) ;" eval ] unit-test
|
||||
[ ] [ "IN: words.tests : test-last ( -- ) ;" (( -- )) eval ] unit-test
|
||||
[ "test-last" ] [ word name>> ] unit-test
|
||||
|
||||
! regression
|
||||
|
|
@ -146,15 +146,15 @@ SYMBOL: quot-uses-b
|
|||
[ forget ] with-compilation-unit
|
||||
] when*
|
||||
|
||||
[ "IN: words.tests : undef-test ( -- ) ; << undef-test >>" eval ]
|
||||
[ "IN: words.tests : undef-test ( -- ) ; << undef-test >>" (( -- )) eval ]
|
||||
[ error>> undefined? ] must-fail-with
|
||||
|
||||
[ ] [
|
||||
"IN: words.tests GENERIC: symbol-generic ( -- )" eval
|
||||
"IN: words.tests GENERIC: symbol-generic ( -- )" (( -- )) eval
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: words.tests SYMBOL: symbol-generic" eval
|
||||
"IN: words.tests SYMBOL: symbol-generic" (( -- )) eval
|
||||
] unit-test
|
||||
|
||||
[ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test
|
||||
|
|
@ -174,14 +174,14 @@ SYMBOL: quot-uses-b
|
|||
[ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test
|
||||
|
||||
! Regressions
|
||||
[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; foldable" eval ] unit-test
|
||||
[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; foldable" (( -- )) eval ] unit-test
|
||||
[ t ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test
|
||||
[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval ] unit-test
|
||||
[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" (( -- )) eval ] unit-test
|
||||
[ f ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test
|
||||
|
||||
[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; flushable" eval ] unit-test
|
||||
[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; flushable" (( -- )) eval ] unit-test
|
||||
[ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test
|
||||
[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval ] unit-test
|
||||
[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" (( -- )) eval ] unit-test
|
||||
[ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test
|
||||
|
||||
[ { } ]
|
||||
|
|
|
|||
Loading…
Reference in New Issue