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:

T{ 1 1 + -> 2 }T

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.

0 INVERT CONSTANT MAX-UINT
0 INVERT 1 RSHIFT CONSTANT MAX-INT
0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT
0 INVERT 1 RSHIFT CONSTANT MID-UINT
0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1

0S CONSTANT <FALSE>
1S CONSTANT <TRUE>

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.

: IFFLOORED [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;
: IFSYM      [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;

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:

: S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) Compare two strings.
   >R SWAP R@ = IF            \ Make sure strings have same length
     R> ?DUP IF               \ If non-empty strings
       0 DO
         OVER C@ OVER C@ - IF 2DROP <FALSE> UNLOOP EXIT THEN
         SWAP CHAR+ SWAP CHAR+
       LOOP
     THEN
     2DROP <TRUE>            \ If we get here, strings match
   ELSE
     R> DROP 2DROP <FALSE> \ Lengths mismatch
   THEN ;

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.

24 CONSTANT MAX-BASE                  \ BASE 2 ... 36
: COUNT-BITS
   0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
COUNT-BITS 2* CONSTANT #BITS-UD    \ NUMBER OF BITS IN UD

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:

CREATE FBUF 00 C, 00 C, 00 C,
CREATE SBUF 12 C, 34 C, 56 C,
: SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ;

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

F.6.1.0010
!
F.6.1.0030
#
: GP3 <# 1 0 # # #> S" 01" S= ;
T{ GP3 -> <TRUE> }T
F.6.1.0040
#>
F.6.1.0050
#S
: GP4 <# 1 0 #S #> S" 1" S= ;
T{ GP4 -> <TRUE> }T

: 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

F.6.1.0070
'
T{ : GT1 123 ;   ->     }T
T{ ' GT1 EXECUTE -> 123 }T
F.6.1.0080
(
\ There is no space either side of the ).
T{ ( A comment)1234 -> }T
T{ : pc1 ( A comment)1234 ; pc1 -> 1234 }T
F.6.1.0090
*
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

F.6.1.0100
*/
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

F.6.1.0110
*/MOD
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

F.6.1.0120
+
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
F.6.1.0130
+!
T{  0 1ST !        ->   }T
T{  1 1ST +!       ->   }T
T{    1ST @        -> 1 }T
T{ -1 1ST +! 1ST @ -> 0 }T
F.6.1.0140
+LOOP
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

F.6.1.0150
,
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

F.6.1.0160
-
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
F.6.1.0180
.
F.6.1.0190
."
T{ : pb1 CR ." You should see 2345: "." 2345"; pb1 -> }T

See F.6.1.1320 EMIT.

F.6.1.0230
/
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

F.6.1.0240
/MOD
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

F.6.1.0250
0<
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
F.6.1.0270
0=
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
F.6.1.0290
1+
T{        0 1+ ->          1 }T
T{       -1 1+ ->          0 }T
T{        1 1+ ->          2 }T
T{ MID-UINT 1+ -> MID-UINT+1 }T
F.6.1.0300
1-
T{          2 1- ->        1 }T
T{          1 1- ->        0 }T
T{          0 1- ->       -1 }T
T{ MID-UINT+1 1- -> MID-UINT }T
F.6.1.0310
2!
F.6.1.0320
2*
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
F.6.1.0330
2/
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
F.6.1.0350
2@
F.6.1.0370
2DROP
T{ 1 2 2DROP -> }T
F.6.1.0380
2DUP
T{ 1 2 2DUP -> 1 2 1 2 }T
F.6.1.0400
2OVER
T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T
F.6.1.0430
2SWAP
T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T
F.6.1.0450
:
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

F.6.1.0460
;
F.6.1.0480
<
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
F.6.1.0490
<#
F.6.1.0530
=
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
F.6.1.0540
>
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
F.6.1.0550
>BODY
T{  CREATE CR0 ->      }T
T{ ' CR0 >BODY -> HERE }T
F.6.1.0560
>IN
VARIABLE SCANS
: RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ;

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

F.6.1.0570
>NUMBER
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

F.6.1.0580
>R
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 )
F.6.1.0630
?DUP
T{ -1 ?DUP -> -1 -1 }T
T{  0 ?DUP ->  0    }T
T{  1 ?DUP ->  1  1 }T
F.6.1.0650
@
F.6.1.0690
ABS
T{       0 ABS ->          0 }T
T{       1 ABS ->          1 }T
T{      -1 ABS ->          1 }T
T{ MIN-INT ABS -> MID-UINT+1 }T
F.6.1.0695
ACCEPT
CREATE ABUF 80 CHARS ALLOT

: ACCEPT-TEST
     CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
     ABUF 80 ACCEPT
     CR ." RECEIVED: " [CHAR] " EMIT
     ABUF SWAP TYPE [CHAR] " EMIT CR
;

T{ ACCEPT-TEST -> }T

F.6.1.0705
ALIGN
ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT
CONSTANT A-ADDR CONSTANT UA-ADDR
T{ UA-ADDR ALIGNED -> A-ADDR }T
T{       1 A-ADDR C!         A-ADDR       C@ ->       1 }T
T{    1234 A-ADDR !          A-ADDR       @  ->    1234 }T
T{ 123 456 A-ADDR 2!         A-ADDR       2@ -> 123 456 }T
T{       2 A-ADDR CHAR+ C!   A-ADDR CHAR+ C@ ->       2 }T
T{       3 A-ADDR CELL+ C!   A-ADDR CELL+ C@ ->       3 }T
T{    1234 A-ADDR CELL+ !    A-ADDR CELL+ @  ->    1234 }T
T{ 123 456 A-ADDR CELL+ 2!   A-ADDR CELL+ 2@ -> 123 456 }T
F.6.1.0710
ALLOT
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 )
F.6.1.0720
AND
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

F.6.1.0750
BASE
: GN2 \ ( -- 16 10 )
   BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ;
T{ GN2 -> 10 A }T
F.6.1.0760
BEGIN
F.6.1.0770
BL
T{ BL -> 20 }T
F.6.1.0850
C!
F.6.1.0860
C,
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

F.6.1.0870
C@
F.6.1.0880
CELL+
F.6.1.0890
CELLS
: BITS ( X -- U )
   0 SWAP BEGIN DUP WHILE
     DUP MSB AND IF >R 1+ R> THEN 2*
   REPEAT DROP ;

( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS )
T{ 1 CELLS 1 <         -> <FALSE> }T
T{ 1 CELLS 1 CHARS MOD ->    0    }T
T{ 1S BITS 10 <        -> <FALSE> }T

F.6.1.0895
CHAR
T{ CHAR X     -> 58 }T
T{ CHAR HELLO -> 48 }T
F.6.1.0897
CHAR+
F.6.1.0898
CHARS
( 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? )
F.6.1.0950
CONSTANT
T{ 123 CONSTANT X123 -> }T
T{ X123 -> 123 }T

T{ : EQU CONSTANT ; -> }T
T{ X123 EQU Y123 -> }T
T{ Y123 -> 123 }T

F.6.1.0980
COUNT
T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T
F.6.1.0990
CR
F.6.1.1000
CREATE
F.6.1.1170
DECIMAL
F.6.1.1200
DEPTH
T{ 0 1 DEPTH -> 0 1 2 }T
T{   0 DEPTH -> 0 1   }T
T{     DEPTH -> 0     }T
F.6.1.1240
DO
F.6.1.1250
DOES>
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

F.6.1.1260
DROP
T{ 1 2 DROP -> 1 }T
T{ 0   DROP ->   }T
F.6.1.1290
DUP
T{ 1 DUP -> 1 1 }T
F.6.1.1310
ELSE
F.6.1.1320
EMIT
: OUTPUT-TEST
   ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR
   41 BL DO I EMIT LOOP CR
   61 41 DO I EMIT LOOP CR
   7F 61 DO I EMIT LOOP CR
   ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR
   9 1+ 0 DO I . LOOP CR
   ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR
   [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR
   ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR
   [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR
   ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR
   5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR
   ." YOU SHOULD SEE TWO SEPARATE LINES:" CR
   S" LINE 1" TYPE CR S" LINE 2" TYPE CR
   ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR
   ." SIGNED: " MIN-INT . MAX-INT . CR
   ." UNSIGNED: " 0 U. MAX-UINT U. CR
;

T{ OUTPUT-TEST -> }T

F.6.1.1345
ENVIRONMENT?
\ 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
F.6.1.1360
EVALUATE
: 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.

F.6.1.1370
EXECUTE
F.6.1.1380
EXIT
F.6.1.1540
FILL
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

F.6.1.1550
FIND
HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING
HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING
T{ GT1STRING FIND -> ' GT1 -1 }T
T{ GT2STRING FIND -> ' GT2 1  }T
( HOW TO SEARCH FOR NON-EXISTENT WORD? )
F.6.1.1561
FM/MOD
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
F.6.1.1650
HERE
F.6.1.1670
HOLD
: GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
T{ GP1 -> <TRUE> }T
F.6.1.1680
I
F.6.1.1700
IF
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

F.6.1.1710
IMMEDIATE
T{ 123 CONSTANT iw1 IMMEDIATE iw1 -> 123 }T
T{ : iw2 iw1 LITERAL ; iw2 -> 123 }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".

F.6.1.1720
INVERT
T{ 0S INVERT -> 1S }T
T{ 1S INVERT -> 0S }T
F.6.1.1730
J
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

F.6.1.1760
LEAVE
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
F.6.1.1780
LITERAL
T{ : GT3 GT2 LITERAL ; -> }T
T{ GT3 -> ' GT1 }T
F.6.1.1800
LOOP
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
F.6.1.1805
LSHIFT
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
F.6.1.1810
M*
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
F.6.1.1870
MAX
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
F.6.1.1880
MIN
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
F.6.1.1890
MOD
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

F.6.1.1900
MOVE
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

F.6.1.1910
NEGATE
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
F.6.1.1980
OR
T{ 0S 0S OR -> 0S }T
T{ 0S 1S OR -> 1S }T
T{ 1S 0S OR -> 1S }T
T{ 1S 1S OR -> 1S }T
F.6.1.1990
OVER
T{ 1 2 OVER -> 1 2 1 }T
F.6.1.2033
POSTPONE
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

F.6.1.2060
R>
F.6.1.2070
R@
F.6.1.2120
RECURSE
T{ : GI6 ( N -- 0,1,..N ) 
     DUP IF DUP >R 1- RECURSE R> THEN ; -> }T

T{ 0 GI6 -> 0 }T
T{ 1 GI6 -> 0 1 }T
T{ 2 GI6 -> 0 1 2 }T
T{ 3 GI6 -> 0 1 2 3 }T
T{ 4 GI6 -> 0 1 2 3 4 }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

F.6.1.2140
REPEAT
F.6.1.2160
ROT
T{ 1 2 3 ROT -> 2 3 1 }T
F.6.1.2162
RSHIFT
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
F.6.1.2165
S"
T{ : GC4 S" XY" ; ->   }T
T{ GC4 SWAP DROP  -> 2 }T
T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T

: GC5 S" A String"2DROP ; \ There is no space between the " and 2DROP
T{ GC5 -> }T

F.6.1.2170
S>D
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
F.6.1.2210
SIGN
: GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
T{ GP2 -> <TRUE> }T
F.6.1.2214
SM/REM
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
F.6.1.2216
SOURCE
: GS1 S" SOURCE" 2DUP EVALUATE >R SWAP >R = R> R> = ;
T{ GS1 -> <TRUE> <TRUE> }T

: GS4 SOURCE >IN ! DROP ;
T{ GS4 123 456 
    -> }T

F.6.1.2220
SPACE
F.6.1.2230
SPACES
F.6.1.2250
STATE
T{ : GT8 STATE @ ; IMMEDIATE -> }T
T{ GT8 -> 0 }T
T{ : GT9 GT8 LITERAL ; -> }T
T{ GT9 0= -> <FALSE> }T
F.6.1.2260
SWAP
T{ 1 2 SWAP -> 2 1 }T
F.6.1.2270
THEN
F.6.1.2310
TYPE
F.6.1.2320
U.
F.6.1.2340
U<
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
F.6.1.2360
UM*
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

F.6.1.2370
UM/MOD
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
F.6.1.2380
UNLOOP
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
F.6.1.2390
UNTIL
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
F.6.1.2410
VARIABLE
T{ VARIABLE V1 ->     }T
T{    123 V1 ! ->     }T
T{        V1 @ -> 123 }T
F.6.1.2430
WHILE
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

F.6.1.2450
WORD
: GS3 WORD COUNT SWAP C@ ;
T{ BL GS3 HELLO -> 5 CHAR H }T
T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T
T{ BL GS3 
   DROP -> 0 }T
\ Blank lines return zero-length strings
F.6.1.2490
XOR
T{ 0S 0S XOR -> 0S }T
T{ 0S 1S XOR -> 1S }T
T{ 1S 0S XOR -> 1S }T
T{ 1S 1S XOR -> 0S }T
F.6.1.2500
[
T{ : GC3 [ GC1 ] LITERAL ; -> }T
T{ GC3 -> 58 }T
F.6.1.2510
[']
T{ : GT2 ['] GT1 ; IMMEDIATE -> }T
T{ GT2 EXECUTE -> 123 }T
F.6.1.2520
[CHAR]
T{ : GC1 [CHAR] X     ; -> }T
T{ : GC2 [CHAR] HELLO ; -> }T
T{ GC1 -> 58 }T
T{ GC2 -> 48 }T
F.6.1.2540
]
F.6.2.0455
:NONAME
VARIABLE nn1
VARIABLE nn2
T{ :NONAME 1234 ; nn1 ! -> }T
T{ :NONAME 9876 ; nn2 ! -> }T
T{ nn1 @ EXECUTE -> 1234 }T
T{ nn2 @ EXECUTE -> 9876 }T
F.6.2.0620
?DO
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

F.6.2.0698
ACTION-OF
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

F.6.2.0825
BUFFER:
DECIMAL
T{ 127 CHARS BUFFER: TBUF1 -> }T
T{ 127 CHARS BUFFER: TBUF2 -> }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

F.6.2.0855
C"
T{ : cq1 C" 123" ; -> }T
T{ : cq2 C" " ;    -> }T
T{ cq1 COUNT EVALUATE -> 123 }T
T{ cq2 COUNT EVALUATE ->     }T
F.6.2.0873
CASE
: cs1 CASE 1 OF 111 ENDOF
   2 OF 222 ENDOF
   3 OF 333 ENDOF
   >R 999 R>
   ENDCASE
;

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

F.6.2.0945
COMPILE,
:NONAME DUP + ; CONSTANT dup+
T{ : q dup+ COMPILE, ; -> }T
T{ : as [ q ] ; -> }T
T{ 123 as -> 246 }T
F.6.2.1173
DEFER
T{ DEFER defer2 ->   }T
T{ ' * ' defer2 DEFER! -> }T
T{   2 3 defer2 -> 6 }T

T{ ' + IS defer2 ->   }T
T{    1 2 defer2 -> 3 }T

F.6.2.1175
DEFER!
T{ DEFER defer3 -> }T

T{ ' * ' defer3 DEFER! -> }T
T{ 2 3 defer3 -> 6 }T

T{ ' + ' defer3 DEFER! -> }T
T{ 1 2 defer3 -> 3 }T

F.6.2.1177
DEFER@
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

F.6.2.1342
ENDCASE
F.6.2.1343
ENDOF
F.6.2.1485
FALSE
T{ FALSE -> 0 }T
T{ FALSE -> <FALSE> }T
F.6.2.1660
HEX
F.6.2.1675
HOLDS
T{ 0. <# S" Test" HOLDS #> S" Test" COMPARE -> 0 }T
F.6.2.1725
IS
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

F.6.2.1950
OF
F.6.2.2020
PARSE-NAME
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

F.6.2.2182
SAVE-INPUT
Testing with a file source
VARIABLE siv -1 siv !

: 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

F.6.2.2295
TO
F.6.2.2298
TRUE
T{ TRUE -> <TRUE> }T
T{ TRUE -> 0 INVERT }T
F.6.2.2405
VALUE
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

F.6.2.2530
[COMPILE]
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:

MAX-INT 2/ CONSTANT HI-INT \ 001...1
MIN-INT 2/ CONSTANT LO-INT \ 110...1

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:

1S MAX-INT 2CONSTANT MAX-2INT \ 01...1
0 MIN-INT 2CONSTANT MIN-2INT \ 10...0
MAX-2INT 2/ 2CONSTANT HI-2INT \ 001...1
MIN-2INT 2/ 2CONSTANT LO-2INT \ 110...0

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

F.8.6.1.0360
2CONSTANT
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

F.8.6.1.0390
2LITERAL
T{ : cd1 [ MAX-2INT ] 2LITERAL ; -> }T
T{ cd1 -> MAX-2INT }T

T{ 2VARIABLE 2v4 IMMEDIATE 5 6 2v4 2! -> }T
T{ : cd7 2v4 [ 2@ ] 2LITERAL ; cd7 -> 5 6 }T
T{ : cd8 [ 6 7 ] 2v4 [ 2! ] ; 2v4 2@ -> 6 7 }T

F.8.6.1.0440
2VARIABLE
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

F.8.6.1.1040
D+
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

F.8.6.1.1050
D-
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

F.8.6.1.1060
D.
F.8.6.1.1070
D.R
MAX-2INT 71 73 M*/ 2CONSTANT dbl1
MIN-2INT 73 79 M*/ 2CONSTANT dbl2

: 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

F.8.6.1.1075
D0<
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
F.8.6.1.1080
D0=
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
F.8.6.1.1090
D2*
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
F.8.6.1.1100
D2/
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
F.8.6.1.1110
D<
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

F.8.6.1.1120
D=
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

F.8.6.1.1140
D>S
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
F.8.6.1.1160
DABS
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
F.8.6.1.1210
DMAX
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

F.8.6.1.1220
DMIN
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

F.8.6.1.1230
DNEGATE
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
F.8.6.1.1820
M*/
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

F.8.6.1.1830
M+
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
F.8.6.2.0420
2ROT
T{       1.       2. 3. 2ROT ->       2. 3.       1. }T
T{ MAX-2INT MIN-2INT 1. 2ROT -> MIN-2INT 1. MAX-2INT }T
F.8.6.2.0435
2VALUE
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
F.8.6.2.1270
DU<
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.

DECIMAL
: t7 S" 333 $$UndefedWord$$ 334" EVALUATE 335 ;
: t8 S" 222 t7 223" EVALUATE 224 ;
: t9 S" 111 112 t8 113" EVALUATE 114 ;

T{ 6 7 ' t9 c6 3 -> 6 7 13 3 }T

F.9.6.1.0875
CATCH
F.9.6.1.2275
THROW
DECIMAL

: 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

F.9.6.2.0670
ABORT
F.9.6.2.0680
ABORT"
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.

F.11.6.1.0080
(
T{ ( 1 2 3 
      4 5 6 
      7 8 9 ) 11 22 33 -> 11 22 33 }T
F.11.6.1.1010
CREATE-FILE
: fn1 S" fatest1.txt" ;
VARIABLE fid1

T{ fn1 R/W CREATE-FILE SWAP fid1 ! -> 0 }T
T{ fid1 @ CLOSE-FILE -> 0 }T

F.11.6.1.1190
DELETE-FILE
T{ fn2 DELETE-FILE -> 0 }T
T{ fn2 R/W BIN OPEN-FILE SWAP DROP -> 0 }T
T{ fn2 DELETE-FILE -> 0 }T
F.11.6.1.1522
FILE-SIZE
: cbuf buf bsize 0 FILL ;
: fn2 S" fatest2.txt" ;
VARIABLE fid2
: setpad PAD 50 0 DO I OVER C! CHAR+ LOOP DROP ;

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

F.11.6.1.1718
INCLUDED
F.11.6.1.2090
READ-LINE
200 CONSTANT bsize
CREATE buf bsize ALLOT
VARIABLE #chars

T{ fn1 R/O OPEN-FILE SWAP fid1 ! -> 0 }T
T{ fid1 @ FILE-POSITION -> 0. 0 }T
T{ buf 100 fid1 @ READ-LINE ROT DUP #chars ! ->
    <TRUE> 0 line1 SWAP DROP }T

T{ buf #chars @ line1 COMPARE -> 0 }T
T{ fid1 @ CLOSE-FILE -> 0 }T

F.11.6.1.2142
REPOSITION-FILE
: line2 S" Line 2 blah blah blah" ;
: rl1 buf 100 fid1 @ READ-LINE ;
2VARIABLE fp

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

F.11.6.1.2147
RESIZE-FILE
setpad
T{ fn2 R/W BIN OPEN-FILE SWAP fid2 ! -> 0 }T
T{ 37. fid2 @ RESIZE-FILE -> 0 }T
T{ fid2 @ FILE-SIZE -> 37. 0 }T
T{ 0. fid2 @ REPOSITION-FILE -> 0 }T
T{ cbuf buf 100 fid2 @ READ-FILE -> 37 0 }T
T{ PAD 37 buf 37 COMPARE -> 0 }T
T{ PAD 38 buf 38 COMPARE -> 1 }T
T{ 500. fid2 @ RESIZE-FILE -> 0 }T
T{ fid2 @ FILE-SIZE -> 500. 0 }T
T{ 0. fid2 @ REPOSITION-FILE -> 0 }T
T{ cbuf buf 100 fid2 @ READ-FILE -> 100 0 }T
T{ PAD 37 buf 37 COMPARE -> 0 }T
T{ fid2 @ CLOSE-FILE -> 0 }T
F.11.6.1.2165
S"
T{ S" A String"2DROP -> }T    \ There is no space between the " and 2DROP
F.11.6.1.2218
SOURCE-ID
T{ SOURCE-ID DUP -1 = SWAP 0= OR -> <FALSE> }T
F.11.6.1.2485
WRITE-LINE
: line1 S" Line 1" ;

T{ fn1 W/O OPEN-FILE SWAP fid1 ! -> 0 }T
T{ line1 fid1 @ WRITE-LINE -> 0 }T
T{ fid1 @ CLOSE-FILE -> 0 }T

F.11.6.2.1714
INCLUDE
F.11.6.2.2130
RENAME-FILE
: fn3 S" fatest3.txt" ;
: >end fid1 @ FILE-SIZE DROP fid1 @ REPOSITION-FILE ;

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

F.11.6.2.2144.10
REQUIRE
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:
1+
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

F.12.6.2.1489
FATAN2
[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]

F.12.6.2.1627
FTRUNC
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

F.12.6.2.1628
FVALUE
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:

VARIABLE addr

: 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
;

The test F.14.6.1.0707 ALLOCATE includes a test for FREE.

F.14.6.1.0707
ALLOCATE
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

F.14.6.1.1605
FREE
F.14.6.1.2145
RESIZE
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

F.15.6.2.0702
AHEAD
T{ : pt1 AHEAD 1111 2222 THEN 3333 ; -> }T
T{ pt1 -> 3333 }T
F.15.6.2.1015
CS-PICK
: ?repeat
   0 CS-PICK POSTPONE UNTIL
; IMMEDIATE

VARIABLE pt4

: <= > 0= ;

T{ : pt5  ( n1 -- ) 
      pt4 ! 
      BEGIN 
        -1 pt4 +! 
        pt4 @ 4 <= ?repeat    \ Back to BEGIN if false 
        111 
        pt4 @ 3 <= ?repeat 
        222 
        pt4 @ 2 <= ?repeat 
        333 
        pt4 @ 1 = 
      UNTIL 
    ; -> }T

T{ 6 pt5 -> 111 111 222 111 222 333 111 222 333 }T

F.15.6.2.1020
CS-ROLL
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

F.15.6.2.1908
N>R
: 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.15.6.2.2533
[THEN]
T{ <TRUE>  [IF] 111 [ELSE] 222 [THEN] -> 111 }T
T{ <FALSE> [IF] 111 [ELSE] 222 [THEN] -> 222 }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

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.

VARIABLE wid1
VARIABLE wid2

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.

: save-orderlist ( widn ... wid1 n -- )
   DUP , 0 ?DO , LOOP
;

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.

F.16.6.1.1180
DEFINITIONS
T{ ONLY FORTH DEFINITIONS -> }T
T{ GET-CURRENT -> FORTH-WORDLIST }T

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

F.16.6.1.1550
FIND
: 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
ONLY FORTH DEFINITIONS
VARIABLE xt ' DUP xt !
VARIABLE xti ' .( xti ! \ Immediate word

T{ S" DUP" wid1 @ SEARCH-WORDLIST -> xt  @ -1 }T
T{ S" .("  wid1 @ SEARCH-WORDLIST -> xti @  1 }T
T{ S" DUP" wid2 @ SEARCH-WORDLIST ->        0 }T

F.16.6.1.2195
SET-CURRENT
T{ GET-CURRENT -> wid1 @ }T

T{ WORDLIST wid2 ! -> }T
T{ wid2 @ SET-CURRENT -> }T
T{ GET-CURRENT -> wid2 @ }T

T{ wid1 @ SET-CURRENT -> }T

F.16.6.1.2197
SET-ORDER
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.16.6.2.0715
ALSO
T{ ALSO GET-ORDER ONLY -> get-orderlist OVER SWAP 1+ }T
F.16.6.2.1965
ONLY
T{ ONLY FORTH GET-ORDER -> get-orderlist }T

: so1 SET-ORDER ; \ In case it is unavailable in the forth wordlist

T{ ONLY FORTH-WORDLIST 1 SET-ORDER get-orderlist so1 -> }T
T{ GET-ORDER -> get-orderlist }T

F.16.6.2.1985
ORDER
CR .( ONLY FORTH DEFINITIONS search order and compilation list) CR
T{ ONLY FORTH DEFINITIONS ORDER -> }T

CR .( Plus another unnamed wordlist at head of search order) CR
T{ alsowid2 DEFINITIONS ORDER -> }T

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.

F.17.6.1.0170
-TRAILING
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 "

F.17.6.1.0245
/STRING
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
F.17.6.1.0780
BLANK
: 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

F.17.6.1.0935
COMPARE
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

F.17.6.1.2191
SEARCH
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

F.17.6.1.2212
SLITERAL
T{ : s14 [ s1 ] SLITERAL ; -> }T
T{ s1 s14 COMPARE -> 0 }T
T{ s1 s14 ROT = ROT ROT = -> <TRUE> <FALSE> }T
F.17.6.2.2255
SUBSTITUTE
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.17.6.2.2375
UNESCAPE
Using subbuff, sub5 and sub6 from F.17.6.2.2255 SUBSTITUTE.

T{ sub6 subbuff UNESCAPE sub5 COMPARE -> 0 }T

F.21 The optional Extended Character word set

These test assume the UTF-8 character encoding is being used.

F.18.6.1.2487.15
XC!+?
T{ $ffff PAD 4 XC!+? -> PAD 3 + 1 <TRUE> }T
F.18.6.1.2487.25
XC-SIZE
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

ContributeContributions