Annex F: Test Suite
F.1 Introduction
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
F.2 Test Harness
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
F.2.1 Floating-Point
Floating point testing can involve further complications. The harness
attempts to determine whether floating-point support is present, and
if so, whether there is a separate floating-point stack, and behave
accordingly. The
CONSTANTs
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:
SET-NEAR
1E-6 REL-NEAR
F!
T{ S" 3.14159E" >FLOAT -> -1E FACOS <TRUE> RX}T
F.2.2 Error Processing
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.
F.2.3 Source
The following source code provides the test harness.
\ This is the source for the ANS test harness, it is based on the
\ harness originally developed by John Hayes
\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
\ VERSION 1.1
\ Revision history and possibly newer versions can be found at
\ http://www.forth200x/tests/ttester.fs
BASE @
HEX
VARIABLE ACTUAL-DEPTH
\ stack record
CREATE ACTUAL-RESULTS 20
CELLS ALLOT
VARIABLE START-DEPTH
VARIABLE XCURSOR
\ for ...}T
VARIABLE ERROR-XT
: ERROR ERROR-XT
@ EXECUTE ; \ for vectoring of error reporting
: "FLOATING"
S" FLOATING"
; \ only compiled S" in CORE
: "FLOATING-STACK"
S" FLOATING-STACK"
;
"FLOATING"
ENVIRONMENT? [IF]
[IF]
TRUE
[ELSE]
FALSE
[THEN]
[ELSE]
FALSE
[THEN] CONSTANT HAS-FLOATING
"FLOATING-STACK"
ENVIRONMENT? [IF]
[IF]
TRUE
[ELSE]
FALSE
[THEN]
[ELSE] \ We don't know whether the FP stack is separate.
HAS-FLOATING
\ If we have FLOATING, we assume it is.
[THEN] CONSTANT HAS-FLOATING-STACK
HAS-FLOATING
[IF]
\ Set the following to the relative and absolute tolerances you
\ want for approximate float equality, to be used with F in
\ FNEARLY=. Keep the signs, because F needs them.
FVARIABLE REL-NEAR
DECIMAL 1E-12
HEX REL-NEAR
F!
FVARIABLE ABS-NEAR
DECIMAL 0E
HEX ABS-NEAR
F!
\ When EXACT? is TRUE, }F uses FEXACTLY=, otherwise FNEARLY=.
TRUE VALUE EXACT?
: SET-EXACT
( -- )
TRUE TO EXACT?
;
: SET-NEAR
( -- )
FALSE TO EXACT?
;
DECIMAL
: FEXACTLY=
( F: X Y -- S: FLAG )
(
Leave TRUE if the two floats are identical.
)
0E
F~ ;
HEX
: FABS=
( F: X Y -- S: FLAG )
(
Leave TRUE if the two floats are equal within the tolerance
stored in ABS-NEAR.
)
ABS-NEAR
F@ F~ ;
: FREL=
( F: X Y -- S: FLAG )
(
Leave TRUE if the two floats are relatively equal based on the
tolerance stored in ABS-NEAR.
)
REL-NEAR
F@ FNEGATE F~ ;
: F2DUP
FOVER FOVER ;
: F2DROP
FDROP FDROP ;
: FNEARLY=
( F: X Y -- S: FLAG )
(
Leave TRUE if the two floats are nearly equal. This is a
refinement of Dirk Zoller's FEQ to also allow X = Y, including
both zero, or to allow approximately equality when X and Y are too
small to satisfy the relative approximation mode in the F~
specification.
)
F2DUP FEXACTLY=
IF F2DROP
TRUE EXIT THEN
F2DUP FREL=
IF F2DROP
TRUE EXIT THEN
FABS=
;
: FCONF=
( R1 R2 -- F )
EXACT?
IF
FEXACTLY=
ELSE
FNEARLY=
THEN ;
[THEN]
HAS-FLOATING-STACK
[IF]
VARIABLE ACTUAL-FDEPTH
CREATE ACTUAL-FRESULTS 20
FLOATS ALLOT
VARIABLE START-FDEPTH
VARIABLE FCURSOR
: EMPTY-FSTACK
( ... -- ... )
FDEPTH START-FDEPTH
@ < IF
FDEPTH START-FDEPTH
@ SWAP DO 0E
LOOP
THEN
FDEPTH START-FDEPTH
@ > IF
FDEPTH START-FDEPTH
@ DO FDROP LOOP
THEN ;
: F{
( -- )
FDEPTH START-FDEPTH
! 0 FCURSOR
! ;
: F->
( ... -- ... )
FDEPTH DUP ACTUAL-FDEPTH
!
START-FDEPTH
@ > IF
FDEPTH START-FDEPTH
@ - 0
DO ACTUAL-FRESULTS
I FLOATS + F! LOOP
THEN ;
: F}
( ... -- ... )
FDEPTH ACTUAL-FDEPTH
@ = IF
FDEPTH START-FDEPTH
@ > IF
FDEPTH START-FDEPTH
@ - 0
DO
ACTUAL-FRESULTS
I FLOATS + F@ FCONF=
INVERT IF
S" INCORRECT FP RESULT: " ERROR
LEAVE
THEN
LOOP
THEN
ELSE
S" WRONG NUMBER OF FP RESULTS: " ERROR
THEN ;
: F...}T
( -- )
FCURSOR
@ START-FDEPTH
@ + ACTUAL-FDEPTH
@ <> IF
S" NUMBER OF FLOAT RESULTS BEFORE '->' DOES NOT MATCH ...}T "
S" SPECIFICATION: " ERROR
ELSE FDEPTH START-FDEPTH
@ = 0= IF
S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: "
ERROR
THEN THEN ;
: FTESTER
( R -- )
FDEPTH 0= ACTUAL-FDEPTH
@ FCURSOR
@ START-FDEPTH
@ + 1+ < OR IF
S" NUMBER OF FLOAT RESULTS AFTER '->' BELOW ...}T SPECIFICATION: "
ERROR
ELSE ACTUAL-FRESULTS FCURSOR
@ FLOATS + F@ FCONF=
0= IF
S" INCORRECT FP RESULT: " ERROR
THEN THEN
1 FCURSOR
+! ;
[ELSE]
: EMPTY-FSTACK
;
: F{
;
: F->
;
: F}
;
: F...}T
;
HAS-FLOATING
[IF]
DECIMAL
: COMPUTE-CELLS-PER-FP
( -- U )
DEPTH 0E
DEPTH 1- >R FDROP R> SWAP - ;
HEX
COMPUTE-CELLS-PER-FP
CONSTANT CELLS-PER-FP
: FTESTER
( R -- )
DEPTH CELLS-PER-FP
<
ACTUAL-DEPTH
@ XCURSOR
@ START-DEPTH
@ + CELLS-PER-FP
+ <
OR IF
S" NUMBER OF RESULTS AFTER '->' BELOW ...}T SPECIFICATION: "
ERROR
EXIT
ELSE ACTUAL-RESULTS XCURSOR
@ CELLS + F@ FCONF=
0= IF
S" INCORRECT FP RESULT: " ERROR
THEN THEN
CELLS-PER-FP XCURSOR
+! ;
[THEN]
[THEN]
: EMPTY-STACK
\ ( ... -- ) empty stack; handles underflowed stack too.
DEPTH START-DEPTH
@ < IF
DEPTH START-DEPTH
@ SWAP DO 0
LOOP
THEN
DEPTH START-DEPTH
@ > IF
DEPTH START-DEPTH
@ DO DROP LOOP
THEN
EMPTY-FSTACK
;
: ERROR1
\ ( C-ADDR U -- ) display an error message
\ followed by the line that had the error.
TYPE SOURCE TYPE CR \ display line corresponding to error
EMPTY-STACK
\ throw away everything else
;
' ERROR1 ERROR-XT
!
: T{
\ ( -- ) record the pre-test depth.
DEPTH START-DEPTH
! 0 XCURSOR
! F{
;
: ->
\ ( ... -- ) record depth and contents of stack.
DEPTH DUP ACTUAL-DEPTH
! \ record depth
START-DEPTH
@ > IF \ if there is something on the stack
DEPTH START-DEPTH
@ - 0
DO \ save them
ACTUAL-RESULTS
I CELLS + !
LOOP
THEN
F->
;
: }T
\ ( ... -- ) comapre stack (expected) contents with saved
\ (actual) contents.
DEPTH ACTUAL-DEPTH
@ = IF \ if depths match
DEPTH START-DEPTH
@ > IF \ if something on the stack
DEPTH START-DEPTH
@ - 0
DO \ for each stack item
ACTUAL-RESULTS
I CELLS + @ \ compare actual with expected
<> IF S" INCORRECT RESULT: " ERROR
LEAVE THEN
LOOP
THEN
ELSE \ depth mismatch
S" WRONG NUMBER OF RESULTS: " ERROR
THEN
F}
;
: ...}T
( -- )
XCURSOR
@ START-DEPTH
@ + ACTUAL-DEPTH
@ <> IF
S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T "
S" SPECIFICATION: " ERROR
ELSE DEPTH START-DEPTH
@ = 0= IF
S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: "
ERROR
THEN THEN
F...}T
;
: XTESTER
( X -- )
DEPTH 0= ACTUAL-DEPTH
@ XCURSOR
@ START-DEPTH
@ + 1+ < OR IF
S" NUMBER OF CELL RESULTS AFTER '->' BELOW ...}T SPECIFICATION: "
ERROR
EXIT
ELSE ACTUAL-RESULTS XCURSOR
@ CELLS + @ <> IF
S" INCORRECT CELL RESULT: " ERROR
THEN THEN
1 XCURSOR
+! ;
: X}T XTESTER ...}T
;
: XX}T XTESTER XTESTER ...}T
;
: XXX}T XTESTER XTESTER XTESTER ...}T
;
: XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T
;
HAS-FLOATING
[IF]
: R}T FTESTER ...}T
;
: XR}T FTESTER XTESTER ...}T
;
: RX}T XTESTER FTESTER ...}T
;
: RR}T FTESTER FTESTER ...}T
;
: XXR}T FTESTER XTESTER XTESTER ...}T
;
: XRX}T XTESTER FTESTER XTESTER ...}T
;
: XRR}T FTESTER FTESTER XTESTER ...}T
;
: RXX}T XTESTER XTESTER FTESTER ...}T
;
: RXR}T FTESTER XTESTER FTESTER ...}T
;
: RRX}T XTESTER FTESTER FTESTER ...}T
;
: RRR}T FTESTER FTESTER FTESTER ...}T
;
: XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T
;
: XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T
;
: XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T
;
: XRXX}T XTESTER XTESTER FTESTER XTESTER ...}T
;
: XRXR}T FTESTER XTESTER FTESTER XTESTER ...}T
;
: XRRX}T XTESTER FTESTER FTESTER XTESTER ...}T
;
: XRRR}T FTESTER FTESTER FTESTER XTESTER ...}T
;
: RXXX}T XTESTER XTESTER XTESTER FTESTER ...}T
;
: RXXR}T FTESTER XTESTER XTESTER FTESTER ...}T
;
: RXRX}T XTESTER FTESTER XTESTER FTESTER ...}T
;
: RXRR}T FTESTER FTESTER XTESTER FTESTER ...}T
;
: RRXX}T XTESTER XTESTER FTESTER FTESTER ...}T
;
: RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T
;
: RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T
;
: RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T
;
[THEN]
\ Set the following flag to TRUE for more verbose output; this may
\ allow you to tell which test caused your system to hang.
VARIABLE VERBOSE
FALSE VERBOSE
!
: TESTING
\ ( -- ) TALKING COMMENT.
SOURCE VERBOSE
@
IF DUP >R TYPE CR R> >IN !
ELSE >IN ! DROP
THEN ;
BASE !
F.3 Core Tests
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.
F.3.1 Basic Assumptions
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
F.3.2 Booleans
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.
F.3.3 Shifts
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:
T{ MSB BITSSET? -> 0 0 }T
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.
F.3.4 Numeric notation
The numeric representation can be tested with the following test cases:
DECIMAL
T{ #1289 -> 1289 }T
T{ #12346789. -> 12346789. }T
T{ #-1289 -> -1289 }T
T{ #-12346789. -> -12346789. }T
T{ $12eF -> 4847 }T
T{ $12aBcDeF. -> 313249263. }T
T{ $-12eF -> -4847 }T
T{ $-12AbCdEf. -> -313249263. }T
T{ %10010110 -> 150 }T
T{ %10010110. -> 150. }T
T{ %-10010110 -> -150 }T
T{ %-10010110. -> -150. }T
T{ 'z' -> 122 }T
F.3.5 Comparisons
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.
F.3.6 Stack Operators
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.
F.3.7 Return Stack Operators
The test
F.6.1.0580 >R will test all three basic return
stack operators (
>R,
R>, and
R@).
F.3.8 Addition and Subtraction
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.
F.3.9 Multiplication
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*.
F.3.10 Division
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.
F.3.11 Memory
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.
F.3.12 Characters
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".
F.3.13 Dictionary
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
F.3.14 Flow Control
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.
F.3.15 Counted Loops
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.
F.3.16 Defining Words
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.
F.3.17 Evaluate
As with the defining words,
F.6.1.1360 EVALUATE has
already been used, but it must still be tested fully.
F.3.18 Parser Input Source Control
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.
F.3.19 Number Patterns
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.
F.3.20 Memory Movement
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.
F.3.21 Output
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..
F.3.22 Input
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.
F.3.23 Dictionary Search Rules
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
F.6 The Core word set
: GP3 <# 1 0 # # #> S" 01" S= ;
T{ GP3 -> <TRUE> }T
T{ : GT1 123 ; -> }T
T{ ' GT1 EXECUTE -> 123 }T
\ There is no space either side of the ).
T{ ( A comment)1234 -> }T
T{ : pc1 ( A comment)1234 ; pc1 -> 1234 }T
T{ 0 0 * -> 0 }T \ TEST IDENTITIE\S
T{ 0 1 * -> 0 }T
T{ 1 0 * -> 0 }T
T{ 1 2 * -> 2 }T
T{ 2 1 * -> 2 }T
T{ 3 3 * -> 9 }T
T{ -3 3 * -> -9 }T
T{ 3 -3 * -> -9 }T
T{ -3 -3 * -> 9 }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
IFFLOORED
: T*/ T*/MOD
SWAP DROP ;
IFSYM
: T*/ T*/MOD
SWAP DROP ;
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
IFFLOORED
: T*/MOD
>R M* R> FM/MOD ;
IFSYM
: T*/MOD
>R M* R> SM/REM ;
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
T{ 0 5 + -> 5 }T
T{ 5 0 + -> 5 }T
T{ 0 -5 + -> -5 }T
T{ -5 0 + -> -5 }T
T{ 1 2 + -> 3 }T
T{ 1 -2 + -> -1 }T
T{ -1 2 + -> 1 }T
T{ -1 -2 + -> -3 }T
T{ -1 1 + -> 0 }T
T{ MID-UINT 1 + -> MID-UINT+1 }T
T{ 0 1ST ! -> }T
T{ 1 1ST +! -> }T
T{ 1ST @ -> 1 }T
T{ -1 1ST +! 1ST @ -> 0 }T
T{ : GD2 DO I -1 +LOOP ; -> }T
T{ 1 4 GD2 -> 4 3 2 1 }T
T{ -1 2 GD2 -> 2 1 0 -1 }T
T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }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
HERE 1
,
HERE 2
,
CONSTANT 2ND
CONSTANT 1ST
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
T{ 0 5 - -> -5 }T
T{ 5 0 - -> 5 }T
T{ 0 -5 - -> 5 }T
T{ -5 0 - -> -5 }T
T{ 1 2 - -> -1 }T
T{ 1 -2 - -> 3 }T
T{ -1 2 - -> -3 }T
T{ -1 -2 - -> 1 }T
T{ 0 1 - -> -1 }T
T{ MID-UINT+1 1 - -> MID-UINT }T
IFFLOORED
: T/ T/MOD
SWAP DROP ;
IFSYM
: T/ T/MOD
SWAP DROP ;
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
IFFLOORED
: T/MOD
>R S>D R> FM/MOD ;
IFSYM
: T/MOD
>R S>D R> SM/REM ;
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{ 0 0< -> <FALSE> }T
T{ -1 0< -> <TRUE> }T
T{ MIN-INT 0< -> <TRUE> }T
T{ 1 0< -> <FALSE> }T
T{ MAX-INT 0< -> <FALSE> }T
T{ 0 0= -> <TRUE> }T
T{ 1 0= -> <FALSE> }T
T{ 2 0= -> <FALSE> }T
T{ -1 0= -> <FALSE> }T
T{ MAX-UINT 0= -> <FALSE> }T
T{ MIN-INT 0= -> <FALSE> }T
T{ MAX-INT 0= -> <FALSE> }T
T{ 0 1+ -> 1 }T
T{ -1 1+ -> 0 }T
T{ 1 1+ -> 2 }T
T{ MID-UINT 1+ -> MID-UINT+1 }T
T{ 2 1- -> 1 }T
T{ 1 1- -> 0 }T
T{ 0 1- -> -1 }T
T{ MID-UINT+1 1- -> MID-UINT }T
T{ 0S 2* -> 0S }T
T{ 1 2* -> 2 }T
T{ 4000 2* -> 8000 }T
T{ 1S 2* 1 XOR -> 1S }T
T{ MSB 2* -> 0S }T
T{ 0S 2/ -> 0S }T
T{ 1 2/ -> 0 }T
T{ 4000 2/ -> 2000 }T
T{ 1S 2/ -> 1S }T \ MSB PROPOGATED
T{ 1S 1 XOR 2/ -> 1S }T
T{ MSB 2/ MSB AND -> MSB }T
T{ 1 2 2DUP -> 1 2 1 2 }T
T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T
T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T
T{ : NOP : POSTPONE ; ; -> }T
T{ NOP NOP1 NOP NOP2 -> }T
T{ NOP1 -> }T
T{ NOP2 -> }T
The following tests the dictionary search order:
T{ : GDX 123 ; : GDX GDX 234 ; -> }T
T{ GDX -> 123 234 }T
T{ 0 1 < -> <TRUE> }T
T{ 1 2 < -> <TRUE> }T
T{ -1 0 < -> <TRUE> }T
T{ -1 1 < -> <TRUE> }T
T{ MIN-INT 0 < -> <TRUE> }T
T{ MIN-INT MAX-INT < -> <TRUE> }T
T{ 0 MAX-INT < -> <TRUE> }T
T{ 0 0 < -> <FALSE> }T
T{ 1 1 < -> <FALSE> }T
T{ 1 0 < -> <FALSE> }T
T{ 2 1 < -> <FALSE> }T
T{ 0 -1 < -> <FALSE> }T
T{ 1 -1 < -> <FALSE> }T
T{ 0 MIN-INT < -> <FALSE> }T
T{ MAX-INT MIN-INT < -> <FALSE> }T
T{ MAX-INT 0 < -> <FALSE> }T
T{ 0 0 = -> <TRUE> }T
T{ 1 1 = -> <TRUE> }T
T{ -1 -1 = -> <TRUE> }T
T{ 1 0 = -> <FALSE> }T
T{ -1 0 = -> <FALSE> }T
T{ 0 1 = -> <FALSE> }T
T{ 0 -1 = -> <FALSE> }T
T{ 0 1 > -> <FALSE> }T
T{ 1 2 > -> <FALSE> }T
T{ -1 0 > -> <FALSE> }T
T{ -1 1 > -> <FALSE> }T
T{ MIN-INT 0 > -> <FALSE> }T
T{ MIN-INT MAX-INT > -> <FALSE> }T
T{ 0 MAX-INT > -> <FALSE> }T
T{ 0 0 > -> <FALSE> }T
T{ 1 1 > -> <FALSE> }T
T{ 1 0 > -> <TRUE> }T
T{ 2 1 > -> <TRUE> }T
T{ 0 -1 > -> <TRUE> }T
T{ 1 -1 > -> <TRUE> }T
T{ 0 MIN-INT > -> <TRUE> }T
T{ MAX-INT MIN-INT > -> <TRUE> }T
T{ MAX-INT 0 > -> <TRUE> }T
CREATE GN-BUF 0
C,
: GN-STRING GN-BUF 1
;
: GN-CONSUMED GN-BUF
CHAR+ 0
;
: GN'
[CHAR] '
WORD CHAR+ C@ GN-BUF
C! GN-STRING
;
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{ : GR1 >R R> ; -> }T
T{ : GR2 >R R@ R> DROP ; -> }T
T{ 123 GR1 -> 123 }T
T{ 123 GR2 -> 123 }T
T{ 1S GR1 -> 1S }T ( Return stack holds cells )
T{ -1 ?DUP -> -1 -1 }T
T{ 0 ?DUP -> 0 }T
T{ 1 ?DUP -> 1 1 }T
T{ 0 ABS -> 0 }T
T{ 1 ABS -> 1 }T
T{ -1 ABS -> 1 }T
T{ MIN-INT ABS -> MID-UINT+1 }T
HERE 1
ALLOT
HERE
CONSTANT 2NDA
CONSTANT 1STA
T{ 1STA 2NDA U< -> <TRUE> }T \ HERE MUST GROW WITH ALLOT
T{ 1STA 1+ -> 2NDA }T \ ... BY ONE ADDRESS UNIT
( MISSING TEST: NEGATIVE ALLOT )
T{ 0 0 AND -> 0 }T
T{ 0 1 AND -> 0 }T
T{ 1 0 AND -> 0 }T
T{ 1 1 AND -> 1 }T
T{ 0 INVERT 1 AND -> 1 }T
T{ 1 INVERT 1 AND -> 0 }T
T{ 0S 0S AND -> 0S }T
T{ 0S 1S AND -> 0S }T
T{ 1S 0S AND -> 0S }T
T{ 1S 1S AND -> 1S }T
HERE 1
C,
HERE 2
C,
CONSTANT 2NDC
CONSTANT 1STC
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{ CHAR X -> 58 }T
T{ CHAR HELLO -> 48 }T
( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS )
T{ 1 CHARS 1 < -> <FALSE> }T
T{ 1 CHARS 1 CELLS > -> <FALSE> }T
( TBD: HOW TO FIND NUMBER OF BITS? )
T{ 123 CONSTANT X123 -> }T
T{ X123 -> 123 }T
T{ : EQU CONSTANT ; -> }T
T{ X123 EQU Y123 -> }T
T{ Y123 -> 123 }T
T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T
T{ 0 1 DEPTH -> 0 1 2 }T
T{ 0 DEPTH -> 0 1 }T
T{ DEPTH -> 0 }T
T{ : DOES1 DOES> @ 1 + ; -> }T
T{ : DOES2 DOES> @ 2 + ; -> }T
T{ CREATE CR1 -> }T
T{ CR1 -> HERE }T
T{ 1 , -> }T
T{ CR1 @ -> 1 }T
T{ DOES1 -> }T
T{ CR1 -> 2 }T
T{ DOES2 -> }T
T{ CR1 -> 3 }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{ 1 2 DROP -> 1 }T
T{ 0 DROP -> }T
\ should be the same for any query starting with X:
T{ S" X:deferred" ENVIRONMENT? DUP 0= XOR INVERT -> <TRUE> }T
T{ S" X:notfound" ENVIRONMENT? DUP 0= XOR INVERT -> <FALSE> }T
: GE1
S" 123"
; IMMEDIATE
: GE2
S" 123 1+"
; IMMEDIATE
: GE3
S" : GE4 345
;"
;
: GE5
EVALUATE ; IMMEDIATE
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 0 20 FILL -> }T
T{ SEEBUF -> 00 00 00 }T
T{ FBUF 1 20 FILL -> }T
T{ SEEBUF -> 20 00 00 }T
T{ FBUF 3 20 FILL -> }T
T{ SEEBUF -> 20 20 20 }T
T{ 0 S>D 1 FM/MOD -> 0 0 }T
T{ 1 S>D 1 FM/MOD -> 0 1 }T
T{ 2 S>D 1 FM/MOD -> 0 2 }T
T{ -1 S>D 1 FM/MOD -> 0 -1 }T
T{ -2 S>D 1 FM/MOD -> 0 -2 }T
T{ 0 S>D -1 FM/MOD -> 0 0 }T
T{ 1 S>D -1 FM/MOD -> 0 -1 }T
T{ 2 S>D -1 FM/MOD -> 0 -2 }T
T{ -1 S>D -1 FM/MOD -> 0 1 }T
T{ -2 S>D -1 FM/MOD -> 0 2 }T
T{ 2 S>D 2 FM/MOD -> 0 1 }T
T{ -1 S>D -1 FM/MOD -> 0 1 }T
T{ -2 S>D -2 FM/MOD -> 0 1 }T
T{ 7 S>D 3 FM/MOD -> 1 2 }T
T{ 7 S>D -3 FM/MOD -> -2 -3 }T
T{ -7 S>D 3 FM/MOD -> 2 -3 }T
T{ -7 S>D -3 FM/MOD -> -1 2 }T
T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T
T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T
T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T
T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T
T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T
T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T
T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T
T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T
T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T
T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T
T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T
T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T
T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T
T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T
T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T
T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T
T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T
: GP1
<# 41
HOLD 42
HOLD 0 0
#> S" BA" S=
;
T{ GP1 -> <TRUE> }T
T{ : GI1 IF 123 THEN ; -> }T
T{ : GI2 IF 123 ELSE 234 THEN ; -> }T
T{ 0 GI1 -> }T
T{ 1 GI1 -> 123 }T
T{ -1 GI1 -> 123 }T
T{ 0 GI2 -> 234 }T
T{ 1 GI2 -> 123 }T
T{ -1 GI1 -> 123 }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{ 0S INVERT -> 1S }T
T{ 1S INVERT -> 0S }T
T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T
T{ 4 1 GD3 -> 1 2 3 }T
T{ 2 -1 GD3 -> -1 0 1 }T
T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T
T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T
T{ 1 4 GD4 -> 4 3 2 1 }T
T{ -1 2 GD4 -> 2 1 0 -1 }T
T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T
T{ : GD5 123 SWAP 0 DO
I 4 > IF DROP 234 LEAVE THEN
LOOP ; -> }T
T{ 1 GD5 -> 123 }T
T{ 5 GD5 -> 123 }T
T{ 6 GD5 -> 234 }T
T{ : GT3 GT2 LITERAL ; -> }T
T{ GT3 -> ' GT1 }T
T{ : GD1 DO I LOOP ; -> }T
T{ 4 1 GD1 -> 1 2 3 }T
T{ 2 -1 GD1 -> -1 0 1 }T
T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T
T{ 1 0 LSHIFT -> 1 }T
T{ 1 1 LSHIFT -> 2 }T
T{ 1 2 LSHIFT -> 4 }T
T{ 1 F LSHIFT -> 8000 }T \ BIGGEST GUARANTEED SHIFT
T{ 1S 1 LSHIFT 1 XOR -> 1S }T
T{ MSB 1 LSHIFT -> 0 }T
T{ 0 0 M* -> 0 S>D }T
T{ 0 1 M* -> 0 S>D }T
T{ 1 0 M* -> 0 S>D }T
T{ 1 2 M* -> 2 S>D }T
T{ 2 1 M* -> 2 S>D }T
T{ 3 3 M* -> 9 S>D }T
T{ -3 3 M* -> -9 S>D }T
T{ 3 -3 M* -> -9 S>D }T
T{ -3 -3 M* -> 9 S>D }T
T{ 0 MIN-INT M* -> 0 S>D }T
T{ 1 MIN-INT M* -> MIN-INT S>D }T
T{ 2 MIN-INT M* -> 0 1S }T
T{ 0 MAX-INT M* -> 0 S>D }T
T{ 1 MAX-INT M* -> MAX-INT S>D }T
T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T
T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T
T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T
T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T
T{ 0 1 MAX -> 1 }T
T{ 1 2 MAX -> 2 }T
T{ -1 0 MAX -> 0 }T
T{ -1 1 MAX -> 1 }T
T{ MIN-INT 0 MAX -> 0 }T
T{ MIN-INT MAX-INT MAX -> MAX-INT }T
T{ 0 MAX-INT MAX -> MAX-INT }T
T{ 0 0 MAX -> 0 }T
T{ 1 1 MAX -> 1 }T
T{ 1 0 MAX -> 1 }T
T{ 2 1 MAX -> 2 }T
T{ 0 -1 MAX -> 0 }T
T{ 1 -1 MAX -> 1 }T
T{ 0 MIN-INT MAX -> 0 }T
T{ MAX-INT MIN-INT MAX -> MAX-INT }T
T{ MAX-INT 0 MAX -> MAX-INT }T
T{ 0 1 MIN -> 0 }T
T{ 1 2 MIN -> 1 }T
T{ -1 0 MIN -> -1 }T
T{ -1 1 MIN -> -1 }T
T{ MIN-INT 0 MIN -> MIN-INT }T
T{ MIN-INT MAX-INT MIN -> MIN-INT }T
T{ 0 MAX-INT MIN -> 0 }T
T{ 0 0 MIN -> 0 }T
T{ 1 1 MIN -> 1 }T
T{ 1 0 MIN -> 0 }T
T{ 2 1 MIN -> 1 }T
T{ 0 -1 MIN -> -1 }T
T{ 1 -1 MIN -> -1 }T
T{ 0 MIN-INT MIN -> MIN-INT }T
T{ MAX-INT MIN-INT MIN -> MIN-INT }T
T{ MAX-INT 0 MIN -> 0 }T
IFFLOORED
: TMOD T/MOD
DROP ;
IFSYM
: TMOD T/MOD
DROP ;
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{ FBUF FBUF 3 CHARS MOVE -> }T \ BIZARRE SPECIAL CASE
T{ SEEBUF -> 20 20 20 }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
T{ 0 NEGATE -> 0 }T
T{ 1 NEGATE -> -1 }T
T{ -1 NEGATE -> 1 }T
T{ 2 NEGATE -> -2 }T
T{ -2 NEGATE -> 2 }T
T{ 0S 0S OR -> 0S }T
T{ 0S 1S OR -> 1S }T
T{ 1S 0S OR -> 1S }T
T{ 1S 1S OR -> 1S }T
T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T
T{ : GT5 GT4 ; -> }T
T{ GT5 -> 123 }T
T{ : GT6 345 ; IMMEDIATE -> }T
T{ : GT7 POSTPONE GT6 ; -> }T
T{ GT7 -> 345 }T
T{ 1 0 RSHIFT -> 1 }T
T{ 1 1 RSHIFT -> 0 }T
T{ 2 1 RSHIFT -> 1 }T
T{ 4 2 RSHIFT -> 1 }T
T{ 8000 F RSHIFT -> 1 }T \ Biggest
T{ MSB 1 RSHIFT MSB AND -> 0 }T \ RSHIFT
zero fills MSBs
T{ MSB 1 RSHIFT 2* -> MSB }T
T{ 0 S>D -> 0 0 }T
T{ 1 S>D -> 1 0 }T
T{ 2 S>D -> 2 0 }T
T{ -1 S>D -> -1 -1 }T
T{ -2 S>D -> -2 -1 }T
T{ MIN-INT S>D -> MIN-INT -1 }T
T{ MAX-INT S>D -> MAX-INT 0 }T
: GP2
<# -1
SIGN 0
SIGN -1
SIGN 0 0
#> S" --" S=
;
T{ GP2 -> <TRUE> }T
T{ 0 S>D 1 SM/REM -> 0 0 }T
T{ 1 S>D 1 SM/REM -> 0 1 }T
T{ 2 S>D 1 SM/REM -> 0 2 }T
T{ -1 S>D 1 SM/REM -> 0 -1 }T
T{ -2 S>D 1 SM/REM -> 0 -2 }T
T{ 0 S>D -1 SM/REM -> 0 0 }T
T{ 1 S>D -1 SM/REM -> 0 -1 }T
T{ 2 S>D -1 SM/REM -> 0 -2 }T
T{ -1 S>D -1 SM/REM -> 0 1 }T
T{ -2 S>D -1 SM/REM -> 0 2 }T
T{ 2 S>D 2 SM/REM -> 0 1 }T
T{ -1 S>D -1 SM/REM -> 0 1 }T
T{ -2 S>D -2 SM/REM -> 0 1 }T
T{ 7 S>D 3 SM/REM -> 1 2 }T
T{ 7 S>D -3 SM/REM -> 1 -2 }T
T{ -7 S>D 3 SM/REM -> 1 -2 }T
T{ -7 S>D -3 SM/REM -> -1 2 }T
T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T
T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T
T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T
T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T
T{ 1S 1 4 SM/REM -> 3 MAX-INT }T
T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T
T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T
T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T
T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T
T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T
T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T
T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T
T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T
T{ 0 1 U< -> <TRUE> }T
T{ 1 2 U< -> <TRUE> }T
T{ 0 MID-UINT U< -> <TRUE> }T
T{ 0 MAX-UINT U< -> <TRUE> }T
T{ MID-UINT MAX-UINT U< -> <TRUE> }T
T{ 0 0 U< -> <FALSE> }T
T{ 1 1 U< -> <FALSE> }T
T{ 1 0 U< -> <FALSE> }T
T{ 2 1 U< -> <FALSE> }T
T{ MID-UINT 0 U< -> <FALSE> }T
T{ MAX-UINT 0 U< -> <FALSE> }T
T{ MAX-UINT MID-UINT U< -> <FALSE> }T
T{ 0 0 UM* -> 0 0 }T
T{ 0 1 UM* -> 0 0 }T
T{ 1 0 UM* -> 0 0 }T
T{ 1 2 UM* -> 2 0 }T
T{ 2 1 UM* -> 2 0 }T
T{ 3 3 UM* -> 9 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{ 0 0 1 UM/MOD -> 0 0 }T
T{ 1 0 1 UM/MOD -> 0 1 }T
T{ 1 0 2 UM/MOD -> 1 0 }T
T{ 3 0 2 UM/MOD -> 1 1 }T
T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T
T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T
T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T
T{ : GD6 ( PAT: {0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} )
0 SWAP 0 DO
I 1+ 0 DO
I J + 3 = IF
I UNLOOP I UNLOOP EXIT THEN 1+
LOOP
LOOP ; -> }T
T{ 1 GD6 -> 1 }T
T{ 2 GD6 -> 3 }T
T{ 3 GD6 -> 4 1 2 }T
T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T
T{ 3 GI4 -> 3 4 5 6 }T
T{ 5 GI4 -> 5 6 }T
T{ 6 GI4 -> 6 7 }T
T{ VARIABLE V1 -> }T
T{ 123 V1 ! -> }T
T{ V1 @ -> 123 }T
T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T
T{ 0 GI3 -> 0 1 2 3 4 5 }T
T{ 4 GI3 -> 4 5 }T
T{ 5 GI3 -> 5 }T
T{ 6 GI3 -> 6 }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
T{ 0S 0S XOR -> 0S }T
T{ 0S 1S XOR -> 1S }T
T{ 1S 0S XOR -> 1S }T
T{ 1S 1S XOR -> 0S }T
T{ : GC1 [CHAR] X ; -> }T
T{ : GC2 [CHAR] HELLO ; -> }T
T{ GC1 -> 58 }T
T{ GC2 -> 48 }T
DECIMAL
: 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
T{ DEFER defer1 -> }T
T{ : action-defer1 ACTION-OF defer1 ; -> }T
T{ ' * ' defer1 DEFER! -> }T
T{ 2 3 defer1 -> 6 }T
T{ ACTION-OF defer1 -> ' * }T
T{ action-defer1 -> ' * }T
T{ ' + IS defer1 -> }T
T{ 1 2 defer1 -> 3 }T
T{ ACTION-OF defer1 -> ' + }T
T{ action-defer1 -> ' + }T
T{ DEFER defer2 -> }T
T{ ' * ' defer2 DEFER! -> }T
T{ 2 3 defer2 -> 6 }T
T{ ' + IS defer2 -> }T
T{ 1 2 defer2 -> 3 }T
T{ DEFER defer3 -> }T
T{ ' * ' defer3 DEFER! -> }T
T{ 2 3 defer3 -> 6 }T
T{ ' + ' defer3 DEFER! -> }T
T{ 1 2 defer3 -> 3 }T
T{ DEFER defer4 -> }T
T{ ' * ' defer4 DEFER! -> }T
T{ 2 3 defer4 -> 6 }T
T{ ' defer4 DEFER@ -> ' * }T
T{ ' + IS defer4 -> }T
T{ 1 2 defer4 -> 3 }T
T{ ' defer4 DEFER@ -> ' + }T
T{ FALSE -> 0 }T
T{ FALSE -> <FALSE> }T
T{ DEFER defer5 -> }T
T{ : is-defer5 IS defer5 ; -> }T
T{ ' * IS defer5 -> }T
T{ 2 3 defer5 -> 6 }T
T{ ' + is-defer5 -> }T
T{ 1 2 defer5 -> 3 }T
T{ PARSE-NAME abcd S" abcd" S= -> <TRUE> }T
T{ PARSE-NAME abcde S" abcde" S= -> <TRUE> }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
T{ TRUE -> <TRUE> }T
T{ TRUE -> 0 INVERT }T
T{ 111 VALUE v1 -> }T
T{ -999 VALUE v2 -> }T
T{ v1 -> 111 }T
T{ v2 -> -999 }T
T{ 222 TO v1 -> }T
T{ v1 -> 222 }T
T{ : vd1 v1 ; -> }T
T{ vd1 -> 222 }T
T{ : vd2 TO v2 ; -> }T
T{ v2 -> -999 }T
T{ -333 vd2 -> }T
T{ v2 -> -333 }T
T{ v1 -> 222 }T
With default compilation semantics
T{ : [c1] [COMPILE] DUP ; IMMEDIATE -> }T
T{ 123 [c1] -> 123 123 }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
F.8 The optional Double-Number word set
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.
F.8.3.2 Text interpreter input number conversion
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{ 1 2 2CONSTANT 2c1 -> }T
T{ 2c1 -> 1 2 }T
T{ : cd1 2c1 ; -> }T
T{ cd1 -> 1 2 }T
T{ : cd2 2CONSTANT ; -> }T
T{ -1 -2 cd2 2c2 -> }T
T{ 2c2 -> -1 -2 }T
T{ 4 5 2CONSTANT 2c3 IMMEDIATE 2c3 -> 4 5 }T
T{ : cd6 2c3 2LITERAL ; cd6 -> 4 5 }T
T{ 2VARIABLE 2v1 -> }T
T{ 0. 2v1 2! -> }T
T{ 2v1 2@ -> 0. }T
T{ -1 -2 2v1 2! -> }T
T{ 2v1 2@ -> -1 -2 }T
T{ : cd2 2VARIABLE ; -> }T
T{ cd2 2v2 -> }T
T{ : cd3 2v2 2! ; -> }T
T{ -2 -1 cd3 -> }T
T{ 2v2 2@ -> -2 -1 }T
T{ 2VARIABLE 2v3 IMMEDIATE 5 6 2v3 2! -> }T
T{ 2v3 2@ -> 5 6 }T
T{ 0. 5. D+ -> 5. }T \ small integers
T{ -5. 0. D+ -> -5. }T
T{ 1. 2. D+ -> 3. }T
T{ 1. -2. D+ -> -1. }T
T{ -1. 2. D+ -> 1. }T
T{ -1. -2. D+ -> -3. }T
T{ -1. 1. D+ -> 0. }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{ 0. 5. D- -> -5. }T \ small integers
T{ 5. 0. D- -> 5. }T
T{ 0. -5. D- -> 5. }T
T{ 1. 2. D- -> -1. }T
T{ 1. -2. D- -> 3. }T
T{ -1. 2. D- -> -3. }T
T{ -1. -2. D- -> 1. }T
T{ -1. -1. D- -> 0. }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 -1 -5 D- -> 1 4 }T
T{ 0 -5 0 0 D- -> 0 -5 }T
T{ -1 1 0 2 D- -> -1 -1 }T
T{ 0 1 -1 -2 D- -> 1 2 }T
T{ 0 -1 0 2 D- -> 0 -3 }T
T{ 0 -1 0 -2 D- -> 0 1 }T
T{ 0 0 0 1 D- -> 0 -1 }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
T{ 0. D0< -> <FALSE> }T
T{ 1. D0< -> <FALSE> }T
T{ MIN-INT 0 D0< -> <FALSE> }T
T{ 0 MAX-INT D0< -> <FALSE> }T
T{ MAX-2INT D0< -> <FALSE> }T
T{ -1. D0< -> <TRUE> }T
T{ MIN-2INT D0< -> <TRUE> }T
T{ 1. D0= -> <FALSE> }T
T{ MIN-INT 0 D0= -> <FALSE> }T
T{ MAX-2INT D0= -> <FALSE> }T
T{ -1 MAX-INT D0= -> <FALSE> }T
T{ 0. D0= -> <TRUE> }T
T{ -1. D0= -> <FALSE> }T
T{ 0 MIN-INT D0= -> <FALSE> }T
T{ 0. D2* -> 0. D2* }T
T{ MIN-INT 0 D2* -> 0 1 }T
T{ HI-2INT D2* -> MAX-2INT 1. D- }T
T{ LO-2INT D2* -> MIN-2INT }T
T{ 0. D2/ -> 0. }T
T{ 1. D2/ -> 0. }T
T{ 0 1 D2/ -> MIN-INT 0 }T
T{ MAX-2INT D2/ -> HI-2INT }T
T{ -1. D2/ -> -1. }T
T{ MIN-2INT D2/ -> LO-2INT }T
T{ 0. 1. D< -> <TRUE> }T
T{ 0. 0. D< -> <FALSE> }T
T{ 1. 0. D< -> <FALSE> }T
T{ -1. 1. D< -> <TRUE> }T
T{ -1. 0. D< -> <TRUE> }T
T{ -2. -1. D< -> <TRUE> }T
T{ -1. -2. D< -> <FALSE> }T
T{ -1. MAX-2INT D< -> <TRUE> }T
T{ MIN-2INT MAX-2INT D< -> <TRUE> }T
T{ MAX-2INT -1. D< -> <FALSE> }T
T{ MAX-2INT MIN-2INT D< -> <FALSE> }T
T{ MAX-2INT 2DUP -1. D+ D< -> <FALSE> }T
T{ MIN-2INT 2DUP 1. D+ D< -> <TRUE> }T
T{ -1. -1. D= -> <TRUE> }T
T{ -1. 0. D= -> <FALSE> }T
T{ -1. 1. D= -> <FALSE> }T
T{ 0. -1. D= -> <FALSE> }T
T{ 0. 0. D= -> <TRUE> }T
T{ 0. 1. D= -> <FALSE> }T
T{ 1. -1. D= -> <FALSE> }T
T{ 1. 0. D= -> <FALSE> }T
T{ 1. 1. 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{ 1234 0 D>S -> 1234 }T
T{ -1234 -1 D>S -> -1234 }T
T{ MAX-INT 0 D>S -> MAX-INT }T
T{ MIN-INT -1 D>S -> MIN-INT }T
T{ 1. DABS -> 1. }T
T{ -1. DABS -> 1. }T
T{ MAX-2INT DABS -> MAX-2INT }T
T{ MIN-2INT 1. D+ DABS -> MAX-2INT }T
T{ 1. 2. DMAX -> 2. }T
T{ 1. 0. DMAX -> 1. }T
T{ 1. -1. DMAX -> 1. }T
T{ 1. 1. DMAX -> 1. }T
T{ 0. 1. DMAX -> 1. }T
T{ 0. -1. DMAX -> 0. }T
T{ -1. 1. DMAX -> 1. }T
T{ -1. -2. DMAX -> -1. }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{ 1. 2. DMIN -> 1. }T
T{ 1. 0. DMIN -> 0. }T
T{ 1. -1. DMIN -> -1. }T
T{ 1. 1. DMIN -> 1. }T
T{ 0. 1. DMIN -> 0. }T
T{ 0. -1. DMIN -> -1. }T
T{ -1. 1. DMIN -> -1. }T
T{ -1. -2. DMIN -> -2. }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
T{ 0. DNEGATE -> 0. }T
T{ 1. DNEGATE -> -1. }T
T{ -1. DNEGATE -> 1. }T
T{ max-2int DNEGATE -> min-2int SWAP 1+ SWAP }T
T{ min-2int SWAP 1+ SWAP DNEGATE -> max-2int }T
To correct the result if the division is floored,
only used when necessary, i.e., negative quotient and
remainder <>= 0.
: ?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{ HI-2INT 1 M+ -> HI-2INT 1. D+ }T
T{ MAX-2INT -1 M+ -> MAX-2INT -1. D+ }T
T{ MIN-2INT 1 M+ -> MIN-2INT 1. D+ }T
T{ LO-2INT -1 M+ -> LO-2INT -1. D+ }T
T{ 1. 2. 3. 2ROT -> 2. 3. 1. }T
T{ MAX-2INT MIN-2INT 1. 2ROT -> MIN-2INT 1. MAX-2INT }T
T{ 1 2 2VALUE t2val -> }T
T{ t2val -> 1 2 }T
T{ 3 4 TO t2val -> }T
T{ t2val -> 3 4 }T
: sett2val t2val
2SWAP TO t2val
;
T{ 5 6 sett2val t2val -> 3 4 5 6 }T
T{ 1. 1. DU< -> <FALSE> }T
T{ 1. -1. DU< -> <TRUE> }T
T{ -1. 1. DU< -> <FALSE> }T
T{ -1. -2. DU< -> <FALSE> }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
F.9 The optional Exception word set
The test
F.9.6.1.0875 CATCH also test
THROW. This should
be followed by the test
F.9.6.2.0680 ABORT" which also test
ABORT. Finally, the general exception handling is tested in
F.9.3.6.
F.9.3.6 Exception handling
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
DECIMAL
-1
CONSTANT exc_abort
-2
CONSTANT exc_abort"
-13
CONSTANT exc_undef
: t6
ABORT ;
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
F.11 The optional Facility word set
F.10.6.2.1306.40
EKEY>FKEY
: TFKEY"
( "ccc<quote>" -- u flag )
CR ." Please press "
POSTPONE ." EKEY EKEY>FKEY ;
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
T{ TFKEY" <a>" SWAP EKEY>CHAR -> <FALSE> CHAR a <TRUE> }T
F.12 The optional File-Access word set
These tests create files in the current directory, if all goes well
these will be deleted. If something fails they may not be deleted.
If this is a problem ensure you set a suitable directory before
running this test. Currently, there is no ANS standard way of doing
this. the file names used in these test are:
"
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.
T{ ( 1 2 3
4 5 6
7 8 9 ) 11 22 33 -> 11 22 33 }T
F.11.6.1.1010
CREATE-FILE
F.11.6.1.1190
DELETE-FILE
F.11.6.1.2142
REPOSITION-FILE
F.11.6.1.2147
RESIZE-FILE
T{ S" A String"2DROP -> }T
\ There is no space between the " and 2DROP
F.11.6.2.2130
RENAME-FILE
F.11.6.2.2144.50
REQUIRED
This test requires two additional files:
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
F.14 The optional Floating-Point word set
[UNDEFINED] NaN
[IF] 0e 0e
F/ FCONSTANT NaN
[THEN]
[UNDEFINED] +Inf
[IF] 1e 0e
F/ FCONSTANT +Inf
[THEN]
[UNDEFINED] -Inf
[IF] -1e 0e
F/ FCONSTANT -Inf
[THEN]
TRUE verbose
!
DECIMAL
The test harness default for EXACT? is TRUE.
Uncomment the following line if your system needs it to
be FALSE
\ SET-NEAR
VARIABLE #errors 0 #errors
!
: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
verbose
@ [IF]
CR .( #ERRORS: ) #errors
@ . CR
[THEN]
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
T{ 0e0 FVALUE Tval -> }T
T{ Tval -> 0e0 R}T
T{ 1e0 TO Tval -> }T
T{ Tval -> 1e0 R}T
: setTval Tval
FSWAP TO Tval
;
T{ 2e0 setTval Tval -> 1e0 2e0 RR}T
T{ 5e0 TO Tval -> }T
: [execute]
EXECUTE ; IMMEDIATE
T{ ' Tval ] [execute] [ -> 2e0 R}T
F.16 The optional Memory-Allocation word set
These test require a new variable to hold the address of the allocated
memory. Two helper words are defined to populate the allocated memory
and to check the memory:
The test
F.14.6.1.0707 ALLOCATE includes a test for
FREE.
VARIABLE datsp
HERE datsp
!
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
T{ 50 CHARS ALLOCATE SWAP addr ! -> 0 }T
addr
@ 50 write-char-mem addr
@ 50 check-char-mem
\ 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
F.18 The optional Programming-Tools word set
T{ : pt1 AHEAD 1111 2222 THEN 3333 ; -> }T
T{ pt1 -> 3333 }T
T{ : ?DONE ( dest -- orig dest ) \ Same as WHILE
POSTPONE IF 1 CS-ROLL
; IMMEDIATE -> }T
T{ : pt6
>R
BEGIN
R@
?DONE
R@
R> 1- >R
REPEAT
R> DROP
; -> }T
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
: TNR1
N>R SWAP NR> ;
T{ 1 2 10 20 30 3 TNR1 -> 2 1 10 20 30 3 }T
: TNR2
N>R N>R SWAP NR> NR> ;
T{ 1 2 10 20 30 3 40 50 2 TNR2 -> 2 1 10 20 30 3 40 50 2 }T
F.19 The optional Search-Order word set
The search order is reset to a known state before the tests can be
run.
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.
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.
F.16.6.1.1180
DEFINITIONS
: c"dup"
C" DUP"
;
: c".("
C" .("
;
: c"x"
C" unknown word"
;
T{ c"dup" FIND -> xt @ -1 }T
T{ c".(" FIND -> xti @ 1 }T
T{ c"x" FIND -> c"x" 0 }T
F.16.6.1.1595
FORTH-WORDLIST
T{ FORTH-WORDLIST wid1 ! -> }T
F.16.6.1.2192
SEARCH-WORDLIST
F.16.6.1.2195
SET-CURRENT
T{ GET-ORDER OVER -> GET-ORDER wid1 @ }T
T{ GET-ORDER SET-ORDER -> }T
T{ GET-ORDER -> get-orderlist }T
T{ get-orderlist DROP get-orderList 2* SET-ORDER -> }T
T{ GET-ORDER -> get-orderlist DROP get-orderList 2* }T
T{ get-orderlist SET-ORDER GET-ORDER -> get-orderlist }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
F.20 The optional String word set
Most of the tests in this wordlist require a known string which is
defined as:
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.
T{ : s8 S" abc " ; -> }T
T{ : s9 S" " ; -> }T
T{ : s10 S" a " ; -> }T
T{ s1 -TRAILING -> s1 }T \ "
abcdefghijklmnopqrstuvwxyz"
T{ s8 -TRAILING -> s8 2 - }T \ "
abc "
T{ s7 -TRAILING -> s7 }T \ "
"
T{ s9 -TRAILING -> s9 DROP 0 }T \ "
"
T{ s10 -TRAILING -> s10 1- }T \ "
a "
T{ s1 5 /STRING -> s1 SWAP 5 + SWAP 5 - }T
T{ s1 10 /STRING -4 /STRING -> s1 6 /STRING }T
T{ s1 0 /STRING -> s1 }T
: s13
S" aaaaa a"
; \ Six spaces
T{ PAD 25 CHAR a FILL -> }T \ Fill PAD with 25 'a's
T{ PAD 5 CHARS + 6 BLANK -> }T \ Put 6 spaced from character 5
T{ PAD 12 s13 COMPARE -> 0 }T \ PAD Should now be same as s13
T{ s1 s1 COMPARE -> 0 }T
T{ s1 PAD SWAP CMOVE -> }T \ Copy s1 to PAD
T{ s1 PAD OVER COMPARE -> 0 }T
T{ s1 PAD 6 COMPARE -> 1 }T
T{ PAD 10 s1 COMPARE -> -1 }T
T{ s1 PAD 0 COMPARE -> 1 }T
T{ PAD 0 s1 COMPARE -> -1 }T
T{ s1 s6 COMPARE -> 1 }T
T{ s6 s1 COMPARE -> -1 }T
: "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{ : s2 S" abc" ; -> }T
T{ : s3 S" jklmn" ; -> }T
T{ : s4 S" z" ; -> }T
T{ : s5 S" mnoq" ; -> }T
T{ : s6 S" 12345" ; -> }T
T{ : s7 S" " ; -> }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
30
CHARS BUFFER: subbuff
\ Destination buffer
\ 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
F.21 The optional Extended Character word set
These test assume the UTF-8 character encoding is being used.
T{ $ffff PAD 4 XC!+? -> PAD 3 + 1 <TRUE> }T
This test assumes UTF-8 encoding is being used.
HEX
T{ 0 XC-SIZE -> 1 }T
T{ 7f XC-SIZE -> 1 }T
T{ 80 XC-SIZE -> 2 }T
T{ 7ff XC-SIZE -> 2 }T
T{ 800 XC-SIZE -> 3 }T
T{ ffff XC-SIZE -> 3 }T
T{ 10000 XC-SIZE -> 4 }T
T{ 1fffff XC-SIZE -> 4 }T
F.18.6.2.2487.30
XC-WIDTH
T{ $606D XC-WIDTH -> 2 }T
T{ $41 XC-WIDTH -> 1 }T
T{ $2060 XC-WIDTH -> 0 }T