INVIS
EXIT   This is a single-line comment. It works like this:
EXIT   The interpreter repeatedly executes QUERY followed by LINE and then
EXIT   prints OK. LINE parses and executes the words in an input line one at
EXIT   a time. If one of these words is EXIT, then LINE will return, the rest
EXIT   of the line won't be processed, and QUERY will clear the input buffer
EXIT   again. The net result is that when executing EXIT, we're allowing
EXIT   single line comments because the rest of the line will be ignored.
EXIT
EXIT   However, that's not very convenient for readability, and also we can't
EXIT   use this trick inside colon definitions, so we create an alias. For
EXIT   compactness, we use CREATE, then point the code field of the newly
EXIT   created word to the routine that executes an EXIT, but this would have
EXIT   worked all the same: : \ R> DROP ; IMMEDIATE

CREATE \ 1208 HERE 2- ! IMMEDIATE
\ Done, we can now use nicer single-line comments and even write them inside
\ colon definitions.


1 VARIABLE DUMMY \ used later, needs to be near the beginning of the user RAM

\ ***************************************************************************
\ COMPILATION TESTS
\ ***************************************************************************

\ Test the compiled result of all words
VIS
: testcolon  \ This is a VLIST of the ROM dict, with a few modifications.
  FORTH UFLOAT INT FNEGATE F/ F* F+ F- LOAD BVERIFY VERIFY BLOAD BSAVE SAVE
  LIST EDIT FORGET REDEFINE EXIT
  ." One string"
  ( One comment)
  [ 1 ] LITERAL  \ need to add something to test '['; test 'LITERAL' too
  DO     \ added to make the structure correct
  +LOOP
  DO     \ moved to make the structure correct
  LOOP
  BEGIN  \ added to make the structure correct
  UNTIL
  BEGIN  \ moved to make the structure correct
  WHILE  \ moved to make the structure correct
  REPEAT
  \ Test multiple ELSE's while we're here.
  IF ELSE ELSE ELSE THEN \ shuffled to make the structure correct
  ] LEAVE J I' I DEFINITIONS VOCABULARY IMMEDIATE
  \ RUNS> DOES>  \ these need to be tested separately
  COMPILER CALL DEFINER ASCII abcd
  \ LITERAL      \ already tested
  CONSTANT VARIABLE ALLOT C, , CREATE : DECIMAL MIN MAX XOR AND OR 2- 1- 2+ 1+
  D+ - + DNEGATE NEGATE U/MOD */ * MOD / */MOD /MOD U* D< U< < > = 0> 0< 0= ABS
  OUT IN INKEY BEEP PLOT AT F. EMIT CR SPACES SPACE HOLD CLS # #S U. . SIGN
  #> <# TYPE ROLL PICK OVER ROT ?DUP R> >R ! @ C! C@ SWAP DROP DUP SLOW FAST
  INVIS VIS CONVERT NUMBER EXECUTE FIND VLIST WORD RETYPE QUERY LINE
  \ ;            \ moved to the end for obvious reasons
  PAD BASE CURRENT CONTEXT HERE ABORT QUIT
;
\ Test compilation of RUNS> and DOES>
0 COMPILER CompWord 2 RUNS> 3 ;
DEFINER DefWord 4 DOES> 5 ;

\ Test compilation of CONSTANT, VARIABLE, CREATE
2 CONSTANT Two
12345 VARIABLE OneTwoThreeFourFive
CREATE MyWord
\ While we're here, test , and C, with weird values; they should work OK.
-447 C, 547 , 652 C,

\ Actually test that COMPILER and DEFINER work, using the manual's examples
\ as well as our own code.
4 COMPILER 2LITERAL
  SWAP , ,
RUNS>
  DUP @ SWAP 2+ @
;
\ This is a more compact definition for 2LITERAL, using the ROM's definition,
\ but the doubles are listed as FP (with COMPILER they are listed as the
\ word 2LITERAL, which isn't helpful either).
\ CREATE 2LITERAL
\ 4198 HERE 2- ! IMMEDIATE

: Test2Literal
  [ 4321 23456 ] 2LITERAL . .
;
Test2Literal

DEFINER MAKEDAYS
  32 WORD 1+ DUP 21 + SWAP
  DO
    I C@ C,
  LOOP
DOES>
  SWAP 1- 3 * +
  3 TYPE
;

MAKEDAYS .DAY MonTueWedThuFriSatSun
MAKEDAYS .JOUR lunmarmerjeuvensamdim
MAKEDAYS .TAG MonDieMitDonFreSamSon
3 .DAY
4 .JOUR
5 .TAG

: PRINTDAYS
  CR
  8 1 DO
    DUP I SWAP EXECUTE CR
  LOOP
  DROP
;

FIND .DAY PRINTDAYS
FIND .JOUR PRINTDAYS
FIND .TAG PRINTDAYS

: COLON_DEFINER
  MAKEDAYS
  .JOUR
  .JOUR
;

-1 COMPILER CompLength3
  3 ,  \ length field
  4 , 1 C,  \ 3-byte operand
RUNS>
  \ print the operands
  DUP @ . 2+ DUP @ . 2+ C@ .
;

: TestCompLength3
  CompLength3
  CompLength3
;
TestCompLength3

\ Test semantics of multiple ELSEs (alternates between true and false)
: ELSELSE
  IF
    1 2  \ if true
  ELSE
    3 4  \ if false
  ELSE
    5 6  \ if true
  ELSE
    7 8  \ if false
  THEN
;

1 ELSELSE . . . .  \ prints 6 5 2 1
0 ELSELSE . . . .  \ prints 8 7 4 3

\ Test semantics of +LOOP, I, I', J
: LOOPS
  10 0 DO
    3 11 DO
      ." I I' J = "
      I . I' . J . CR
    -2 +LOOP
    I 6 = IF
      LEAVE
    THEN
  2 +LOOP
;
LOOPS

\ ***************************************************************************
\ UTILITY ROUTINES
\ ***************************************************************************

: ERROR
  15421 C! ABORT  \ Set ERR_NO and abort
;

\ Use at points where the stack should be empty, to test if that's the case
: STKCHK
  15419 @ 12 - HERE -
  \ Uncomment to show the value at the top of the stack before erroring:
  \ DUP .
  IF
    2 ERROR
  THEN
;

STKCHK

\ Allow input of a double integer. 'DINT' acts as a prefix to allow us to
\ enter double integers as a single long number rather than as two integers.
\ Like ASCII, it works in either direct or compilation mode.
\ The error codes are somewhat weird, admittedly, but there are no adequate
\ error codes in the ROM.
: DINT
  0 0         \ Double accumulator
  32 WORD     \ Parse next word (we know the result is in PAD)
  0           \ Sign = 0 for positive or 1 for negative
  PAD 1+ C@   \ Grab first character
  ASCII - =   \ Is it a "-"?
  IF
    1+        \ Sign = 1
  THEN
  DUP >R      \ Save sign in return stack
  +           \ Skip sign if negative
  CONVERT     \ Skip length byte and convert parsed word to double integer
  PAD 1+      \ Address where number starts
  -           \ Subtract end address minus start address to obtain length
  PAD C@      \ Fetch length byte stored by the 'WORD' command
  DUP 0= IF   \ Now that we're here, is it zero? (known bug: it should check
              \ if it equals the stored sign, otherwise 'DINT -' is wrongly
              \ accepted)
    6 ERROR   \ If so, give Error 6 (empty word)
  THEN
  XOR         \ Does it differ from the length that WORD parsed?
  IF          \ If so...
    13 ERROR  \ Error 13 (word not found)
  THEN
  R> IF       \ Recover sign; if negative:
    DNEGATE   \ negate double
  THEN
  15422 C@    \ FLAGS
  64 AND      \ Compiling?
  IF
    \ Compile it as a word
    4196 ,         \ Compile stk-fp (warning: the result is shown as FP!)
    SWAP , ,       \ Compile double int as operand
  \ Else just leave it on the stack
  THEN
; IMMEDIATE

\ From the manual, a definition of 'D.' (abbreviated):
: D.
  ( double length integer -- )
  DUP >R DUP 0<
  IF
    DNEGATE
  THEN
  <# #S R> SIGN #>
  TYPE SPACE
;

: UD.
  ( double length integer -- )
  <# #S #>
  TYPE SPACE
;

\ Test our tool in direct and compiled mode.
DINT    2147483647 D.

16 BASE C!
: TestDINT
  DINT -1234567A OVER OVER D. OVER OVER UD.
  -1235 =
  SWAP -567A =
  AND 0=
  IF
    0 ERROR
  THEN
;
TESTdint  \ check different case too
DECIMAL

\ ***************************************************************************
\ NUMERIC TESTS
\ ***************************************************************************

STKCHK

\ Uninitialized variables
CREATE OP 2 ALLOT
CREATE .FUNC 2 ALLOT

: EXECOP
  OP @ EXECUTE     \ Execute the operation
  .FUNC @ EXECUTE  \ Execute the displaying
;

: ..  \ Print pairs of numbers, with a bar to separate them
  ASCII | EMIT SPACE . .
;

\ Test cases for 1 int operations
: EXERCISE_1INT
  OP !
  0       EXECOP
  1       EXECOP
  Two     EXECOP  \ Exercises invoking a constant too
  Two NEGATE EXECOP
  -1      EXECOP
  35      EXECOP
  -35     EXECOP
  32767   EXECOP
  -32767  EXECOP
  -32768  EXECOP
;

\ Test cases for 2 int operations
: EXERCISE_2INTS
  OP !
  35 12          EXECOP
  35 12          EXECOP
  35 -12         EXECOP
  12 35          EXECOP
  12 -35         EXECOP
  -35 12         EXECOP
  -35 -12        EXECOP
  -12 35         EXECOP
  -12 -35        EXECOP
  23456 24791    EXECOP
  51234 73412    EXECOP
  -23456 -59117  EXECOP
  -32768 -1      EXECOP
  32767 1        EXECOP
  -32768 1       EXECOP
  -32768 -1      EXECOP
  -32768 0       EXECOP
  32767 0        EXECOP
  767 0          EXECOP
  0 0            EXECOP
  0 1            EXECOP
  0 -1           EXECOP
  0 32767        EXECOP
  0 -32768       EXECOP
;

: EXERCISE_3INTS
  OP !
  0 0 0          EXECOP
  -3 0 0         EXECOP
  0 -3 0         EXECOP
  0 1 0          EXECOP
  1 1 0          EXECOP
  10 10 0        EXECOP
  10 -10 0       EXECOP
  -10 -10 0      EXECOP
  45 90 1        EXECOP
  305 339 1      EXECOP
  999 999 1      EXECOP
  255 255 1      EXECOP
  256 255 1      EXECOP
  256 255 256    EXECOP
  -325 123 321   EXECOP
  997 -997 317   EXECOP
  997 -997 -317  EXECOP
  -999 -999 317  EXECOP
  -999 -999 -317 EXECOP
  4923 9219 1721 EXECOP
  1 1 -32767     EXECOP
;

\ Functions that accept 1 int and return 1 int
FIND . .FUNC !  \ print 1 int
FIND 0=     EXERCISE_1INT
FIND 0>     EXERCISE_1INT
FIND 0<     EXERCISE_1INT
FIND ABS    EXERCISE_1INT

\ Functions that accept 2 ints and return 1 int
16 BASE C!  \ just to exercise it as well
FIND . .FUNC !  \ print 1 int
FIND +      EXERCISE_2INTS
FIND -      EXERCISE_2INTS
FIND *      EXERCISE_2INTS
FIND /      EXERCISE_2INTS
FIND MOD    EXERCISE_2INTS
FIND MIN    EXERCISE_2INTS
FIND MAX    EXERCISE_2INTS
FIND OR     EXERCISE_2INTS
FIND AND    EXERCISE_2INTS
FIND XOR    EXERCISE_2INTS
FIND U<     EXERCISE_2INTS
FIND <      EXERCISE_2INTS
FIND >      EXERCISE_2INTS
FIND =      EXERCISE_2INTS
FIND U. .FUNC !  \ print as unsigned for the next test
FIND +      EXERCISE_2INTS
DECIMAL

\ Functions that accept 2 ints and return 2 ints
FIND .. .FUNC !  \ print two ints
FIND /MOD   EXERCISE_2INTS

\ Functions that accept 2 ints and return doubles
FIND D. .FUNC !  \ print double
FIND U*     EXERCISE_2INTS

\ Functions that accept 1 double and 1 int and return 2 ints
16 BASE C!        \ work in hex
FIND .. .FUNC !   \ print 2 ints
FIND U/MOD OP !  \ exercise U/MOD
DINT        1        1 EXECOP
DINT ABCD1234        1 EXECOP
DINT ABCD1234     F3AF EXECOP
DINT 12345678        0 EXECOP
DINT  2345678     C221 EXECOP
DINT        0        0 EXECOP
DINT        0      145 EXECOP
2 BASE C! 1010 BASE C!  \ back to base 10 (works in any base > 2)

\ Functions that accept 3 ints and return 1 int
FIND . .FUNC !
FIND */ EXERCISE_3INTS

\ Functions that accept 3 ints and return 2 ints
FIND .. .FUNC !
FIND */MOD EXERCISE_3INTS

\ Functions that accept 2 doubles and return 1 double
FIND UD. .FUNC !  \ print unsigned double
FIND D+ OP !      \ exercise D+
16 BASE C!        \ work in hex
DINT 7fffffff DINT 7FFFFFFF     EXECOP
DINT 7FFFFFFF DINT 80000000     EXECOP
DINT 7FFFFFFF DINT        1     EXECOP
DINT FFFFFFFF DINT        1     EXECOP
DINT FFFFFFFF DINT FFFFFFFF     EXECOP
DINT        0 DINT        0     EXECOP

\ Functions that accept 2 doubles and return 1 int
FIND . .FUNC !
FIND D< OP !
DINT 7FFFFFFF DINT 7FFFFFFF     EXECOP
DINT 80000000 DINT 7FFFFFFF     EXECOP
DINT 7FFFFFFF DINT 80000000     EXECOP
DINT 7FFFFFFF DINT        1     EXECOP
DINT        1 DINT 7FFFFFFF     EXECOP
DINT FFFFFFFF DINT        1     EXECOP
DINT        1 DINT FFFFFFFF     EXECOP
DINT FFFFFFFF DINT FFFFFFFF     EXECOP
DINT        0 DINT        0     EXECOP
DINT FFFFFFFF DINT        0     EXECOP
DINT        0 DINT FFFFFFFF     EXECOP

\ Functions that accept 1 double and return 1 double
FIND UD. .FUNC !
FIND DNEGATE OP !
DINT        0 EXECOP
DINT 7FFFFFFF EXECOP
DINT 80000000 EXECOP
DINT        1 EXECOP
DINT   123456 EXECOP
DINT        0 EXECOP

\ Float functions, using hex exponents
\ Functions that take 2 floats and return 1 float
0.100000E-3F F.       \ first positive valid value
0.999999E3F  F.       \ last valid value
0.9999999999999999999ee F.  \ no rounding for you
0.00000000000123456E-0C F.  \ normalized
0.0 F.                      \ zero
-0.0 F.                     \ no signed zero...
DINT 80000000 F.            \ but with a bit of help... ;)
DINT 40010000 F.            \ non-normalized float
DINT 00FEDCBA F.            \ non-standard zero
DINT 80FEDCBA F.            \ negative non-standard zero
DINT 3C000000 F.            \ a different zero
DINT 3D000000 F.            \ a different zero
DINT 3E000000 F.            \ a different zero
DINT 3F000000 F.            \ a different zero
DINT 40000000 F.            \ a different zero
DINT 41000000 F.            \ a different zero
DINT 42000000 F.            \ a different zero
DINT 43000000 F.            \ a different zero
DINT 44000000 F.            \ a different zero
DINT 45000000 F.            \ a different zero
DINT 46000000 F.            \ a different zero
DINT 47000000 F.            \ a different zero
DINT 48000000 F.            \ a different zero
DINT 49000000 F.            \ a different zero
DINT 4A000000 F.            \ a different zero
DINT 4B000000 F.            \ a different zero
DINT C8000000 F.            \ a different zero
DINT BE000000 F.            \ a different zero
DINT 40ABCDEF F.            \ non-decimal chars
DINT 3D0FEDCB F.            \ unnormalized non-decimal chars
0.100000E-3F 1.00001 F/ F.  \ underflows to 0.0
0. 0. F/ F.           \ Does not err, despite what the manual says
0. 0.999999 FNEGATE F/ F.
0. 0.999999 F/ F.
0.142857 7. F* F.
0.142857 7. F- F.
\ Rounding tests
0.999995 0.0000045 F+ F.
0.999995 0.00000449999 F+ F.
0.555559 11. F* F.
0. 0. F+ F.

   123456.  0.51 F- F.
   123456. -0.51 F+ F.

\ This test is known to fail, but fixing it is too complicated for very
\ little benefit:
\ 123456.  0.50 F- F.
\ 123456. -0.50 F+ F.

   123456.  0.49 F- F.
   123456. -0.49 F+ F.


-8000 UFLOAT F.
 7FFF UFLOAT F.
    0 UFLOAT F.

-1. INT .
-0.999999 INT .
-0.5 INT .
0.00001 INT .
0.5 INT .
0.51 INT .
0.49 INT .
0.999999 INT .
1. INT .
654321. INT .

DECIMAL           \ back to two 5-fingered hands


\ Test ASCII without a character
ASCII    
.

STKCHK

\ ***************************************************************************
\ VOCABULARY TESTS
\ ***************************************************************************

\ VOC1 and VOC2 are children of FORTH
VOCABULARY VOC1
VOCABULARY VOC2
: DEF1 ." FORTH-DEF1 ";

\ Activate VOC1
VOC1
DEFINITIONS

\ These words are created in VOC1
CREATE VOC1DEF1
CREATE VOC1DEF2
: DEF1 ." VOC1-DEF1 ";

\ VOC11 and VOC12 are children of VOC1
VOCABULARY VOC11
VOCABULARY VOC12

\ Activate VOC11
VOC11
DEFINITIONS
CREATE VOC11DEF1
: DEF1 ." VOC11-DEF1 ";

\ Activate VOC2
VOC2
DEFINITIONS

: DEF1 ." VOC2-DEF1 ";
CREATE VOC2DEF1
CREATE VOC2DEF2

\ VOC21 and VOC22 are children of VOC2 but not of VOC1
VOCABULARY VOC21
VOCABULARY VOC22

\ Activate VOC21
VOC21
DEFINITIONS

: DEF1 ." VOC21-DEF1 ";
CREATE VOC21DEF1

\ Go back to FORTH for definitions
FORTH
DEFINITIONS

\ Test the different versions of DEF1 depending on the context vocabulary
VOC1  DEF1
VOC2  DEF1
VOC1
  VOC11 DEF1
  VOC12 DEF1  \ VOC12 does not have DEF1 so the parent is chosen
VOC2
  VOC21 DEF1
FORTH DEF1

: MANYCTX [ VOC1 ] DEF1 [ VOC2 ] DEF1 [ VOC1 VOC11 ] DEF1 [ VOC2 VOC21 ] DEF1 ;

MANYCTX

FORTH

\ ***************************************************************************
\ COVERAGE TESTS
\ ***************************************************************************
\ Test functions not tested elsewhere

123 456 789 ROT . . .
123 456 789 2 PICK . . . .
123 456 789 2 ROLL . . .

0 0 32 WORD 12J CONVERT . . .

CURRENT .
CONTEXT .

1 2 3 4 5 6 7 8 9
ABORT  This clears the stack and also works as a line comment prefix
STKCHK

QUIT   Also works as a line comment prefix

STKCHK

\ Coverage OCD
FAST SLOW
255 IN
DROP
255 255 OUT
INVIS CR
10 SPACES 64 EMIT
<# 96 HOLD 0 0 #> TYPE CR
VIS
2105 CALL
: PI 3.14159 ; PI F.

\ Mirrors
DUMMY 1024 - 123 OVER C! C@ .
PAD   1024 - 123 OVER C! C@ .

STKCHK

\ Save the whole thing
SAVE Test
