After the publication of the original ANS Forth document (ANSI X3.215-1994), John Hayes developed a test suite, which included both a test harness and a suite of core tests. The harness was extended by Anton Ertl and David N. Williams to allow the testing of floating point operations. The current revision of the test harness is available from the web site:
The teat harness can be used to define regression tests for a set of application words. It can also be used to define tests of words in a standard-conforming implementation. Numerous people have contributed to the test cases given in section F.3 onwards. The majority of the test cases have been taken from John Hayes' test suite[1], Gerry Jackson's test suite[2] and David Williams with significant contributions from the committee.
[1] http://www.taygeta.com/forth.html
[2] http://soton.mpeforth.com/flag/anstests/index.html
The tester defines functions that compare the results of a test with
a set of expected results. The syntax for each test starts with
"T{" (T-open brace) followed by a code sequence to test.
This is followed by "->", the expected results, and
"}T" (close brace-T). For example, the following:
tests that one plus one indeed equals two.
The "T{" records the stack depth prior to the test code
so that they can be eliminated from the test.
The "->" records the stack depth and moves the entire stack
contents to an array. In the example test, the recorded stack depth
is one and the saved array contains one value, two.
The "}T" compares the current stack depth to the saved
stack depth. If they are equal each value on the stack is removed
from the stack and compared to its corresponding value in the array.
If the depths are not equal or if the stack comparison fails, an error
is reported. For example:
T{ 1 2 3 SWAP -> 1 3 2 }T
T{ 1 2 3 SWAP -> 1 2 3 }T INCORRECT RESULT: T{ 1 2 3 SWAP -> 1 2 3 }T
T{ 1 2 SWAP -> 1 }T WRONG NUMBER OF RESULTS: T{ 1 2 SWAP -> 1 }T
HAS-FLOATING and
HAS-FLOATING-STACK contain the results of its efforts, so
the behavior of the code can be modified by the user if necessary.
Then there are the perennial issues of floating point value
comparisons. Exact equality is specified by SET-EXACT
(the default). If approximate equality tests are desired, execute
SET-NEAR. Then the
FVARIABLEs REL-NEAR (default 1E-12) and
ABS-NEAR (default 0E) contain the values to be used in
comparisons by the (internal) word FNEARLY=.
When there is not a separate floating point stack, and you want to use
approximate equality for FP values, it is necessary to identify which
stack items are floating point quantities. This can be done by
replacing the closing }T with a version that specifies
this, such as RRXR}T which identifies the stack picture
(r r x r). The harness provides such words for all
combinations of R and X with up to four stack items. They can be
used with either an integrated or a separate floating point stacks.
Adding more if you need them is straightforward; see the examples in
the source. Here is an example which also illustrates controlling
the precision of comparisons:
The internal word ERROR is vectored, through the
ERROR-XT variable, so that its action can be changed by
the user (for example, to add a counter for the number of errors).
The default action ERROR1 can be used as a factor in the
display of error reports.
The following source code provides the test harness.
The test cases in John Hayes' original test suite were designed to test features before they were used in later tests. Due to the structure of this annex the progressive testing has been lost. This section attempts to retain the integrity of the original test suite by laying out the test progression for the core word set.
While this suite does test many aspects of the core word set, it is not comprehensive. A standard system should pass all of the tests within this suite. A system cannot claim to be standard simply because it passes this test suite.
The test starts by verifying basic assumptions about number representation. It then builds on this with tests of boolean logic, shifting, and comparisons. It then tests the basic stack manipulations and arithmetic. Ultimately, it tests the Forth interpreter and compiler.
Note that all of the tests in this suite assume the current base is hexadecimal.
These test assume a two's complement implementation where the range of signed numbers is -2n-1 ... 2n-1-1 and the range of unsinged numbers is 0 ... 2n-1.
A method for testing KEY, QUIT, ABORT, ABORT", ENVIRONMENT?, etc has yet to be proposed.
T{ -> }T ( Start with a clean slate )
( Test if any bits are set; Answer in base 1 )
T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T
T{ 0 BITSSET? -> 0 }T ( Zero is all bits clear )
T{ 1 BITSSET? -> 0 0 }T ( Other numbers have at least one bit )
T{ -1 BITSSET? -> 0 0 }T
To test the booleans it is first neccessary to test
F.6.1.0720 AND, and F.6.1.1720 INVERT. Before moving
on to the test F.6.1.0950 CONSTANT. The latter defines
two constants (0S and 1S) which will be used in the
further test.
It is now possible to complete the testing of F.6.1.0720 AND, F.6.1.1980 OR, and F.6.1.2490 XOR.
To test the shift operators it is necessary to calculate the most significant bit of a cell:
RSHIFT is tested later.
MSB must have at least one bit set:
The test F.6.1.0320 2*, F.6.1.0330 2/, F.6.1.1805 LSHIFT, and F.6.1.2162 RSHIFT can now be performed.
The numeric representation can be tested with the following test cases:
Before testing the comparison operators it is necessary to define a few constants to allow the testing of the upper and lower bounds.
With these constants defined, it is now possible to perform the F.6.1.0270 0=, F.6.1.0530 =, F.6.1.0250 0<, F.6.1.0480 <, F.6.1.0540 >, F.6.1.2340 U<, F.6.1.1880 MIN, and F.6.1.1870 MAX test.
The stack operators can be tested without any prepatory work. The "normal" operators (F.6.1.1260 DROP, F.6.1.1290 DUP, F.6.1.1990 OVER, F.6.1.2160 ROT, and F.6.1.2260 SWAP) should be tested first, followed by the two-cell variants (F.6.1.0370 2DROP, F.6.1.0380 2DUP, F.6.1.0400 2OVER and F.6.1.0430 2SWAP) with F.6.1.0630 ?DUP and F.6.1.1200 DEPTH being performed last.
The test F.6.1.0580 >R will test all three basic return stack operators (>R, R>, and R@).
Basic addition and subtraction should be tested in the order: F.6.1.0120 +, F.6.1.0160 -, F.6.1.0290 1+, F.6.1.0300 1-, F.6.1.0690 ABS and F.6.1.1910 NEGATE.
The multiplication operators should be tested in the order: F.6.1.2170 S>D, F.6.1.0090 *, F.6.1.1810 M*, and F.6.1.2360 UM*.
Due to the complexity of the division operators they are tested separately from the multiplication operators. The basic division operators are tested first: F.6.1.1561 FM/MOD, F.6.1.2214 SM/REM, and F.6.1.2370 UM/MOD.
As the standard allows a system to provide either floored or symmetric division, the remaining operators have to be tested depending on the system behaviour. Two words are defined that provide a form of conditional compilation.
IFSYM will ignore the rest of the line when it is performed
on a system with floored division and perform the line on a system
with symmetric division. IFFLOORED is the direct inverse,
ignoring the rest of the line on systems with symmetric division and
processing it on systems with floored division.
The remaining division operators are tested by defining a version of the operator using words which have already been tested (S>D, M*, FM/MOD and SM/REM). The test definition handles the special case of differing signes. As the test definitions use the words which have just been tested, the tests must be performed in the order: F.6.1.0240 /MOD, F.6.1.0230 /, F.6.1.1890 MOD, F.6.1.0100 */, and F.6.1.0110 */MOD.
As with the other sections, the tests for the memory access words build on previously tested words and thus require an order to the testing.
The first test (F.6.1.0150 , (comma)) tests HERE, the signle cell memory access words @, ! and CELL+ as well as the double cell access words 2@ and 2!. The tests F.6.1.0130 +! and F.6.1.0890 CELLS should then be performed.
The test (F.6.1.0860 C,) also tests the single character memory words C@, C!, and CHAR+, leaving the test F.6.1.0898 CHARS to be performed seperatly.
Finally, the memory access alignment test F.6.1.0705 ALIGN includes a test of ALIGNED, leaving F.6.1.0710 ALLOT as the final test in this group.
Basic character handling: F.6.1.0770 BL, F.6.1.0895 CHAR, F.6.1.2520 [CHAR], F.6.1.2500 [ which also tests ], and F.6.1.2165 S".
The dictionary tests define a number of words as part of the test, these are included in the approperate test: F.6.1.0070 ', F.6.1.2510 ['] both of which also test EXECUTE, F.6.1.1550 FIND, F.6.1.1780 LITERAL, F.6.1.0980 COUNT, F.6.1.2033 POSTPONE, F.6.1.2250 STATE
The flow control words have to be tested in matching groups. First test F.6.1.1700 IF, ELSE, THEN group. Followed by the BEGIN, F.6.1.2430 WHILE, REPEAT group, and the BEGIN, F.6.1.2390 UNTIL pairing. Finally the F.6.1.2120 RECURSE function should be tested.
Counted loops have a set of special condition that require testing. As with the flow control words, these words have to be tested as a group. First the basic counted loop: DO; I; F.6.1.1800 LOOP, followed by loops with a non regular increment: F.6.1.0140 +LOOP, loops within loops: F.6.1.1730 J, and aborted loops: F.6.1.1760 LEAVE; F.6.1.2380 UNLOOP which includes a test for EXIT.
Although most of the defining words have already been used within the test suite, they still need to be tested fully. The tests include F.6.1.0450 : which also tests ;, F.6.1.0950 CONSTANT, F.6.1.2410 VARIABLE, F.6.1.1250 DOES> which includes tests CREATE, and F.6.1.0550 >BODY which also tests CREATE.
As with the defining words, F.6.1.1360 EVALUATE has already been used, but it must still be tested fully.
Testing of the input source can be quit dificult. The tests require line breaks within the test: F.6.1.2216 SOURCE, F.6.1.0560 >IN, and F.6.1.2450 WORD.
The number formatting words produce a string, a word that compares two strings is required. This test suite assumes that the optional String word set is unavailable. Thus a string comparison word is defined, using only trusted words:
The number formatting words have to be tested as a group with F.6.1.1670 HOLD, F.6.1.2210 SIGN, and F.6.1.0030 # all including tests for <# and #>.
Before the F.6.1.0050 #S test can be performed it is necessary to calculate the number of bits required to store the largest double value.
The F.6.1.0570 >NUMBER test can now be performed. Finally, the F.6.1.0750 BASE test, which includes tests for HEX and DECIMAL, can be performed.
Frist two memory buffers are defined:
As the content of FBUF is changed by the
F.6.1.1540 FILL test, this must be executed before the
F.6.1.1900 MOVE test.
As there is no provision for capturing the output stream so that it can be compared to an expected result there is not automatic method of testing the output generation words. The user is required to validate the output for the F.6.1.1320 EMIT test. This tests the selection of output words ., .", CR, SPACE, SPACES, TYPE, and U..
To test the input word (F.6.1.0695 ACCEPT) the user is required to type up to 80 characters. The system will buffer the input sequence and output it to the user for inspection.
The final test in this suite is included with F.6.1.0450 : and tests the search order of the dictionary. It asserts that a definition that uses its own name in the definition is not recursive but rather refers to the previous definition of the word.
T{ : GDX 123 ; -> }T \ First defintion
T{ : GDX GDX 234 ; -> }T \ Second defintion
T{ GDX -> 123 234 }T
: GP4 <# 1 0 #S #> S" 1" S= ;
: GP5
BASE @ <TRUE>
MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE
I BASE ! \ TBD: ASSUMES BASE WORKS
I 0 <# #S #> S" 10" S= AND
LOOP
SWAP BASE ! ;
T{ GP5 -> <TRUE> }T
: GP6
BASE @ >R 2 BASE !
MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY
R> BASE ! \ S: C-ADDR U
DUP #BITS-UD = SWAP
0 DO \ S: C-ADDR FLAG
OVER C@ [CHAR] 1 = AND \ ALL ONES
>R CHAR+ R>
LOOP SWAP DROP ;
T{ GP6 -> <TRUE> }T
: GP7
BASE @ >R MAX-BASE BASE !
<TRUE>
A 0 DO
I 0 <# #S #>
1 = SWAP C@ I 30 + = AND AND
LOOP
MAX-BASE A DO
I 0 <# #S #>
1 = SWAP C@ 41 I A - + = AND AND
LOOP
R> BASE ! ;
T{ GP7 -> <TRUE> }T
T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T
T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T
T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T
T{ 0 2 1 */ -> 0 2 1 T*/ }T
T{ 1 2 1 */ -> 1 2 1 T*/ }T
T{ 2 2 1 */ -> 2 2 1 T*/ }T
T{ -1 2 1 */ -> -1 2 1 T*/ }T
T{ -2 2 1 */ -> -2 2 1 T*/ }T
T{ 0 2 -1 */ -> 0 2 -1 T*/ }T
T{ 1 2 -1 */ -> 1 2 -1 T*/ }T
T{ 2 2 -1 */ -> 2 2 -1 T*/ }T
T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
T{ -2 2 -1 */ -> -2 2 -1 T*/ }T
T{ 2 2 2 */ -> 2 2 2 T*/ }T
T{ -1 2 -1 */ -> -1 2 -1 T*/ }T
T{ -2 2 -2 */ -> -2 2 -2 T*/ }T
T{ 7 2 3 */ -> 7 2 3 T*/ }T
T{ 7 2 -3 */ -> 7 2 -3 T*/ }T
T{ -7 2 3 */ -> -7 2 3 T*/ }T
T{ -7 2 -3 */ -> -7 2 -3 T*/ }T
T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T
T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T
T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T
T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T
T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T
T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T
T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T
T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T
T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T
T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T
T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T
T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T
T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T
T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T
T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T
T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T
T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T
T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T
T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T
T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T
VARIABLE gditerations
VARIABLE gdincrement
: gd7 ( limit start increment -- )
gdincrement !
0 gditerations !
DO
1 gditerations +!
I
gditerations @ 6 = IF LEAVE THEN
gdincrement @
+LOOP gditerations @
;
T{ 4 4 -1 gd7 -> 4 1 }T
T{ 1 4 -1 gd7 -> 4 3 2 1 4 }T
T{ 4 1 -1 gd7 -> 1 0 -1 -2 -3 -4 6 }T
T{ 4 1 0 gd7 -> 1 1 1 1 1 1 6 }T
T{ 0 0 0 gd7 -> 0 0 0 0 0 0 6 }T
T{ 1 4 0 gd7 -> 4 4 4 4 4 4 6 }T
T{ 1 4 1 gd7 -> 4 5 6 7 8 9 6 }T
T{ 4 1 1 gd7 -> 1 2 3 3 }T
T{ 4 4 1 gd7 -> 4 5 6 7 8 9 6 }T
T{ 2 -1 -1 gd7 -> -1 -2 -3 -4 -5 -6 6 }T
T{ -1 2 -1 gd7 -> 2 1 0 -1 4 }T
T{ 2 -1 0 gd7 -> -1 -1 -1 -1 -1 -1 6 }T
T{ -1 2 0 gd7 -> 2 2 2 2 2 2 6 }T
T{ -1 2 1 gd7 -> 2 3 4 5 6 7 6 }T
T{ 2 -1 1 gd7 -> -1 0 1 3 }T
T{ -20 30 -10 gd7 -> 30 20 10 0 -10 -20 6 }T
T{ -20 31 -10 gd7 -> 31 21 11 1 -9 -19 6 }T
T{ -20 29 -10 gd7 -> 29 19 9 -1 -11 5 }T
\ With large and small increments
MAX-UINT 8 RSHIFT 1+ CONSTANT ustep
ustep NEGATE CONSTANT -ustep
MAX-INT 7 RSHIFT 1+ CONSTANT step
step NEGATE CONSTANT -step
VARIABLE bump
T{ : gd8 bump ! DO 1+ bump @ +LOOP ; -> }T
T{ 0 MAX-UINT 0 ustep gd8 -> 256 }T
T{ 0 0 MAX-UINT -ustep gd8 -> 256 }T
T{ 0 MAX-INT MIN-INT step gd8 -> 256 }T
T{ 0 MIN-INT MAX-INT -step gd8 -> 256 }T
T{ 1ST 2ND U< -> <TRUE> }T \ HERE MUST GROW WITH ALLOT
T{ 1ST CELL+ -> 2ND }T \ ... BY ONE CELL
T{ 1ST 1 CELLS + -> 2ND }T
T{ 1ST @ 2ND @ -> 1 2 }T
T{ 5 1ST ! -> }T
T{ 1ST @ 2ND @ -> 5 2 }T
T{ 6 2ND ! -> }T
T{ 1ST @ 2ND @ -> 5 6 }T
T{ 1ST 2@ -> 6 5 }T
T{ 2 1 1ST 2! -> }T
T{ 1ST 2@ -> 2 1 }T
T{ 1S 1ST ! 1ST @ -> 1S }T \ CAN STORE CELL-WIDE VALUE
See F.6.1.1320 EMIT.
T{ 0 1 / -> 0 1 T/ }T
T{ 1 1 / -> 1 1 T/ }T
T{ 2 1 / -> 2 1 T/ }T
T{ -1 1 / -> -1 1 T/ }T
T{ -2 1 / -> -2 1 T/ }T
T{ 0 -1 / -> 0 -1 T/ }T
T{ 1 -1 / -> 1 -1 T/ }T
T{ 2 -1 / -> 2 -1 T/ }T
T{ -1 -1 / -> -1 -1 T/ }T
T{ -2 -1 / -> -2 -1 T/ }T
T{ 2 2 / -> 2 2 T/ }T
T{ -1 -1 / -> -1 -1 T/ }T
T{ -2 -2 / -> -2 -2 T/ }T
T{ 7 3 / -> 7 3 T/ }T
T{ 7 -3 / -> 7 -3 T/ }T
T{ -7 3 / -> -7 3 T/ }T
T{ -7 -3 / -> -7 -3 T/ }T
T{ MAX-INT 1 / -> MAX-INT 1 T/ }T
T{ MIN-INT 1 / -> MIN-INT 1 T/ }T
T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T
T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T
T{ 0 1 /MOD -> 0 1 T/MOD }T
T{ 1 1 /MOD -> 1 1 T/MOD }T
T{ 2 1 /MOD -> 2 1 T/MOD }T
T{ -1 1 /MOD -> -1 1 T/MOD }T
T{ -2 1 /MOD -> -2 1 T/MOD }T
T{ 0 -1 /MOD -> 0 -1 T/MOD }T
T{ 1 -1 /MOD -> 1 -1 T/MOD }T
T{ 2 -1 /MOD -> 2 -1 T/MOD }T
T{ -1 -1 /MOD -> -1 -1 T/MOD }T
T{ -2 -1 /MOD -> -2 -1 T/MOD }T
T{ 2 2 /MOD -> 2 2 T/MOD }T
T{ -1 -1 /MOD -> -1 -1 T/MOD }T
T{ -2 -2 /MOD -> -2 -2 T/MOD }T
T{ 7 3 /MOD -> 7 3 T/MOD }T
T{ 7 -3 /MOD -> 7 -3 T/MOD }T
T{ -7 3 /MOD -> -7 3 T/MOD }T
T{ -7 -3 /MOD -> -7 -3 T/MOD }T
T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T
T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T
T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T
T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T
T{ 2 SCANS !
345 RESCAN?
-> 345 345 }T
: GS2 5 SCANS ! S" 123 RESCAN?" EVALUATE ;
T{ GS2 -> 123 123 123 123 123 }T
\ These tests must start on a new line
DECIMAL
T{ 123456 DEPTH OVER 9 < 35 AND + 3 + >IN !
-> 123456 23456 3456 456 56 6 }T
T{ 14145 8115 ?DUP 0= 34 AND >IN +! TUCK MOD 14 >IN ! GCD calculation
-> 15 }T
T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T
T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T
T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T
\ FOLLOWING SHOULD FAIL TO CONVERT
T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T
T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T
T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T
: >NUMBER-BASED
BASE @ >R BASE ! >NUMBER R> BASE ! ;
T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T
T{ 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING }T
T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T
T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T
T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T
T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T
: GN1 ( UD BASE -- UD' LEN )
\ UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
BASE @ >R BASE !
<# #S #>
0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY
R> BASE ! ;
T{ 0 0 2 GN1 -> 0 0 0 }T
T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T
T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T
T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T
T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T
T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T
T{ 1STC 2NDC U< -> <TRUE> }T \ HERE MUST GROW WITH ALLOT
T{ 1STC CHAR+ -> 2NDC }T \ ... BY ONE CHAR
T{ 1STC 1 CHARS + -> 2NDC }T
T{ 1STC C@ 2NDC C@ -> 1 2 }T
T{ 3 1STC C! -> }T
T{ 1STC C@ 2NDC C@ -> 3 2 }T
T{ 4 2NDC C! -> }T
T{ 1STC C@ 2NDC C@ -> 3 4 }T
T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T
T{ WEIRD: W1 -> }T
T{ ' W1 >BODY -> HERE }T
T{ W1 -> HERE 1 + }T
T{ W1 -> HERE 2 + }T
T{ OUTPUT-TEST -> }T
T{ GE1 EVALUATE -> 123 }T ( TEST EVALUATE IN INTERP. STATE )
T{ GE2 EVALUATE -> 124 }T
T{ GE3 EVALUATE -> }T
T{ GE4 -> 345 }T
T{ : GE6 GE1 GE5 ; -> }T ( TEST EVALUATE IN COMPILE STATE )
T{ GE6 -> 123 }T
T{ : GE7 GE2 GE5 ; -> }T
T{ GE7 -> 124 }T
See F.9.3.6 for additional test.
T{ FBUF 1 20 FILL -> }T
T{ SEEBUF -> 20 00 00 }T
T{ FBUF 3 20 FILL -> }T
T{ SEEBUF -> 20 20 20 }T
\ Multiple ELSEs in an IF statement
: melse IF 1 ELSE 2 ELSE 3 ELSE 4 ELSE 5 THEN ;
T{ <FALSE> melse -> 2 4 }T
T{ <TRUE> melse -> 1 3 5 }T
T{ VARIABLE iw3 IMMEDIATE 234 iw3 ! iw3 @ -> 234 }T
T{ : iw4 iw3 [ @ ] LITERAL ; iw4 -> 234 }T
T{ :NONAME [ 345 ] iw3 [ ! ] ; DROP iw3 @ -> 345 }T
T{ CREATE iw5 456 , IMMEDIATE -> }T
T{ :NONAME iw5 [ @ iw3 ! ] ; DROP iw3 @ -> 456 }T
T{ : iw6 CREATE , IMMEDIATE DOES> @ 1+ ; -> }T
T{ 111 iw6 iw7 iw7 -> 112 }T
T{ : iw8 iw7 LITERAL 1+ ; iw8 -> 113 }T
T{ : iw9 CREATE , DOES> @ 2 + IMMEDIATE ; -> }T
: find-iw BL WORD FIND NIP ;
T{ 222 iw9 iw10 find-iw iw10 -> -1 }T \ iw10 is not immediate
T{ iw10 find-iw iw10 -> 224 1 }T \ iw10 becomes immediate
See F.6.1.2510 ['], F.6.1.2033 POSTPONE, F.6.1.2250 STATE, F.6.1.2165 S".
T{ 0 1 MOD -> 0 1 TMOD }T
T{ 1 1 MOD -> 1 1 TMOD }T
T{ 2 1 MOD -> 2 1 TMOD }T
T{ -1 1 MOD -> -1 1 TMOD }T
T{ -2 1 MOD -> -2 1 TMOD }T
T{ 0 -1 MOD -> 0 -1 TMOD }T
T{ 1 -1 MOD -> 1 -1 TMOD }T
T{ 2 -1 MOD -> 2 -1 TMOD }T
T{ -1 -1 MOD -> -1 -1 TMOD }T
T{ -2 -1 MOD -> -2 -1 TMOD }T
T{ 2 2 MOD -> 2 2 TMOD }T
T{ -1 -1 MOD -> -1 -1 TMOD }T
T{ -2 -2 MOD -> -2 -2 TMOD }T
T{ 7 3 MOD -> 7 3 TMOD }T
T{ 7 -3 MOD -> 7 -3 TMOD }T
T{ -7 3 MOD -> -7 3 TMOD }T
T{ -7 -3 MOD -> -7 -3 TMOD }T
T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T
T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T
T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T
T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T
T{ SBUF FBUF 0 CHARS MOVE -> }T
T{ SEEBUF -> 20 20 20 }T
T{ SBUF FBUF 1 CHARS MOVE -> }T
T{ SEEBUF -> 12 20 20 }T
T{ SBUF FBUF 3 CHARS MOVE -> }T
T{ SEEBUF -> 12 34 56 }T
T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T
T{ SEEBUF -> 12 12 34 }T
T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T
T{ SEEBUF -> 12 34 34 }T
DECIMAL
T{ :NONAME ( n -- 0, 1, .., n )
DUP IF DUP >R 1- RECURSE R> THEN
;
CONSTANT rn1 -> }T
T{ 0 rn1 EXECUTE -> 0 }T
T{ 4 rn1 EXECUTE -> 0 1 2 3 4 }T
:NONAME ( n -- n1 )
1- DUP
CASE 0 OF EXIT ENDOF
1 OF 11 SWAP RECURSE ENDOF
2 OF 22 SWAP RECURSE ENDOF
3 OF 33 SWAP RECURSE ENDOF
DROP ABS RECURSE EXIT
ENDCASE
; CONSTANT rn2
T{ 1 rn2 EXECUTE -> 0 }T
T{ 2 rn2 EXECUTE -> 11 0 }T
T{ 4 rn2 EXECUTE -> 33 22 11 0 }T
T{ 25 rn2 EXECUTE -> 33 22 11 0 }T
T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T
T{ MID-UINT+1 2 UM* -> 0 1 }T
T{ MID-UINT+1 4 UM* -> 0 2 }T
T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T
T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T
T{ : GI5 BEGIN DUP 2 > WHILE
DUP 5 < WHILE DUP 1+ REPEAT
123 ELSE 345 THEN ; -> }T
T{ 1 GI5 -> 1 345 }T
T{ 2 GI5 -> 2 345 }T
T{ 3 GI5 -> 3 4 5 123 }T
T{ 4 GI5 -> 4 5 123 }T
T{ 5 GI5 -> 5 123 }T
: qd ?DO I LOOP ;
T{ 789 789 qd -> }T
T{ -9876 -9876 qd -> }T
T{ 5 0 qd -> 0 1 2 3 4 }T
: qd1 ?DO I 10 +LOOP ;
T{ 50 1 qd1 -> 1 11 21 31 41 }T
T{ 50 0 qd1 -> 0 10 20 30 40 }T
: qd2 ?DO I 3 > IF LEAVE ELSE I THEN LOOP ;
T{ 5 -1 qd2 -> -1 0 1 2 3 }T
: qd3 ?DO I 1 +LOOP ;
T{ 4 4 qd3 -> }T
T{ 4 1 qd3 -> 1 2 3 }T
T{ 2 -1 qd3 -> -1 0 1 }T
: qd4 ?DO I -1 +LOOP ;
T{ 4 4 qd4 -> }T
T{ 1 4 qd4 -> 4 3 2 1 }T
T{ -1 2 qd4 -> 2 1 0 -1 }T
: qd5 ?DO I -10 +LOOP ;
T{ 1 50 qd5 -> 50 40 30 20 10 }T
T{ 0 50 qd5 -> 50 40 30 20 10 0 }T
T{ -25 10 qd5 -> 10 0 -10 -20 }T
VARIABLE qditerations
VARIABLE qdincrement
: qd6 ( limit start increment -- )
qdincrement !
0 qditerations !
?DO
1 qditerations +!
I
qditerations @ 6 = IF LEAVE THEN
qdincrement @
+LOOP qditerations @
;
T{ 4 4 -1 qd6 -> 0 }T
T{ 1 4 -1 qd6 -> 4 3 2 1 4 }T
T{ 4 1 -1 qd6 -> 1 0 -1 -2 -3 -4 6 }T
T{ 4 1 0 qd6 -> 1 1 1 1 1 1 6 }T
T{ 0 0 0 qd6 -> 0 }T
T{ 1 4 0 qd6 -> 4 4 4 4 4 4 6 }T
T{ 1 4 1 qd6 -> 4 5 6 7 8 9 6 }T
T{ 4 1 1 qd6 -> 1 2 3 3 }T
T{ 4 4 1 qd6 -> 0 }T
T{ 2 -1 -1 qd6 -> -1 -2 -3 -4 -5 -6 6 }T
T{ -1 2 -1 qd6 -> 2 1 0 -1 4 }T
T{ 2 -1 0 qd6 -> -1 -1 -1 -1 -1 -1 6 }T
T{ -1 2 0 qd6 -> 2 2 2 2 2 2 6 }T
T{ -1 2 1 qd6 -> 2 3 4 5 6 7 6 }T
T{ 2 -1 1 qd6 -> -1 0 1 3 }T
\ Buffer is aligned
T{ TBUF1 ALIGNED -> TBUF1 }T
\ Buffers do not overlap
T{ TBUF2 TBUF1 - ABS 127 CHARS < -> <FALSE> }T
\ Buffer can be written to
1 CHARS CONSTANT /CHAR
: TFULL? ( c-addr n char -- flag )
TRUE 2SWAP CHARS OVER + SWAP ?DO
OVER I C@ = AND
/CHAR +LOOP NIP
;
T{ TBUF1 127 CHAR * FILL -> }T
T{ TBUF1 127 CHAR * TFULL? -> <TRUE> }T
T{ TBUF1 127 0 FILL -> }T
T{ TBUF1 127 0 TFULL? -> <TRUE> }T
T{ 1 cs1 -> 111 }T
T{ 2 cs1 -> 222 }T
T{ 3 cs1 -> 333 }T
T{ 4 cs1 -> 999 }T
: cs2 >R CASE
-1 OF CASE R@ 1 OF 100 ENDOF
2 OF 200 ENDOF
>R -300 R>
ENDCASE
ENDOF
-2 OF CASE R@ 1 OF -99 ENDOF
>R -199 R>
ENDCASE
ENDOF
>R 299 R>
ENDCASE R> DROP
;
T{ -1 1 cs2 -> 100 }T
T{ -1 2 cs2 -> 200 }T
T{ -1 3 cs2 -> -300 }T
T{ -2 1 cs2 -> -99 }T
T{ -2 2 cs2 -> -199 }T
T{ 0 2 cs2 -> 299 }T
\ test empty parse area
T{ PARSE-NAME
NIP -> 0 }T \ empty line
T{ PARSE-NAME
NIP -> 0 }T \ line with white space
T{ : parse-name-test ( "name1" "name2" -- n )
PARSE-NAME PARSE-NAME S= ; -> }T
T{ parse-name-test abcd abcd -> <TRUE> }T
T{ parse-name-test abcd abcd -> <TRUE> }T
T{ parse-name-test abcde abcdf -> <FALSE> }T
T{ parse-name-test abcdf abcde -> <FALSE> }T
T{ parse-name-test abcde abcde
-> <TRUE> }T
T{ parse-name-test abcde abcde
-> <TRUE> }T
\ line with white space
: NeverExecuted
." This should never be executed" ABORT
;
11111 SAVE-INPUT
siv @
[IF]
0 siv !
RESTORE-INPUT
NeverExecuted
[ELSE]
\ Testing the ELSE part is executed
22222
[THEN]
T{ -> 11111 0 22222 }T \ 0 comes from RESTORE-INPUT
Testing with a string source
VARIABLE si_inc 0 si_inc !
: si1
si_inc @ >IN +!
15 si_inc !
;
: s$ S" SAVE-INPUT si1 RESTORE-INPUT 12345" ;
T{ s$ EVALUATE si_inc @ -> 0 2345 15 }T
Testing nesting
: read_a_line
REFILL 0=
ABORT" REFILL failed"
;
0 si_inc !
2VARIABLE 2res -1. 2res 2!
: si2
read_a_line
read_a_line
SAVE-INPUT
read_a_line
read_a_line
s$ EVALUATE 2res 2!
RESTORE-INPUT
;
WARNING: do not delete or insert lines of text after si2 is called otherwise the next test will fail
si2
33333 \ This line should be ignored
2res 2@ 44444 \ RESTORE-INPUT should return to this line
55555
T{ -> 0 0 2345 44444 55555 }T
With an immediate word
T{ : [c2] [COMPILE] [c1] ; -> }T
T{ 234 [c2] -> 234 234 }T
With special compilation semantics
T{ : [cif] [COMPILE] IF ; IMMEDIATE -> }T
T{ : [c3] [cif] 111 ELSE 222 THEN ; -> }T
T{ -1 [c3] -> 111 }T
T{ 0 [c3] -> 222 }T
Two additional constants are defined to assist tests in this word set:
Before anything can be tested, the text interpreter must be tested (F.8.3.2). Once the F.8.6.1.0360 2CONSTANT test has been preformed we can also define a number of double constants:
The rest of the word set can be tesed: F.8.6.1.1230 DNEGATE, F.8.6.1.1040 D+, F.8.6.1.1050 D-, F.8.6.1.1075 D0<, F.8.6.1.1080 D0=, F.8.6.1.1090 D2*, F.8.6.1.1100 D2/, F.8.6.1.1110 D<, F.8.6.1.1120 D=, F.8.6.1.0390 2LITERAL, F.8.6.1.0440 2VARIABLE, F.8.6.1.1210 DMAX, F.8.6.1.1220 DMIN, F.8.6.1.1140 D>S, F.8.6.1.1160 DABS, F.8.6.1.1830 M+, F.8.6.1.1820 M*/ and F.8.6.1.1070 D.R which also tests D. before moving on to the existion words with the F.8.6.2.0420 2ROT and F.8.6.2.1270 DU< tests.
T{ 1. -> 1 0 }T
T{ -2. -> -2 -1 }T
T{ : rdl1 3. ; rdl1 -> 3 0 }T
T{ : rdl2 -4. ; rdl2 -> -4 -1 }T
T{ 0 0 0 5 D+ -> 0 5 }T \ mid range integers
T{ -1 5 0 0 D+ -> -1 5 }T
T{ 0 0 0 -5 D+ -> 0 -5 }T
T{ 0 -5 -1 0 D+ -> -1 -5 }T
T{ 0 1 0 2 D+ -> 0 3 }T
T{ -1 1 0 -2 D+ -> -1 -1 }T
T{ 0 -1 0 2 D+ -> 0 1 }T
T{ 0 -1 -1 -2 D+ -> -1 -3 }T
T{ -1 -1 0 1 D+ -> -1 0 }T
T{ MIN-INT 0 2DUP D+ -> 0 1 }T
T{ MIN-INT S>D MIN-INT 0 D+ -> 0 0 }T
T{ HI-2INT 1. D+ -> 0 HI-INT 1+ }T \ large double integers
T{ HI-2INT 2DUP D+ -> 1S 1- MAX-INT }T
T{ MAX-2INT MIN-2INT D+ -> -1. }T
T{ MAX-2INT LO-2INT D+ -> HI-2INT }T
T{ LO-2INT 2DUP D+ -> MIN-2INT }T
T{ HI-2INT MIN-2INT D+ 1. D+ -> LO-2INT }T
T{ MIN-INT 0 2DUP D- -> 0. }T
T{ MIN-INT S>D MAX-INT 0D- -> 1 1s }T
T{ MAX-2INT max-2INT D- -> 0. }T \ large integers
T{ MIN-2INT min-2INT D- -> 0. }T
T{ MAX-2INT hi-2INT D- -> lo-2INT DNEGATE }T
T{ HI-2INT lo-2INT D- -> max-2INT }T
T{ LO-2INT hi-2INT D- -> min-2INT 1. D+ }T
T{ MIN-2INT min-2INT D- -> 0. }T
T{ MIN-2INT lo-2INT D- -> lo-2INT }T
: d>ascii ( d -- caddr u )
DUP >R <# DABS #S R> SIGN #> ( -- caddr1 u )
HERE SWAP 2DUP 2>R CHARS DUP ALLOT MOVE 2R>
;
dbl1 d>ascii 2CONSTANT "dbl1"
dbl2 d>ascii 2CONSTANT "dbl2"
: DoubleOutput
CR ." You should see lines duplicated:" CR
5 SPACES "dbl1" TYPE CR
5 SPACES dbl1 D. CR
8 SPACES "dbl1" DUP >R TYPE CR
5 SPACES dbl1 R> 3 + D.R CR
5 SPACES "dbl2" TYPE CR
5 SPACES dbl2 D. CR
10 SPACES "dbl2" DUP >R TYPE CR
5 SPACES dbl2 R> 5 + D.R CR
;
T{ DoubleOutput -> }T
T{ MAX-2INT 2DUP -1. D+ D< -> <FALSE> }T
T{ MIN-2INT 2DUP 1. D+ D< -> <TRUE> }T
T{ 0 -1 0 -1 D= -> <TRUE> }T
T{ 0 -1 0 0 D= -> <FALSE> }T
T{ 0 -1 0 1 D= -> <FALSE> }T
T{ 0 0 0 -1 D= -> <FALSE> }T
T{ 0 0 0 0 D= -> <TRUE> }T
T{ 0 0 0 1 D= -> <FALSE> }T
T{ 0 1 0 -1 D= -> <FALSE> }T
T{ 0 1 0 0 D= -> <FALSE> }T
T{ 0 1 0 1 D= -> <TRUE> }T
T{ MAX-2INT MIN-2INT D= -> <FALSE> }T
T{ MAX-2INT 0. D= -> <FALSE> }T
T{ MAX-2INT MAX-2INT D= -> <TRUE> }T
T{ MAX-2INT HI-2INT D= -> <FALSE> }T
T{ MAX-2INT MIN-2INT D= -> <FALSE> }T
T{ MIN-2INT MIN-2INT D= -> <TRUE> }T
T{ MIN-2INT LO-2INT D= -> <FALSE> }T
T{ MIN-2INT MAX-2INT D= -> <FALSE> }T
T{ MAX-2INT HI-2INT DMAX -> MAX-2INT }T
T{ MAX-2INT MIN-2INT DMAX -> MAX-2INT }T
T{ MIN-2INT MAX-2INT DMAX -> MAX-2INT }T
T{ MIN-2INT LO-2INT DMAX -> LO-2INT }T
T{ MAX-2INT 1. DMAX -> MAX-2INT }T
T{ MAX-2INT -1. DMAX -> MAX-2INT }T
T{ MIN-2INT 1. DMAX -> 1. }T
T{ MIN-2INT -1. DMAX -> -1. }T
T{ MAX-2INT HI-2INT DMIN -> HI-2INT }T
T{ MAX-2INT MIN-2INT DMIN -> MIN-2INT }T
T{ MIN-2INT MAX-2INT DMIN -> MIN-2INT }T
T{ MIN-2INT LO-2INT DMIN -> MIN-2INT }T
T{ MAX-2INT 1. DMIN -> 1. }T
T{ MAX-2INT -1. DMIN -> -1. }T
T{ MIN-2INT 1. DMIN -> MIN-2INT }T
T{ MIN-2INT -1. DMIN -> MIN-2INT }T
: ?floored [ -3 2 / -2 = ] LITERAL IF 1. D- THEN ;
T{ 5. 7 11 M*/ -> 3. }T
T{ 5. -7 11 M*/ -> -3. ?floored }T
T{ -5. 7 11 M*/ -> -3. ?floored }T
T{ -5. -7 11 M*/ -> 3. }T
T{ MAX-2INT 8 16 M*/ -> HI-2INT }T
T{ MAX-2INT -8 16 M*/ -> HI-2INT DNEGATE ?floored }T
T{ MIN-2INT 8 16 M*/ -> LO-2INT }T
T{ MIN-2INT -8 16 M*/ -> LO-2INT DNEGATE }T
T{ MAX-2INT MAX-INT MAX-INT M*/ -> MAX-2INT }T
T{ MAX-2INT MAX-INT 2/ MAX-INT M*/ -> MAX-INT 1- HI-2INT NIP }T
T{ MIN-2INT LO-2INT NIP DUP NEGATE M*/ -> MIN-2INT }T
T{ MIN-2INT LO-2INT NIP 1- MAX-INT M*/ -> MIN-INT 3 + HI-2INT NIP 2 + }T
T{ MAX-2INT LO-2INT NIP DUP NEGATE M*/ -> MAX-2INT DNEGATE }T
T{ MIN-2INT MAX-INT DUP M*/ -> MIN-2INT }T
T{ MAX-2INT HI-2INT DU< -> <FALSE> }T
T{ HI-2INT MAX-2INT DU< -> <TRUE> }T
T{ MAX-2INT MIN-2INT DU< -> <TRUE> }T
T{ MIN-2INT MAX-2INT DU< -> <FALSE> }T
T{ MIN-2INT LO-2INT DU< -> <TRUE> }T
Ideally all of the throw codes should be tested. Here only the
thow code for an "Undefined Word" exception is tested, assuming
that the word $$UndefedWord$$ is undefined.
T{ 6 7 ' t9 c6 3 -> 6 7 13 3 }T
: t1 9 ;
: c1 1 2 3 ['] t1 CATCH ;
T{ c1 -> 1 2 3 9 0 }T \ No THROW executed
: t2 8 0 THROW ;
: c2 1 2 ['] t2 CATCH ;
T{ c2 -> 1 2 8 0 }T \ 0 THROW does nothing
: t3 7 8 9 99 THROW ;
: c3 1 2 ['] t3 CATCH ;
T{ c3 -> 1 2 99 }T \ Restores stack to CATCH depth
: t4 1- DUP 0> IF RECURSE ELSE 999 THROW -222 THEN ;
: c4 3 4 5 10 ['] t4 CATCH -111 ;
T{ c4 -> 3 4 5 0 999 -111 }T \ Test return stack unwinding
: t5 2DROP 2DROP 9999 THROW ;
: c5 1 2 3 4 ['] t5 CATCH \ Test depth restored correctly
DEPTH >R DROP 2DROP 2DROP R> ; \ after stack has been emptied
T{ c5 -> 5 }T
The 77 in t10 is necessary for the second
ABORT" test as the data stack is restored to a
depth of 2 when THROW is executed. The 77 ensures
the top of stack value is known for the results check.
: t10 77 SWAP ABORT" This should not be displayed" ;
: c6 CATCH
CASE exc_abort OF 11 ENDOF
exc_abort" OF 12 ENDOF
exc_undef OF 13 ENDOF
ENDCASE
;
T{ 1 2 ' t6 c6 -> 1 2 11 }T \ Test that ABORT is caught
T{ 3 0 ' t10 c6 -> 3 77 }T \ ABORT" does nothing
T{ 4 5 ' t10 c6 -> 4 77 12 }T \ ABORT" caught, no message
T{ TFKEY" <left>" -> K-LEFT <TRUE> }T
T{ TFKEY" <right>" -> K-RIGHT <TRUE> }T
T{ TFKEY" <up>" -> K-UP <TRUE> }T
T{ TFKEY" <down>" -> K-DOWN <TRUE> }T
T{ TFKEY" <home>" -> K-HOME <TRUE> }T
T{ TFKEY" <end>" -> K-END <TRUE> }T
T{ TFKEY" <prior>" -> K-PRIOR <TRUE> }T
T{ TFKEY" <next>" -> K-NEXT <TRUE> }T
T{ TFKEY" <F1>" -> K-F1 <TRUE> }T
T{ TFKEY" <F2>" -> K-F2 <TRUE> }T
T{ TFKEY" <F3>" -> K-F3 <TRUE> }T
T{ TFKEY" <F4>" -> K-F4 <TRUE> }T
T{ TFKEY" <F5>" -> K-F5 <TRUE> }T
T{ TFKEY" <F6>" -> K-F6 <TRUE> }T
T{ TFKEY" <F7>" -> K-F7 <TRUE> }T
T{ TFKEY" <F8>" -> K-F8 <TRUE> }T
T{ TFKEY" <F9>" -> K-F9 <TRUE> }T
T{ TFKEY" <F10>" -> K-F10 <TRUE> }T
T{ TFKEY" <F11>" -> K-F11 <TRUE> }T
T{ TFKEY" <F11>" -> K-F12 <TRUE> }T
T{ TFKEY" <shift-left>" -> K-LEFT K-SHIFT-MASK OR <TRUE> }T
T{ TFKEY" <ctrl-left>" -> K-LEFT K-CTRL-MASK OR <TRUE> }T
T{ TFKEY" <alt-left>" -> K-LEFT K-ALT-MASK OR <TRUE> }T
fatest1.txt", "fatest2.txt" and
"fatest3.txt".
The test F.11.6.1.1010 CREATE-FILE also tests CLOSE-FILE, F.11.6.1.2485 WRITE-LINE also tests W/O and OPEN-FILE, F.11.6.1.2090 READ-LINE includes a test for R/O, F.11.6.1.2142 REPOSITION-FILE includes tests for R/W, WRITE-FILE, READ-FILE, FILE-POSITION, and S". The F.11.6.1.1522 FILE-SIZE test includes a test for BIN. The test F.11.6.1.2147 RESIZE-FILE should then be run followed by the F.11.6.1.1190 DELETE-FILE test.
The F.11.6.1.0080 ( test should be next, followed by F.11.6.1.2218 SOURCE-ID the test which test the extended versions of ( and SOURCE-ID respectively.
Finally F.11.6.2.2130 RENAME-FILE tests the extended words RENAME-FILE, FILE-STATUS, and FLUSH-FILE.
setpad
Note: If anything else is defined
setpad must be called again as the pad may move
T{ fn2 R/W BIN CREATE-FILE SWAP fid2 ! -> 0 }T
T{ PAD 50 fid2 @ WRITE-FILE fid2 @ FLUSH-FILE -> 0 0 }T
T{ fid2 @ FILE-SIZE -> 50. 0 }T
T{ 0. fid2 @ REPOSITION-FILE -> 0 }T
T{ cbuf buf 29 fid2 @ READ-FILE -> 29 0 }T
T{ PAD 29 buf 29 COMPARE -> 0 }T
T{ PAD 30 buf 30 COMPARE -> 1 }T
T{ cbuf buf 29 fid2 @ READ-FILE -> 21 0 }T
T{ PAD 29 + 21 buf 21 COMPARE -> 0 }T
T{ fid2 @ FILE-SIZE DROP fid2 @ FILE-POSITION DROP D= -> <TRUE> }T
T{ buf 10 fid2 @ READ-FILE -> 0 0 }T
T{ fid2 @ CLOSE-FILE -> 0 }T
T{ fn1 R/W OPEN-FILE SWAP fid1 ! -> 0 }T
T{ fid1 @ FILE-SIZE DROP fid1 @ REPOSITION-FILE -> 0 }T
T{ fid1 @ FILE-SIZE -> fid1 @ FILE-POSITION }T
T{ line2 fid1 @ WRITE-FILE -> 0 }T
T{ 10. fid1 @ REPOSITION-FILE -> 0 }T
T{ fid1 @ FILE-POSITION -> 10. 0 }T
T{ 0. fid1 @ REPOSITION-FILE -> 0 }T
T{ rl1 -> line1 SWAP DROP <TRUE> 0 }T
T{ rl1 -> ROT DUP #chars ! }T<TRUE> 0 line2 SWAP DROP
T{ buf #chars @ line2 COMPARE -> 0 }T
T{ rl1 -> 0 <FALSE> 0 }T
T{ fid1 @ FILE-POSITION ROT ROT fp 2! -> 0 }T
T{ fp 2@ fid1 @ FILE-SIZE DROP D= -> <TRUE> }T
T{ S" " fid1 @ WRITE-LINE -> 0 }T
T{ S" " fid1 @ WRITE-LINE -> 0 }T
T{ fp 2@ fid1 @ REPOSITION-FILE -> 0 }T
T{ rl1 -> 0 <TRUE> 0 }T
T{ rl1 -> 0 <TRUE> 0 }T
T{ rl1 -> 0 <FALSE> 0 }T
T{ fid1 @ CLOSE-FILE -> 0 }T
setpad
T{ fn3 DELETE-FILE DROP -> }T
T{ fn1 fn3 RENAME-FILE -> 0 }T
\ Return value is undefined
T{ fn1 FILE-STATUS SWAP DROP 0= -> <FALSE> }T
T{ fn3 FILE-STATUS SWAP DROP 0= -> <TRUE> }T
T{ fn3 R/W OPEN-FILE SWAP fid1 ! -> 0 }T
T{ >end -> 0 }T
T{ S" Final line" fid1 @ WRITE-LINE -> 0 }T
T{ fid1 @ FLUSH-FILE -> 0 }T \ Can only test FLUSH-FILE doesn't fail
T{ fid1 @ CLOSE-FILE -> 0 }T
\ Tidy the test folder
T{ fn3 DELETE-FILE DROP -> }T
required-helper1.fs and
required-helper2.fs.
Both of which hold the text:
As for the test themselves:
T{ 0
S" required-helper1.fs" REQUIRED \ Increment TOS
REQUIRE required-helper1.fs \ Ignore - already loaded
INCLUDE required-helper1.fs \ Increment TOS
-> 2 }T
T{ 0
INCLUDE required-helper2.fs \ Increment TOS
S" required-helper2.fs" REQUIRED \ Ignored - already loaded
REQUIRE required-helper2.fs \ Ignored - already loaded
S" required-helper2.fs" INCLUDED \ Increment TOS
-> 2 }T
The test harness default for EXACT? is TRUE.
Uncomment the following line if your system needs it to
be FALSE
\ SET-NEAR
:NONAME ( c-addr u -- )
( Display an error message followed by the
line that had the error@. )
1 #errors +! error1 ; error-xt !
[UNDEFINED] pi [IF]
0.3141592653589793238463E1 FCONSTANT pi
[THEN]
[UNDEFINED] -pi [IF]
pi FNEGATE FCONSTANT -pi
[THEN]
FALSE [IF]
0.7853981633974483096157E0 FCONSTANT pi/4
-0.7853981633974483096157E0 FCONSTANT -pi/4
0.1570796326794896619231E1 FCONSTANT pi/2
-0.1570796326794896619231E1 FCONSTANT -pi/2
0.4712388980384689857694E1 FCONSTANT 3pi/2
0.2356194490192344928847E1 FCONSTANT 3pi/4
-0.2356194490192344928847E1 FCONSTANT -3pi/4
[ELSE]
pi 4e F/ FCONSTANT pi/4
-pi 4e F/ FCONSTANT -pi/4
pi 2e F/ FCONSTANT pi/2
-pi 2e F/ FCONSTANT -pi/2
pi/2 3e F* FCONSTANT 3pi/2
pi/4 3e F* FCONSTANT 3pi/4
-pi/4 3e F* FCONSTANT -3pi/4
[THEN]
verbose @ [IF]
:NONAME ( -- fp.separate? )
DEPTH >R 1e DEPTH R> FDROP 2R> = ; EXECUTE
CR .( floating-point and data stacks )
[IF] .( *separate* ) [ELSE] .( *not separate* ) [THEN]
CR
[THEN]
TESTING normal values
\ y x rad deg
T{ 0e 1e FATAN2 -> 0e R}T \ 0
T{ 1e 1e FATAN2 -> pi/4 R}T \ 45
T{ 1e 0e FATAN2 -> pi/2 R}T \ 90
T{ -1e -1e FATAN2 -> -3pi/4 R}T \ 135
T{ 0e -1e FATAN2 -> pi R}T \ 180
T{ -1e 1e FATAN2 -> -pi/4 R}T \ 225
T{ -1e 0e FATAN2 -> -pi/2 R}T \ 270
T{ -1e 1e FATAN2 -> -pi/4 R}T \ 315
TESTING Single UNIX 3 special values spec
\ ISO C / Single UNIX Specification Version 3:
\ http://www.unix.org/single_unix_specification/
\ Select "Topic", then "Math Interfaces", then "atan2()":
\ http://www.opengroup.org/onlinepubs/009695399/
\ functions/atan2f.html
\ If y is +/-0 and x is < 0, +/-pi shall be returned.
T{ 0e -1e FATAN2 -> pi R}T
T{ -0e -1e FATAN2 -> -pi R}T
\ If y is +/-0 and x is > 0, +/-0 shall be returned.
T{ 0e 1e FATAN2 -> 0e R}T
T{ -0e 1e FATAN2 -> -0e R}T
\ If y is < 0 and x is +/-0, -pi/2 shall be returned.
T{ -1e 0e FATAN2 -> -pi/2 R}T
T{ -1e -0e FATAN2 -> -pi/2 R}T
\ If y is > 0 and x is +/-0, pi/2 shall be returned.
T{ 1e 0e FATAN2 -> pi/2 R}T
T{ 1e -0e FATAN2 -> pi/2 R}T
TESTING Single UNIX 3 special values optional spec
\ Optional ISO C / single UNIX specs:
\ If either x or y is NaN, a NaN shall be returned.
T{ NaN 1e FATAN2 -> NaN R}T
T{ 1e NaN FATAN2 -> NaN R}T
T{ NaN NaN FATAN2 -> NaN R}T
\ If y is +/-0 and x is -0, +/-pi shall be returned.
T{ 0e -0e FATAN2 -> pi R}T
T{ -0e -0e FATAN2 -> -pi R}T
\ If y is +/-0 and x is +0, +/-0 shall be returned.
T{ 0e 0e FATAN2 -> +0e R}T
T{ -0e 0e FATAN2 -> -0e R}T
\ For finite values of +/-y > 0, if x is -Inf, +/-pi shall be returned.
T{ 1e -Inf FATAN2 -> pi R}T
T{ -1e -Inf FATAN2 -> -pi R}T
\ For finite values of +/-y > 0, if x is +Inf, +/-0 shall be returned.
T{ 1e +Inf FATAN2 -> +0e R}T
T{ -1e +Inf FATAN2 -> -0e R}T
\ For finite values of x, if y is +/-Inf, +/-pi/2 shall be returned.
T{ +Inf 1e FATAN2 -> pi/2 R}T
T{ +Inf -1e FATAN2 -> pi/2 R}T
T{ +Inf 0e FATAN2 -> pi/2 R}T
T{ +Inf -0e FATAN2 -> pi/2 R}T
T{ -Inf 1e FATAN2 -> -pi/2 R}T
T{ -Inf -1e FATAN2 -> -pi/2 R}T
T{ -Inf 0e FATAN2 -> -pi/2 R}T
T{ -Inf -0e FATAN2 -> -pi/2 R}T
\ If y is +/-Inf and x is -Inf, +/-3pi/4 shall be returned.
T{ +Inf -Inf FATAN2 -> 3pi/4 R}T
T{ -Inf -Inf FATAN2 -> -3pi/4 R}T
\ If y is +/-Inf and x is +Inf, +/-pi/4 shall be returned.
T{ +Inf +Inf FATAN2 -> pi/4 R}T
T{ -Inf +Inf FATAN2 -> -pi/4 R}T
SET-EXACT
T{ -0E FTRUNC F0= -> <TRUE> }T
T{ -1E-9 FTRUNC F0= -> <TRUE> }T
T{ -0.9E FTRUNC F0= -> <TRUE> }T
T{ -1E 1E-5 F+ FTRUNC F0= -> <TRUE> }T
T{ 0E FTRUNC -> 0E R}T
T{ 1E-9 FTRUNC -> 0E R}T
T{ -1E -1E-5 F+ FTRUNC -> -1E R}T
T{ 3.14E FTRUNC -> 3E R}T
T{ 3.99E FTRUNC -> 3E R}T
T{ 4E FTRUNC -> 4E R}T
T{ -4E FTRUNC -> -4E R}T
T{ -4.1E FTRUNC -> -4E R}T
: write-cell-mem ( addr n -- )
1+ 1 DO I OVER ! CELL+ LOOP DROP
;
: check-cell-mem ( addr n -- )
1+ 1 DO
I SWAP >R >R
T{ R> ( I ) -> R@ ( addr ) @ }T
R> CELL+
LOOP DROP
;
: write-char-mem ( addr n -- )
1+ 1 DO I OVER C! CHAR+ LOOP DROP
;
: check-char-mem ( addr n -- )
1+ 1 DO
I SWAP >R >R
T{ R> ( I ) -> R@ ( addr ) C@ }T
R> CHAR+
LOOP DROP
;
T{ 50 CELLS ALLOCATE SWAP addr ! -> 0 }T
T{ addr @ ALIGNED -> addr @ }T \ Test address is aligned
T{ HERE -> datsp @ }T \ Check data space pointer is unaffected
addr @ 50 write-cell-mem
addr @ 50 check-cell-mem \ Check we can access the heap
T{ addr @ FREE -> 0 }T
T{ 99 ALLOCATE SWAP addr ! -> 0 }T
T{ addr @ ALIGNED -> addr @ }T \ Test address is aligned
T{ addr @ FREE -> 0 }T
T{ HERE -> datsp @ }T \ Data space pointer unaffected by FREE
T{ -1 ALLOCATE SWAP DROP 0= -> <FALSE> }T \ Memory allocate failed
\ Resize smaller does not change content.
T{ addr @ 28 CHARS RESIZE SWAP addr ! -> 0 }T
addr @ 28 check-char-mem
\ Resize larger does not change original content.
T{ addr @ 100 CHARS RESIZE SWAP addr ! -> 0 }T
addr @ 28 check-char-mem
\ Resize error does not change addr
T{ addr @ -1 RESIZE 0= -> addr @ <FALSE> }T
T{ addr @ FREE -> 0 }T
T{ HERE -> datsp @ }T \ Data space pointer is unaffected
T{ 5 pt6 -> 5 4 3 2 1 }T
: mix_up 2 CS-ROLL ; IMMEDIATE \ cs-rot
: pt7 ( f3 f2 f1 -- ? )
IF 1111 ROT ROT ( -- 1111 f3 f2 ) ( cs: -- o1 )
IF 2222 SWAP ( -- 1111 2222 f3 ) ( cs: -- o1 o2 )
IF ( cs: -- o1 o2 o3 )
3333 mix_up ( -- 1111 2222 3333 ) ( cs: -- o2 o3 o1 )
THEN ( cs: -- o2 o3 )
4444 \ Hence failure of first IF comes here and falls through
THEN ( cs: -- o2 )
5555 \ Failure of 3rd IF comes here
THEN ( cs: -- )
6666 \ Failure of 2nd IF comes here
;
T{ -1 -1 -1 pt7 -> 1111 2222 3333 4444 5555 6666 }T
T{ 0 -1 -1 pt7 -> 1111 2222 5555 6666 }T
T{ 0 0 -1 pt7 -> 1111 0 6666 }T
T{ 0 0 0 pt7 -> 0 0 4444 5555 6666 }T
: [1cs-roll] 1 CS-ROLL ; IMMEDIATE
T{ : pt8
>R
AHEAD 111
BEGIN 222
[1cs-roll]
THEN
333
R> 1- >R
R@ 0<
UNTIL
R> DROP
; -> }T
T{ 1 pt8 -> 333 222 333 }T
\ Check words are immediate
: tfind BL WORD FIND ;
T{ tfind [IF] NIP -> 1 }T
T{ tfind [ELSE] NIP -> 1 }T
T{ tfind [THEN] NIP -> 1 }T
T{ : pt2 [ 0 ] [IF] 1111 [ELSE] 2222 [THEN] ; pt2 -> 2222 }T
T{ : pt3 [ -1 ] [IF] 3333 [ELSE] 4444 [THEN] ; pt3 -> 3333 }T
\ Code spread over more than 1 line
T{ <TRUE> [IF] 1
2
[ELSE]
3
4
[THEN] -> 1 2 }T
T{ <FALSE> [IF]
1 2
[ELSE]
3 4
[THEN] -> 3 4 }T
\ Nested
: <T> <TRUE> ;
: <F> <FALSE> :
T{ <T> [IF] 1 <T> [IF] 2 [ELSE] 3 [THEN] [ELSE] 4 [THEN] -> 1 2 }T
T{ <F> [IF] 1 <T> [IF] 2 [ELSE] 3 [THEN] [ELSE] 4 [THEN] -> 4 }T
T{ <T> [IF] 1 <F> [IF] 2 [ELSE] 3 [THEN] [ELSE] 4 [THEN] -> 1 3 }T
T{ <F> [IF] 1 <F> [IF] 2 [ELSE] 3 [THEN] [ELSE] 4 [THEN] -> 4 }T
Define two word list (wid) variables used by the tests.
In order to test the search order it in necessary to remember the
existing search order before modifying it. The existing search order
is saved and the get-orderlist defined to access it.
CREATE order-list
T{ GET-ORDER save-orderlist -> }T
: get-orderlist ( -- widn ... wid1 n )
order-list DUP @ CELLS ( -- ad n )
OVER + ( -- AD AD' )
?DO I @ -1 CELLS +LOOP ( -- )
;
Having obtained a copy of the current wordlist, the testing of the wordlist can begin with test F.16.6.1.1595 FORTH-WORDLIST followed by F.16.6.1.2197 SET-ORDER which also test GET-ORDER, then F.16.6.2.0715 ALSO and F.16.6.2.1965 ONLY before moving on to F.16.6.1.2195 SET-CURRENT which also test GET-CURRENT and WORDLIST. This should be followed by the test F.16.6.1.1180 DEFINITIONS which also tests PREVIOUS and the F.16.6.1.2192 SEARCH-WORDLIST and F.16.6.1.1550 FIND tests. Finally the F.16.6.2.1985 ORDER test can be performed.
T{ GET-ORDER wid2 @ SWAP 1+ SET-ORDER DEFINITIONS GET-CURRENT
-> wid2 @ }T
T{ GET-ORDER -> get-orderlist wid2 @ SWAP 1+ }T
T{ PREVIOUS GET-ORDER -> get-orderlist }T
T{ DEFINITIONS GET-CURRENT -> FORTH-WORDLIST }T
: alsowid2 ALSO GET-ORDER wid2 @ ROT DROP SWAP SET-ORDER ;
alsowid2
: w1 1234 ;
DEFINITIONS
: w1 -9876 ; IMMEDIATE
ONLY FORTH
T{ w1 -> 1234 }T
DEFINITIONS
T{ w1 -> 1234 }T
alsowid2
T{ w1 -> -9876 }T
DEFINITIONS
T{ w1 -> -9876 }T
ONLY FORTH DEFINITIONS
: so5 DUP IF SWAP EXECUTE THEN ;
T{ S" w1" wid1 @ SEARCH-WORDLIST so5 -> -1 1234 }T
T{ S" w1" wid2 @ SEARCH-WORDLIST so5 -> 1 -9876 }T
: c"w1" C" w1" ;
T{ alsowid2 c"w1" FIND so5 -> 1 -9876 }T
T{ PREVIOUS c"w1" FIND so5 -> -1 1234 }T
T{ WORDLIST wid2 ! -> }T
T{ wid2 @ SET-CURRENT -> }T
T{ GET-CURRENT -> wid2 @ }T
T{ wid1 @ SET-CURRENT -> }T
: so2a GET-ORDER get-orderlist SET-ORDER ;
: so2 0 SET-ORDER so2a ;
T{ so2 -> 0 }T \ 0 SET-ORDER leaves an empty search order
: so3 -1 SET-ORDER so2a ;
: so4 ONLY so2a ;
T{ so3 -> so4 }T \ -1 SET-ORDER is the same as ONLY
CR .( Plus another unnamed wordlist at head of search order) CR
T{ alsowid2 DEFINITIONS ORDER -> }T
T{ : s1 S" abcdefghijklmnopqrstuvwxyz" ; -> }T
The tests should be carried out in the order: F.17.6.1.0245 /STRING, F.17.6.1.2191 SEARCH, F.17.6.1.0170 -TRAILING, F.17.6.1.0935 COMPARE, F.17.6.1.0780 BLANK and F.17.6.1.2212 SLITERAL.
: "abdde" S" abdde" ;
: "abbde" S" abbde" ;
: "abcdf" S" abcdf" ;
: "abcdee" S" abcdee" ;
T{ s1 "abdde" COMPARE -> -1 }T
T{ s1 "abbde" COMPARE -> 1 }T
T{ s1 "abcdf" COMPARE -> -1 }T
T{ s1 "abcdee" COMPARE -> 1 }T
: s11 S" 0abc" ;
: s12 S" 0aBc" ;
T{ s11 s12 COMPARE -> 1 }T
T{ s12 s11 COMPARE -> -1 }T
T{ s1 s2 SEARCH -> s1 <TRUE> }T
T{ s1 s3 SEARCH -> s1 9 /STRING <TRUE> }T
T{ s1 s4 SEARCH -> s1 25 /STRING <TRUE> }T
T{ s1 s5 SEARCH -> s1 <FALSE> }T
T{ s1 s6 SEARCH -> s1 <FALSE> }T
T{ s1 s7 SEARCH -> s1 <TRUE> }T
\ Define a few string constants
: "hi" S" hi" ;
: "wld" S" wld" ;
: "hello" S" hello" ;
: "world" S" world" ;
\ Define a few test strings
: sub1 S" Start: %hi%,%wld%! :End" ; \ Original string
: sub2 S" Start: hello,world! :End" ; \ First target string
: sub3 S" Start: world,hello! :End" ; \ Second target string
\ Define the hi and wld substitutions
T{ "hello" "hi" REPLACES -> }T \ Replace "%hi%" with "hello"
T{ "world" "wld" REPLACES -> }T \ Replace "%wld%" with "world"
\ "%hi%,%wld%" changed to "hello,world"
T{ sub1 subbuff 30 SUBSTITUTE ROT ROT sub2 COMPARE -> 2 0 }T
\ Change the hi and wld substitutions
T{ "world" "hi" REPLACES -> }T
T{ "hello" "wld" REPLACES -> }T
\ Now "%hi%,%wld%" should be changed to "world,hello"
T{ sub1 subbuff 30 SUBSTITUTE ROT ROT sub3 COMPARE -> 2 0 }T
\ Where the subsitution name is not defined
: sub4 S" aaa%bbb%ccc" ;
T{ sub4 subbuff 30 SUBSTITUTE ROT ROT sub4 COMPARE -> 0 0 }T
\ Finally the % character itself
: sub5 S" aaa%%bbb" ;
: sub6 S" aaa%bbb" ;
T{ sub5 subbuff 30 SUBSTITUTE ROT ROT sub6 COMPARE -> 0 0 }T
subbuff, sub5 and sub6 from F.17.6.2.2255 SUBSTITUTE.
T{ sub6 subbuff UNESCAPE sub5 COMPARE -> 0 }T