Merge pull request #5 from pzembrod/master

More tests: prelimtest.fth and coreexttest.fth.

6502/C64/emulator/x11_sym_vf_de.vkm

@@ -261,14 +261,14 @@ ssharp         7 1 8
 # ctrl
 Tab            7 2 8
 ISO_Left_Tab   7 2 8
-Control_L      7 2 8
+# Control_L      7 2 8
 Control_R      7 2 8
 # shift+2
 quotedbl       7 3 8
 # space
 space          7 4 8
 # cbm
-# Control_L      7 5 8
+Control_L      7 5 8
 Alt_L      7 5 8
 # run/stop
 Escape         7 7 8

6502/C64/tests/ans-shim.fth

@@ -1,7 +1,8 @@
 
 : cells  2* ;
 
-: s"  [compile] " compile count ; immediate
+: s"  [compile] " compile count ; immediate restrict
+: c"  [compile] " ; immediate restrict
 
 : [char]  [compile] ascii ; immediate
 : char  [compile] ascii ;
@@ -45,3 +46,32 @@
 : tuck  under ;
 
 : :noname  here  ['] tuck @ ,  0 ] ;
+
+: <>  = not ;
+\ Wrong for -32768: : 0>  ( n --     flag)  negate 0<  ;
+: 0>  dup 0< swap 0= or not ;
+
+: 2>r  r> -rot swap >r >r >r ;
+: 2r>  r> r> r> swap rot >r ;
+: 2r@  r> r> r> 2dup >r >r swap rot >r ;
+
+: WITHIN ( test low high -- flag ) OVER - >R - R> U< ;
+
+: unused  sp@ here - ;
+: again  [compile] repeat ; immediate restrict
+
+: BUFFER:  CREATE ALLOT ;
+
+: compile,  , ;
+
+: defer!  >body ! ;
+: defer@  >body @ ;
+: action-of
+ STATE @ IF
+     POSTPONE ['] POSTPONE DEFER@
+   ELSE
+     ' DEFER@
+   THEN ; IMMEDIATE
+
+ : HOLDS ( addr u -- )
+   BEGIN DUP WHILE 1- 2DUP + C@ HOLD REPEAT 2DROP ;

6502/C64/tests/coreexttest.fth

@@ -0,0 +1,769 @@
+\ To test the ANS Forth Core Extension word set
+
+\ This program was written by Gerry Jackson in 2006, with contributions from
+\ others where indicated, and is in the public domain - it can be distributed
+\ and/or modified in any way but please retain this notice.
+
+\ This program is distributed in the hope that it will be useful,
+\ but WITHOUT ANY WARRANTY; without even the implied warranty of
+\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+\ The tests are not claimed to be comprehensive or correct
+
+\ ------------------------------------------------------------------------------
+\ Version 0.13 28 October 2015
+\              Replace <FALSE> and <TRUE> with FALSE and TRUE to avoid
+\              dependence on Core tests
+\              Moved SAVE-INPUT and RESTORE-INPUT tests in a file to filetest.fth
+\              Use of 2VARIABLE (from optional wordset) replaced with CREATE.
+\              Minor lower to upper case conversions.
+\              Calls to COMPARE replaced by S= (in utilities.fth) to avoid use
+\              of a word from an optional word set.
+\              UNUSED tests revised as UNUSED UNUSED = may return FALSE when an
+\              implementation has the data stack sharing unused dataspace.
+\              Double number input dependency removed from the HOLDS tests.
+\              Minor case sensitivities removed in definition names.
+\         0.11 25 April 2015
+\              Added tests for PARSE-NAME HOLDS BUFFER:
+\              S\" tests added
+\              DEFER IS ACTION-OF DEFER! DEFER@ tests added
+\              Empty CASE statement test added
+\              [COMPILE] tests removed because it is obsolescent in Forth 2012
+\         0.10 1 August 2014
+\             Added tests contributed by James Bowman for:
+\                <> U> 0<> 0> NIP TUCK ROLL PICK 2>R 2R@ 2R>
+\                HEX WITHIN UNUSED AGAIN MARKER
+\             Added tests for:
+\                .R U.R ERASE PAD REFILL SOURCE-ID
+\             Removed ABORT from NeverExecuted to enable Win32
+\             to continue after failure of RESTORE-INPUT.
+\             Removed max-intx which is no longer used.
+\         0.7 6 June 2012 Extra CASE test added
+\         0.6 1 April 2012 Tests placed in the public domain.
+\             SAVE-INPUT & RESTORE-INPUT tests, position
+\             of T{ moved so that tests work with ttester.fs
+\             CONVERT test deleted - obsolete word removed from Forth 200X
+\             IMMEDIATE VALUEs tested
+\             RECURSE with :NONAME tested
+\             PARSE and .( tested
+\             Parsing behaviour of C" added
+\         0.5 14 September 2011 Removed the double [ELSE] from the
+\             initial SAVE-INPUT & RESTORE-INPUT test
+\         0.4 30 November 2009  max-int replaced with max-intx to
+\             avoid redefinition warnings.
+\         0.3  6 March 2009 { and } replaced with T{ and }T
+\                           CONVERT test now independent of cell size
+\         0.2  20 April 2007 ANS Forth words changed to upper case
+\                            Tests qd3 to qd6 by Reinhold Straub
+\         0.1  Oct 2006 First version released
+\ -----------------------------------------------------------------------------
+\ The tests are based on John Hayes test program for the core word set
+
+\ Words tested in this file are:
+\     .( .R 0<> 0> 2>R 2R> 2R@ :NONAME <> ?DO AGAIN C" CASE COMPILE, ENDCASE
+\     ENDOF ERASE FALSE HEX MARKER NIP OF PAD PARSE PICK REFILL
+\     RESTORE-INPUT ROLL SAVE-INPUT SOURCE-ID TO TRUE TUCK U.R U> UNUSED
+\     VALUE WITHIN [COMPILE]
+
+\ Words not tested or partially tested:
+\     \ because it has been extensively used already and is, hence, unnecessary
+\     REFILL and SOURCE-ID from the user input device which are not possible
+\     when testing from a file such as this one
+\     UNUSED (partially tested) as the value returned is system dependent
+\     Obsolescent words #TIB CONVERT EXPECT QUERY SPAN TIB as they have been
+\     removed from the Forth 2012 standard
+
+\ Results from words that output to the user output device have to visually
+\ checked for correctness. These are .R U.R .(
+
+\ -----------------------------------------------------------------------------
+\ Assumptions & dependencies:
+\     - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been
+\       included prior to this file
+\     - the Core word set available
+\ -----------------------------------------------------------------------------
+TESTING Core Extension words
+
+DECIMAL
+
+TESTING TRUE FALSE
+
+T{ TRUE  -> 0 INVERT }T
+T{ FALSE -> 0 }T
+
+\ -----------------------------------------------------------------------------
+TESTING <> U>   (contributed by James Bowman)
+
+T{ 0 0 <> -> FALSE }T
+T{ 1 1 <> -> FALSE }T
+T{ -1 -1 <> -> FALSE }T
+T{ 1 0 <> -> TRUE }T
+T{ -1 0 <> -> TRUE }T
+T{ 0 1 <> -> TRUE }T
+T{ 0 -1 <> -> TRUE }T
+
+T{ 0 1 U> -> FALSE }T
+T{ 1 2 U> -> FALSE }T
+T{ 0 MID-UINT U> -> FALSE }T
+T{ 0 MAX-UINT U> -> FALSE }T
+T{ MID-UINT MAX-UINT U> -> FALSE }T
+T{ 0 0 U> -> FALSE }T
+T{ 1 1 U> -> FALSE }T
+T{ 1 0 U> -> TRUE }T
+T{ 2 1 U> -> TRUE }T
+T{ MID-UINT 0 U> -> TRUE }T
+T{ MAX-UINT 0 U> -> TRUE }T
+T{ MAX-UINT MID-UINT U> -> TRUE }T
+
+\ -----------------------------------------------------------------------------
+TESTING 0<> 0>   (contributed by James Bowman)
+
+T{ 0 0<> -> FALSE }T
+T{ 1 0<> -> TRUE }T
+T{ 2 0<> -> TRUE }T
+T{ -1 0<> -> TRUE }T
+T{ MAX-UINT 0<> -> TRUE }T
+T{ MIN-INT 0<> -> TRUE }T
+T{ MAX-INT 0<> -> TRUE }T
+
+T{ 0 0> -> FALSE }T
+T{ -1 0> -> FALSE }T
+T{ MIN-INT 0> -> FALSE }T
+T{ 1 0> -> TRUE }T
+T{ MAX-INT 0> -> TRUE }T
+
+\ -----------------------------------------------------------------------------
+TESTING NIP TUCK ROLL PICK   (contributed by James Bowman)
+
+T{ 1 2 NIP -> 2 }T
+T{ 1 2 3 NIP -> 1 3 }T
+
+T{ 1 2 TUCK -> 2 1 2 }T
+T{ 1 2 3 TUCK -> 1 3 2 3 }T
+
+T{ : RO5 100 200 300 400 500 ; -> }T
+T{ RO5 3 ROLL -> 100 300 400 500 200 }T
+T{ RO5 2 ROLL -> RO5 ROT }T
+T{ RO5 1 ROLL -> RO5 SWAP }T
+T{ RO5 0 ROLL -> RO5 }T
+
+T{ RO5 2 PICK -> 100 200 300 400 500 300 }T
+T{ RO5 1 PICK -> RO5 OVER }T
+T{ RO5 0 PICK -> RO5 DUP }T
+
+\ -----------------------------------------------------------------------------
+TESTING 2>R 2R@ 2R>   (contributed by James Bowman)
+
+T{ : RR0 2>R 100 R> R> ; -> }T
+T{ 300 400 RR0 -> 100 400 300 }T
+T{ 200 300 400 RR0 -> 200 100 400 300 }T
+
+T{ : RR1 2>R 100 2R@ R> R> ; -> }T
+T{ 300 400 RR1 -> 100 300 400 400 300 }T
+T{ 200 300 400 RR1 -> 200 100 300 400 400 300 }T
+
+T{ : RR2 2>R 100 2R> ; -> }T
+T{ 300 400 RR2 -> 100 300 400 }T
+T{ 200 300 400 RR2 -> 200 100 300 400 }T
+
+\ -----------------------------------------------------------------------------
+TESTING HEX   (contributed by James Bowman)
+
+T{ BASE @ HEX BASE @ DECIMAL BASE @ - SWAP BASE ! -> 6 }T
+
+\ -----------------------------------------------------------------------------
+TESTING WITHIN   (contributed by James Bowman)
+
+T{ 0 0 0 WITHIN -> FALSE }T
+T{ 0 0 MID-UINT WITHIN -> TRUE }T
+T{ 0 0 MID-UINT+1 WITHIN -> TRUE }T
+T{ 0 0 MAX-UINT WITHIN -> TRUE }T
+T{ 0 MID-UINT 0 WITHIN -> FALSE }T
+T{ 0 MID-UINT MID-UINT WITHIN -> FALSE }T
+T{ 0 MID-UINT MID-UINT+1 WITHIN -> FALSE }T
+T{ 0 MID-UINT MAX-UINT WITHIN -> FALSE }T
+T{ 0 MID-UINT+1 0 WITHIN -> FALSE }T
+T{ 0 MID-UINT+1 MID-UINT WITHIN -> TRUE }T
+T{ 0 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T
+T{ 0 MID-UINT+1 MAX-UINT WITHIN -> FALSE }T
+T{ 0 MAX-UINT 0 WITHIN -> FALSE }T
+T{ 0 MAX-UINT MID-UINT WITHIN -> TRUE }T
+T{ 0 MAX-UINT MID-UINT+1 WITHIN -> TRUE }T
+T{ 0 MAX-UINT MAX-UINT WITHIN -> FALSE }T
+T{ MID-UINT 0 0 WITHIN -> FALSE }T
+T{ MID-UINT 0 MID-UINT WITHIN -> FALSE }T
+T{ MID-UINT 0 MID-UINT+1 WITHIN -> TRUE }T
+T{ MID-UINT 0 MAX-UINT WITHIN -> TRUE }T
+T{ MID-UINT MID-UINT 0 WITHIN -> TRUE }T
+T{ MID-UINT MID-UINT MID-UINT WITHIN -> FALSE }T
+T{ MID-UINT MID-UINT MID-UINT+1 WITHIN -> TRUE }T
+T{ MID-UINT MID-UINT MAX-UINT WITHIN -> TRUE }T
+T{ MID-UINT MID-UINT+1 0 WITHIN -> FALSE }T
+T{ MID-UINT MID-UINT+1 MID-UINT WITHIN -> FALSE }T
+T{ MID-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T
+T{ MID-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T
+T{ MID-UINT MAX-UINT 0 WITHIN -> FALSE }T
+T{ MID-UINT MAX-UINT MID-UINT WITHIN -> FALSE }T
+T{ MID-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T
+T{ MID-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T
+T{ MID-UINT+1 0 0 WITHIN -> FALSE }T
+T{ MID-UINT+1 0 MID-UINT WITHIN -> FALSE }T
+T{ MID-UINT+1 0 MID-UINT+1 WITHIN -> FALSE }T
+T{ MID-UINT+1 0 MAX-UINT WITHIN -> TRUE }T
+T{ MID-UINT+1 MID-UINT 0 WITHIN -> TRUE }T
+T{ MID-UINT+1 MID-UINT MID-UINT WITHIN -> FALSE }T
+T{ MID-UINT+1 MID-UINT MID-UINT+1 WITHIN -> FALSE }T
+T{ MID-UINT+1 MID-UINT MAX-UINT WITHIN -> TRUE }T
+T{ MID-UINT+1 MID-UINT+1 0 WITHIN -> TRUE }T
+T{ MID-UINT+1 MID-UINT+1 MID-UINT WITHIN -> TRUE }T
+T{ MID-UINT+1 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T
+T{ MID-UINT+1 MID-UINT+1 MAX-UINT WITHIN -> TRUE }T
+T{ MID-UINT+1 MAX-UINT 0 WITHIN -> FALSE }T
+T{ MID-UINT+1 MAX-UINT MID-UINT WITHIN -> FALSE }T
+T{ MID-UINT+1 MAX-UINT MID-UINT+1 WITHIN -> FALSE }T
+T{ MID-UINT+1 MAX-UINT MAX-UINT WITHIN -> FALSE }T
+T{ MAX-UINT 0 0 WITHIN -> FALSE }T
+T{ MAX-UINT 0 MID-UINT WITHIN -> FALSE }T
+T{ MAX-UINT 0 MID-UINT+1 WITHIN -> FALSE }T
+T{ MAX-UINT 0 MAX-UINT WITHIN -> FALSE }T
+T{ MAX-UINT MID-UINT 0 WITHIN -> TRUE }T
+T{ MAX-UINT MID-UINT MID-UINT WITHIN -> FALSE }T
+T{ MAX-UINT MID-UINT MID-UINT+1 WITHIN -> FALSE }T
+T{ MAX-UINT MID-UINT MAX-UINT WITHIN -> FALSE }T
+T{ MAX-UINT MID-UINT+1 0 WITHIN -> TRUE }T
+T{ MAX-UINT MID-UINT+1 MID-UINT WITHIN -> TRUE }T
+T{ MAX-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T
+T{ MAX-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T
+T{ MAX-UINT MAX-UINT 0 WITHIN -> TRUE }T
+T{ MAX-UINT MAX-UINT MID-UINT WITHIN -> TRUE }T
+T{ MAX-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T
+T{ MAX-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T
+
+T{ MIN-INT MIN-INT MIN-INT WITHIN -> FALSE }T
+T{ MIN-INT MIN-INT 0 WITHIN -> TRUE }T
+T{ MIN-INT MIN-INT 1 WITHIN -> TRUE }T
+T{ MIN-INT MIN-INT MAX-INT WITHIN -> TRUE }T
+T{ MIN-INT 0 MIN-INT WITHIN -> FALSE }T
+T{ MIN-INT 0 0 WITHIN -> FALSE }T
+T{ MIN-INT 0 1 WITHIN -> FALSE }T
+T{ MIN-INT 0 MAX-INT WITHIN -> FALSE }T
+T{ MIN-INT 1 MIN-INT WITHIN -> FALSE }T
+T{ MIN-INT 1 0 WITHIN -> TRUE }T
+T{ MIN-INT 1 1 WITHIN -> FALSE }T
+T{ MIN-INT 1 MAX-INT WITHIN -> FALSE }T
+T{ MIN-INT MAX-INT MIN-INT WITHIN -> FALSE }T
+T{ MIN-INT MAX-INT 0 WITHIN -> TRUE }T
+T{ MIN-INT MAX-INT 1 WITHIN -> TRUE }T
+T{ MIN-INT MAX-INT MAX-INT WITHIN -> FALSE }T
+T{ 0 MIN-INT MIN-INT WITHIN -> FALSE }T
+T{ 0 MIN-INT 0 WITHIN -> FALSE }T
+T{ 0 MIN-INT 1 WITHIN -> TRUE }T
+T{ 0 MIN-INT MAX-INT WITHIN -> TRUE }T
+T{ 0 0 MIN-INT WITHIN -> TRUE }T
+T{ 0 0 0 WITHIN -> FALSE }T
+T{ 0 0 1 WITHIN -> TRUE }T
+T{ 0 0 MAX-INT WITHIN -> TRUE }T
+T{ 0 1 MIN-INT WITHIN -> FALSE }T
+T{ 0 1 0 WITHIN -> FALSE }T
+T{ 0 1 1 WITHIN -> FALSE }T
+T{ 0 1 MAX-INT WITHIN -> FALSE }T
+T{ 0 MAX-INT MIN-INT WITHIN -> FALSE }T
+T{ 0 MAX-INT 0 WITHIN -> FALSE }T
+T{ 0 MAX-INT 1 WITHIN -> TRUE }T
+T{ 0 MAX-INT MAX-INT WITHIN -> FALSE }T
+T{ 1 MIN-INT MIN-INT WITHIN -> FALSE }T
+T{ 1 MIN-INT 0 WITHIN -> FALSE }T
+T{ 1 MIN-INT 1 WITHIN -> FALSE }T
+T{ 1 MIN-INT MAX-INT WITHIN -> TRUE }T
+T{ 1 0 MIN-INT WITHIN -> TRUE }T
+T{ 1 0 0 WITHIN -> FALSE }T
+T{ 1 0 1 WITHIN -> FALSE }T
+T{ 1 0 MAX-INT WITHIN -> TRUE }T
+T{ 1 1 MIN-INT WITHIN -> TRUE }T
+T{ 1 1 0 WITHIN -> TRUE }T
+T{ 1 1 1 WITHIN -> FALSE }T
+T{ 1 1 MAX-INT WITHIN -> TRUE }T
+T{ 1 MAX-INT MIN-INT WITHIN -> FALSE }T
+T{ 1 MAX-INT 0 WITHIN -> FALSE }T
+T{ 1 MAX-INT 1 WITHIN -> FALSE }T
+T{ 1 MAX-INT MAX-INT WITHIN -> FALSE }T
+T{ MAX-INT MIN-INT MIN-INT WITHIN -> FALSE }T
+T{ MAX-INT MIN-INT 0 WITHIN -> FALSE }T
+T{ MAX-INT MIN-INT 1 WITHIN -> FALSE }T
+T{ MAX-INT MIN-INT MAX-INT WITHIN -> FALSE }T
+T{ MAX-INT 0 MIN-INT WITHIN -> TRUE }T
+T{ MAX-INT 0 0 WITHIN -> FALSE }T
+T{ MAX-INT 0 1 WITHIN -> FALSE }T
+T{ MAX-INT 0 MAX-INT WITHIN -> FALSE }T
+T{ MAX-INT 1 MIN-INT WITHIN -> TRUE }T
+T{ MAX-INT 1 0 WITHIN -> TRUE }T
+T{ MAX-INT 1 1 WITHIN -> FALSE }T
+T{ MAX-INT 1 MAX-INT WITHIN -> FALSE }T
+T{ MAX-INT MAX-INT MIN-INT WITHIN -> TRUE }T
+T{ MAX-INT MAX-INT 0 WITHIN -> TRUE }T
+T{ MAX-INT MAX-INT 1 WITHIN -> TRUE }T
+T{ MAX-INT MAX-INT MAX-INT WITHIN -> FALSE }T
+
+\ -----------------------------------------------------------------------------
+TESTING UNUSED  (contributed by James Bowman & Peter Knaggs)
+
+VARIABLE UNUSED0
+T{ UNUSED DROP -> }T
+T{ ALIGN UNUSED UNUSED0 ! 0 , UNUSED CELL+ UNUSED0 @ = -> TRUE }T
+T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ =
+         -> TRUE }T  \ aligned -> unaligned
+T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ = -> TRUE }T  \ unaligned -> ?
+
+\ -----------------------------------------------------------------------------
+TESTING AGAIN   (contributed by James Bowman)
+
+T{ : AG0 701 BEGIN DUP 7 MOD 0= IF EXIT THEN 1+ AGAIN ; -> }T
+T{ AG0 -> 707 }T
+
+\ -----------------------------------------------------------------------------
+\vf TESTING MARKER   (contributed by James Bowman)
+
+\vf T{ : MA? BL WORD FIND NIP 0<> ; -> }T
+\vf T{ MARKER MA0 -> }T
+\vf T{ : MA1 111 ; -> }T
+\vf T{ MARKER MA2 -> }T
+\vf T{ : MA1 222 ; -> }T
+\vf T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE TRUE }T
+\vf T{ MA1 MA2 MA1 -> 222 111 }T
+\vf T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE FALSE }T
+\vf T{ MA0 -> }T
+\vf T{ MA? MA0 MA? MA1 MA? MA2 -> FALSE FALSE FALSE }T
+
+\ -----------------------------------------------------------------------------
+TESTING ?DO
+
+: 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 ITERS
+VARIABLE INCRMNT
+
+: QD6 ( limit start increment -- )
+   INCRMNT !
+   0 ITERS !
+   ?DO
+      1 ITERS +!
+      I
+      ITERS @  6 = IF LEAVE THEN
+      INCRMNT @
+   +LOOP ITERS @
+;
+
+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
+
+\ -----------------------------------------------------------------------------
+TESTING BUFFER:
+
+T{ 8 BUFFER: BUF:TEST -> }T
+T{ BUF:TEST DUP ALIGNED = -> TRUE }T
+T{ 111 BUF:TEST ! 222 BUF:TEST CELL+ ! -> }T
+T{ BUF:TEST @ BUF:TEST CELL+ @ -> 111 222 }T
+
+\ -----------------------------------------------------------------------------
+\vf TESTING VALUE TO
+
+\vf T{ 111 VALUE VAL1 -999 VALUE VAL2 -> }T
+\vf T{ VAL1 -> 111 }T
+\vf T{ VAL2 -> -999 }T
+\vf T{ 222 TO VAL1 -> }T
+\vf T{ VAL1 -> 222 }T
+\vf T{ : VD1 VAL1 ; -> }T
+\vf T{ VD1 -> 222 }T
+\vf T{ : VD2 TO VAL2 ; -> }T
+\vf T{ VAL2 -> -999 }T
+\vf T{ -333 VD2 -> }T
+\vf T{ VAL2 -> -333 }T
+\vf T{ VAL1 -> 222 }T
+\vf T{ 123 VALUE VAL3 IMMEDIATE VAL3 -> 123 }T
+\vf T{ : VD3 VAL3 LITERAL ; VD3 -> 123 }T
+
+\ -----------------------------------------------------------------------------
+\vf TESTING CASE OF ENDOF ENDCASE
+
+\vf : CS1 CASE 1 OF 111 ENDOF
+\vf            2 OF 222 ENDOF
+\vf            3 OF 333 ENDOF
+\vf            >R 999 R>
+\vf       ENDCASE
+\vf ;
+
+\vf T{ 1 CS1 -> 111 }T
+\vf T{ 2 CS1 -> 222 }T
+\vf T{ 3 CS1 -> 333 }T
+\vf T{ 4 CS1 -> 999 }T
+
+\ Nested CASE's
+
+\vf : CS2 >R CASE -1 OF CASE R@ 1 OF 100 ENDOF
+\vf                             2 OF 200 ENDOF
+\vf                            >R -300 R>
+\vf                     ENDCASE
+\vf                  ENDOF
+\vf               -2 OF CASE R@ 1 OF -99  ENDOF
+\vf                             >R -199 R>
+\vf                     ENDCASE
+\vf                  ENDOF
+\vf                  >R 299 R>
+\vf          ENDCASE R> DROP
+\vf ;
+
+\vf T{ -1 1 CS2 ->  100 }T
+\vf T{ -1 2 CS2 ->  200 }T
+\vf T{ -1 3 CS2 -> -300 }T
+\vf T{ -2 1 CS2 -> -99  }T
+\vf T{ -2 2 CS2 -> -199 }T
+\vf T{  0 2 CS2 ->  299 }T
+
+\ Boolean short circuiting using CASE
+
+\vf : CS3  ( N1 -- N2 )
+\vf    CASE 1- FALSE OF 11 ENDOF
+\vf         1- FALSE OF 22 ENDOF
+\vf         1- FALSE OF 33 ENDOF
+\vf         44 SWAP
+\vf    ENDCASE
+\vf ;
+
+\vf T{ 1 CS3 -> 11 }T
+\vf T{ 2 CS3 -> 22 }T
+\vf T{ 3 CS3 -> 33 }T
+\vf T{ 9 CS3 -> 44 }T
+
+\ Empty CASE statements with/without default
+
+\vf T{ : CS4 CASE ENDCASE ; 1 CS4 -> }T
+\vf T{ : CS5 CASE 2 SWAP ENDCASE ; 1 CS5 -> 2 }T
+\vf T{ : CS6 CASE 1 OF ENDOF 2 ENDCASE ; 1 CS6 -> }T
+\vf T{ : CS7 CASE 3 OF ENDOF 2 ENDCASE ; 1 CS7 -> 1 }T
+
+\ -----------------------------------------------------------------------------
+\vf TESTING :NONAME RECURSE
+
+\vf VARIABLE NN1
+\vf VARIABLE NN2
+\vf :NONAME 1234 ; NN1 !
+\vf :NONAME 9876 ; NN2 !
+\vf T{ NN1 @ EXECUTE -> 1234 }T
+\vf T{ NN2 @ EXECUTE -> 9876 }T
+
+\vf T{ :NONAME ( n -- 0,1,..n ) DUP IF DUP >R 1- RECURSE R> THEN ;
+\vf    CONSTANT RN1 -> }T
+\vf T{ 0 RN1 EXECUTE -> 0 }T
+\vf T{ 4 RN1 EXECUTE -> 0 1 2 3 4 }T
+
+\vf :NONAME  ( n -- n1 )    \ Multiple RECURSEs in one definition
+\vf    1- DUP
+\vf    CASE 0 OF EXIT ENDOF
+\vf         1 OF 11 SWAP RECURSE ENDOF
+\vf         2 OF 22 SWAP RECURSE ENDOF
+\vf         3 OF 33 SWAP RECURSE ENDOF
+\vf         DROP ABS RECURSE EXIT
+\vf    ENDCASE
+\vf ; CONSTANT RN2
+
+\vf T{  1 RN2 EXECUTE -> 0 }T
+\vf T{  2 RN2 EXECUTE -> 11 0 }T
+\vf T{  4 RN2 EXECUTE -> 33 22 11 0 }T
+\vf T{ 25 RN2 EXECUTE -> 33 22 11 0 }T
+
+\ -----------------------------------------------------------------------------
+\vf TESTING C"
+
+T{ : CQ1 C" 123" ; -> }T
+\vf T{ CQ1 COUNT EVALUATE -> 123 }T
+T{ : CQ2 C" " ; -> }T
+\vf T{ CQ2 COUNT EVALUATE -> }T
+\vf T{ : CQ3 C" 2345"COUNT EVALUATE ; CQ3 -> 2345 }T
+
+\ -----------------------------------------------------------------------------
+TESTING COMPILE,
+
+:NONAME DUP + ; CONSTANT DUP+
+T{ : Q DUP+ COMPILE, ; -> }T
+T{ : AS1 [ Q ] ; -> }T
+T{ 123 AS1 -> 246 }T
+
+\ -----------------------------------------------------------------------------
+\ Cannot automatically test SAVE-INPUT and RESTORE-INPUT from a console source
+
+\vf TESTING SAVE-INPUT and RESTORE-INPUT with a string source
+
+\vf VARIABLE SI_INC 0 SI_INC !
+
+\vf : SI1
+\vf    SI_INC @ >IN +!
+\vf    15 SI_INC !
+\vf ;
+
+\vf : S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ;
+
+\vf T{ S$ EVALUATE SI_INC @ -> 0 2345 15 }T
+
+\ -----------------------------------------------------------------------------
+TESTING .(
+
+CR CR .( Output from .()
+T{ CR .( You should see -9876: ) -9876 . -> }T
+T{ CR .( and again: ).( -9876)CR -> }T
+
+CR CR .( On the next 2 lines you should see First then Second messages:)
+T{ : DOTP  CR ." Second message via ." [CHAR] " EMIT    \ Check .( is immediate
+     [ CR ] .( First message via .( ) ; DOTP -> }T
+CR CR
+T{ : IMM? BL WORD FIND NIP ; IMM? .( -> 1 }T
+
+\ -----------------------------------------------------------------------------
+TESTING .R and U.R - has to handle different cell sizes
+
+\ Create some large integers just below/above MAX and Min INTs
+MAX-INT 73 79 */ CONSTANT LI1
+MIN-INT 71 73 */ CONSTANT LI2
+
+LI1 0 <# #S #> NIP CONSTANT LENLI1
+
+: (.R&U.R)  ( u1 u2 -- )  \ u1 <= string length, u2 is required indentation
+   TUCK + >R
+   LI1 OVER SPACES  . CR R@    LI1 SWAP  .R CR
+   LI2 OVER SPACES  . CR R@ 1+ LI2 SWAP  .R CR
+   LI1 OVER SPACES U. CR R@    LI1 SWAP U.R CR
+   LI2 SWAP SPACES U. CR R>    LI2 SWAP U.R CR
+;
+
+: .R&U.R  ( -- )
+   CR ." You should see lines duplicated:" CR
+   ." indented by 0 spaces" CR 0      0 (.R&U.R) CR
+   ." indented by 0 spaces" CR LENLI1 0 (.R&U.R) CR \ Just fits required width
+   ." indented by 5 spaces" CR LENLI1 5 (.R&U.R) CR
+;
+
+CR CR .( Output from .R and U.R)
+T{ .R&U.R -> }T
+
+\ -----------------------------------------------------------------------------
+TESTING PAD ERASE
+\ Must handle different size characters i.e. 1 CHARS >= 1
+
+84 CONSTANT CHARS/PAD      \ Minimum size of PAD in chars
+CHARS/PAD CHARS CONSTANT AUS/PAD
+: CHECKPAD  ( caddr u ch -- f )  \ f = TRUE if u chars = ch
+   SWAP 0
+   ?DO
+      OVER I CHARS + C@ OVER <>
+      IF 2DROP UNLOOP FALSE EXIT THEN
+   LOOP
+   2DROP TRUE
+;
+
+T{ PAD DROP -> }T
+T{ 0 INVERT PAD C! -> }T
+T{ PAD C@ CONSTANT MAXCHAR -> }T
+T{ PAD CHARS/PAD 2DUP MAXCHAR FILL MAXCHAR CHECKPAD -> TRUE }T
+T{ PAD CHARS/PAD 2DUP CHARS ERASE 0 CHECKPAD -> TRUE }T
+T{ PAD CHARS/PAD 2DUP MAXCHAR FILL PAD 0 ERASE MAXCHAR CHECKPAD -> TRUE }T
+T{ PAD 43 CHARS + 9 CHARS ERASE -> }T
+T{ PAD 43 MAXCHAR CHECKPAD -> TRUE }T
+T{ PAD 43 CHARS + 9 0 CHECKPAD -> TRUE }T
+T{ PAD 52 CHARS + CHARS/PAD 52 - MAXCHAR CHECKPAD -> TRUE }T
+
+\ Check that use of WORD and pictured numeric output do not corrupt PAD
+\ Minimum size of buffers for these are 33 chars and (2*n)+2 chars respectively
+\ where n is number of bits per cell
+
+PAD CHARS/PAD ERASE
+2 BASE !
+MAX-UINT MAX-UINT <# #S CHAR 1 DUP HOLD HOLD #> 2DROP
+DECIMAL
+BL WORD 12345678123456781234567812345678 DROP
+T{ PAD CHARS/PAD 0 CHECKPAD -> TRUE }T
+
+\ -----------------------------------------------------------------------------
+\vf TESTING PARSE
+
+\vf T{ CHAR | PARSE 1234| DUP ROT ROT EVALUATE -> 4 1234 }T
+\vf T{ CHAR ^ PARSE  23 45 ^ DUP ROT ROT EVALUATE -> 7 23 45 }T
+\vf : PA1 [CHAR] $ PARSE DUP >R PAD SWAP CHARS MOVE PAD R> ;
+\vf T{ PA1 3456
+\vf    DUP ROT ROT EVALUATE -> 4 3456 }T
+\vf T{ CHAR A PARSE A SWAP DROP -> 0 }T
+\vf T{ CHAR Z PARSE
+\vf    SWAP DROP -> 0 }T
+\vf T{ CHAR " PARSE 4567 "DUP ROT ROT EVALUATE -> 5 4567 }T
+
+\ -----------------------------------------------------------------------------
+\vf TESTING PARSE-NAME  (Forth 2012)
+\ Adapted from the PARSE-NAME RfD tests
+\vf T{ PARSE-NAME abcd  STR1  S= -> TRUE }T        \ No leading spaces
+\vf T{ PARSE-NAME      abcde STR2 S= -> TRUE }T    \ Leading spaces
+
+\ Test empty parse area, new lines are necessary
+\vf T{ PARSE-NAME
+\vf   NIP -> 0 }T
+\ Empty parse area with spaces after PARSE-NAME
+\vf T{ PARSE-NAME
+\vf   NIP -> 0 }T
+
+\vf T{ : PARSE-NAME-TEST ( "name1" "name2" -- n )
+\vf     PARSE-NAME PARSE-NAME S= ; -> }T
+\vf T{ PARSE-NAME-TEST abcd abcd  -> TRUE }T
+\vf T{ PARSE-NAME-TEST abcd   abcd  -> TRUE }T  \ Leading spaces
+\vf T{ PARSE-NAME-TEST abcde abcdf -> FALSE }T
+\vf T{ PARSE-NAME-TEST abcdf abcde -> FALSE }T
+\vf T{ PARSE-NAME-TEST abcde abcde
+\vf    -> TRUE }T         \ Parse to end of line
+\vf T{ PARSE-NAME-TEST abcde           abcde
+\vf    -> TRUE }T         \ Leading and trailing spaces
+
+\ -----------------------------------------------------------------------------
+TESTING DEFER DEFER@ DEFER! IS ACTION-OF (Forth 2012)
+\ Adapted from the Forth 200X RfD tests
+
+T{ DEFER DEFER1 -> }T
+T{ : MY-DEFER DEFER ; -> }T
+T{ : IS-DEFER1 IS DEFER1 ; -> }T
+T{ : ACTION-DEFER1 ACTION-OF DEFER1 ; -> }T
+T{ : DEF! DEFER! ; -> }T
+T{ : DEF@ DEFER@ ; -> }T
+
+T{ ' * ' DEFER1 DEFER! -> }T
+T{ 2 3 DEFER1 -> 6 }T
+T{ ' DEFER1 DEFER@ -> ' * }T
+T{ ' DEFER1 DEF@ -> ' * }T
+T{ ACTION-OF DEFER1 -> ' * }T
+T{ ACTION-DEFER1 -> ' * }T
+T{ ' + IS DEFER1 -> }T
+T{ 1 2 DEFER1 -> 3 }T
+T{ ' DEFER1 DEFER@ -> ' + }T
+T{ ' DEFER1 DEF@ -> ' + }T
+T{ ACTION-OF DEFER1 -> ' + }T
+T{ ACTION-DEFER1 -> ' + }T
+T{ ' - IS-DEFER1 -> }T
+T{ 1 2 DEFER1 -> -1 }T
+T{ ' DEFER1 DEFER@ -> ' - }T
+T{ ' DEFER1 DEF@ -> ' - }T
+T{ ACTION-OF DEFER1 -> ' - }T
+T{ ACTION-DEFER1 -> ' - }T
+
+T{ MY-DEFER DEFER2 -> }T
+T{ ' DUP IS DEFER2 -> }T
+T{ 1 DEFER2 -> 1 1 }T
+
+\ -----------------------------------------------------------------------------
+TESTING HOLDS  (Forth 2012)
+
+: HTEST S" Testing HOLDS" ;
+: HTEST2 S" works" ;
+: HTEST3 S" Testing HOLDS works 123" ;
+T{ 0 0 <#  HTEST HOLDS #> HTEST S= -> TRUE }T
+T{ 123 0 <# #S BL HOLD HTEST2 HOLDS BL HOLD HTEST HOLDS #>
+   HTEST3 S= -> TRUE }T
+T{ : HLD HOLDS ; -> }T
+T{ 0 0 <#  HTEST HLD #> HTEST S= -> TRUE }T
+
+\ -----------------------------------------------------------------------------
+\vf TESTING REFILL SOURCE-ID
+\ REFILL and SOURCE-ID from the user input device can't be tested from a file,
+\ can only be tested from a string via EVALUATE
+
+\vf T{ : RF1  S" REFILL" EVALUATE ; RF1 -> FALSE }T
+\vf T{ : SID1  S" SOURCE-ID" EVALUATE ; SID1 -> -1 }T
+
+\ ------------------------------------------------------------------------------
+\vf TESTING S\"  (Forth 2012 compilation mode)
+\ Extended the Forth 200X RfD tests
+\ Note this tests the Core Ext definition of S\" which has unedfined
+\ interpretation semantics. S\" in interpretation mode is tested in the tests on
+\ the File-Access word set
+
+\vf T{ : SSQ1 S\" abc" S" abc" S= ; -> }T  \ No escapes
+\vf T{ SSQ1 -> TRUE }T
+\vf T{ : SSQ2 S\" " ; SSQ2 SWAP DROP -> 0 }T    \ Empty string
+
+\vf T{ : SSQ3 S\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" ; -> }T
+\vf T{ SSQ3 SWAP DROP          ->  20 }T    \ String length
+\vf T{ SSQ3 DROP            C@ ->   7 }T    \ \a   BEL  Bell
+\vf T{ SSQ3 DROP  1 CHARS + C@ ->   8 }T    \ \b   BS   Backspace
+\vf T{ SSQ3 DROP  2 CHARS + C@ ->  27 }T    \ \e   ESC  Escape
+\vf T{ SSQ3 DROP  3 CHARS + C@ ->  12 }T    \ \f   FF   Form feed
+\vf T{ SSQ3 DROP  4 CHARS + C@ ->  10 }T    \ \l   LF   Line feed
+\vf T{ SSQ3 DROP  5 CHARS + C@ ->  13 }T    \ \m        CR of CR/LF pair
+\vf T{ SSQ3 DROP  6 CHARS + C@ ->  10 }T    \           LF of CR/LF pair
+\vf T{ SSQ3 DROP  7 CHARS + C@ ->  34 }T    \ \q   "    Double Quote
+\vf T{ SSQ3 DROP  8 CHARS + C@ ->  13 }T    \ \r   CR   Carriage Return
+\vf T{ SSQ3 DROP  9 CHARS + C@ ->   9 }T    \ \t   TAB  Horizontal Tab
+\vf T{ SSQ3 DROP 10 CHARS + C@ ->  11 }T    \ \v   VT   Vertical Tab
+\vf T{ SSQ3 DROP 11 CHARS + C@ ->  15 }T    \ \x0F      Given Char
+\vf T{ SSQ3 DROP 12 CHARS + C@ ->  48 }T    \ 0    0    Digit follow on
+\vf T{ SSQ3 DROP 13 CHARS + C@ ->  31 }T    \ \x1F      Given Char
+\vf T{ SSQ3 DROP 14 CHARS + C@ ->  97 }T    \ a    a    Hex follow on
+\vf T{ SSQ3 DROP 15 CHARS + C@ -> 171 }T    \ \xaB      Insensitive Given Char
+\vf T{ SSQ3 DROP 16 CHARS + C@ -> 120 }T    \ x    x    Non hex follow on
+\vf T{ SSQ3 DROP 17 CHARS + C@ ->   0 }T    \ \z   NUL  No Character
+\vf T{ SSQ3 DROP 18 CHARS + C@ ->  34 }T    \ \"   "    Double Quote
+\vf T{ SSQ3 DROP 19 CHARS + C@ ->  92 }T    \ \\   \    Back Slash
+
+\ The above does not test \n as this is a system dependent value.
+\ Check it displays a new line
+\vf CR .( The next test should display:)
+\vf CR .( One line...)
+\vf CR .( another line)
+\vf T{ : SSQ4 S\" \nOne line...\nanotherLine\n" type ; SSQ4 -> }T
+
+\ Test bare escapable characters appear as themselves
+\vf T{ : SSQ5 S\" abeflmnqrtvxz" S" abeflmnqrtvxz" S= ; SSQ5 -> TRUE }T
+
+\vf T{ : SSQ6 S\" a\""2DROP 1111 ; SSQ6 -> 1111 }T \ Parsing behaviour
+
+\vf T{ : SSQ7  S\" 111 : SSQ8 s\\\" 222\" EVALUATE ; SSQ8 333" EVALUATE ; -> }T
+\vf T{ SSQ7 -> 111 222 333 }T
+\vf T{ : SSQ9  S\" 11 : SSQ10 s\\\" \\x32\\x32\" EVALUATE ; SSQ10 33" EVALUATE ; -> }T
+\vf T{ SSQ9 -> 11 22 33 }T
+
+\ -----------------------------------------------------------------------------
+CORE-EXT-ERRORS SET-ERROR-COUNT
+
+CR .( End of Core Extension word tests) CR
+
+

6502/C64/tests/errorreport.fth

@@ -0,0 +1,88 @@
+\ To collect and report on the number of errors resulting from running the
+\ ANS Forth and Forth 2012 test programs
+
+\ This program was written by Gerry Jackson in 2015, and is in the public
+\ domain - it can be distributed and/or modified in any way but please
+\ retain this notice.
+
+\ This program is distributed in the hope that it will be useful,
+\ but WITHOUT ANY WARRANTY; without even the implied warranty of
+\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+\ ------------------------------------------------------------------------------
+\ This file is INCLUDED after Core tests are complete and only uses Core words
+\ already tested. The purpose of this file is to count errors in test results
+\ and present them as a summary at the end of the tests.
+
+DECIMAL
+
+VARIABLE TOTAL-ERRORS
+
+: ERROR-COUNT  ( "name" n1 -- n2 )  \ n2 = n1 + 1cell
+   CREATE  DUP , CELL+
+   DOES>  ( -- offset ) @     \ offset in address units
+;
+
+0     \ Offset into ERRORS[] array
+ERROR-COUNT CORE-ERRORS          ERROR-COUNT CORE-EXT-ERRORS
+ERROR-COUNT DOUBLE-ERRORS        ERROR-COUNT EXCEPTION-ERRORS
+ERROR-COUNT FACILITY-ERRORS      ERROR-COUNT FILE-ERRORS
+ERROR-COUNT LOCALS-ERRORS        ERROR-COUNT MEMORY-ERRORS
+ERROR-COUNT SEARCHORDER-ERRORS   ERROR-COUNT STRING-ERRORS
+ERROR-COUNT TOOLS-ERRORS         ERROR-COUNT BLOCK-ERRORS
+CREATE ERRORS[] DUP ALLOT CONSTANT #ERROR-COUNTS
+
+\ SET-ERROR-COUNT called at the end of each test file with its own offset into
+\ the ERRORS[] array. #ERRORS is in files tester.fr and ttester.fs
+
+: SET-ERROR-COUNT  ( offset -- )
+   #ERRORS @ SWAP ERRORS[] + !
+   #ERRORS @ TOTAL-ERRORS +!
+   0 #ERRORS !
+;
+
+: INIT-ERRORS  ( -- )
+   ERRORS[] #ERROR-COUNTS OVER + SWAP DO -1 I ! 1 CELLS +LOOP
+   0 TOTAL-ERRORS !
+   CORE-ERRORS SET-ERROR-COUNT
+;
+
+INIT-ERRORS
+
+\ Report summary of errors
+
+25 CONSTANT MARGIN
+
+: SHOW-ERROR-LINE  ( n caddr u -- )
+   CR SWAP OVER TYPE MARGIN - ABS >R
+   DUP -1 = IF DROP R> 1- SPACES ." -" ELSE
+   R> .R THEN
+;
+
+: SHOW-ERROR-COUNT  ( caddr u offset -- )
+   ERRORS[] + @ ROT ROT SHOW-ERROR-LINE
+;
+
+: HLINE  ( -- )  CR ." ---------------------------"  ;
+
+: REPORT-ERRORS
+   HLINE
+   CR 8 SPACES ." Error Report"
+   CR ." Word Set" 13 SPACES ." Errors"
+   HLINE
+   S" Core" CORE-ERRORS SHOW-ERROR-COUNT
+   S" Core extension" CORE-EXT-ERRORS SHOW-ERROR-COUNT
+   S" Block" BLOCK-ERRORS SHOW-ERROR-COUNT
+   S" Double number" DOUBLE-ERRORS SHOW-ERROR-COUNT
+   S" Exception" EXCEPTION-ERRORS SHOW-ERROR-COUNT
+   S" Facility" FACILITY-ERRORS SHOW-ERROR-COUNT
+   S" File-access" FILE-ERRORS SHOW-ERROR-COUNT
+   S" Locals"    LOCALS-ERRORS SHOW-ERROR-COUNT
+   S" Memory-allocation" MEMORY-ERRORS SHOW-ERROR-COUNT
+   S" Programming-tools" TOOLS-ERRORS SHOW-ERROR-COUNT
+   S" Search-order" SEARCHORDER-ERRORS SHOW-ERROR-COUNT
+   S" String" STRING-ERRORS SHOW-ERROR-COUNT
+   HLINE
+   TOTAL-ERRORS @ S" Total" SHOW-ERROR-LINE
+   HLINE CR CR
+;

6502/C64/tests/prelimtest.fth

@@ -0,0 +1,233 @@
+CR CR SOURCE TYPE ( Preliminary test ) CR
+SOURCE ( These lines test SOURCE, TYPE, CR and parenthetic comments ) TYPE CR
+( The next line of output should be blank to test CR ) SOURCE TYPE CR CR
+
+( It is now assumed that SOURCE, TYPE, CR and comments work. SOURCE and      )
+( TYPE will be used to report test passes until something better can be      )
+( defined to report errors. Until then reporting failures will depend on the )
+( system under test and will usually be via reporting an unrecognised word   )
+( or possibly the system crashing. Tests will be numbered by #n from now on  )
+( to assist fault finding. Test successes will be indicated by               )
+( 'Pass: #n ...' and failures by 'Error: #n ...'                             )
+
+( Initial tests of >IN +! and 1+ )
+( Check that n >IN +! acts as an interpretive IF, where n >= 0 )
+( Pass #1: testing 0 >IN +! ) 0 >IN +! SOURCE TYPE CR
+( Pass #2: testing 1 >IN +! ) 1 >IN +! xSOURCE TYPE CR
+( Pass #3: testing 1+ ) 1 1+ >IN +! xxSOURCE TYPE CR
+
+( Test results can now be reported using the >IN +! trick to skip )
+( 1 or more characters )
+
+( The value of BASE is unknown so it is not safe to use digits > 1, therefore )
+( it will be set it to binary and then decimal, this also tests @ and ! )
+
+( Pass #4: testing @ ! BASE ) 0 1+ 1+ BASE ! BASE @ >IN +! xxSOURCE TYPE CR
+( Set BASE to decimal ) 1010 BASE !
+( Pass #5: testing decimal BASE ) BASE @ >IN +! xxxxxxxxxxSOURCE TYPE CR
+
+( Now in decimal mode and digits >1 can be used )
+
+( A better error reporting word is needed, much like .( which can't  )
+( be used as it is in the Core Extension word set, similarly PARSE can't be )
+( used either, only WORD is available to parse a message and must be used   )
+( in a colon definition. Therefore a simple colon definition is tested next )
+
+( Pass #6: testing : ; ) : .SRC SOURCE TYPE CR ; 6 >IN +! xxxxxx.SRC
+( Pass #7: testing number input ) 19 >IN +! xxxxxxxxxxxxxxxxxxx.SRC
+
+( VARIABLE is now tested as one will be used instead of DROP e.g. Y ! )
+
+( Pass #8: testing VARIABLE ) VARIABLE Y 2 Y ! Y @ >IN +! xx.SRC
+
+: MSG 41 WORD COUNT ;  ( 41 is the ASCII code for right parenthesis )
+( The next tests MSG leaves 2 items on the data stack )
+( Pass #9: testing WORD COUNT ) 5 MSG abcdef) Y ! Y ! >IN +! xxxxx.SRC
+( Pass #10: testing WORD COUNT ) MSG ab) >IN +! xxY ! .SRC
+
+( For reporting success .MSG( is now defined )
+: .MSG( MSG TYPE ; .MSG( Pass #11: testing WORD COUNT .MSG) CR
+
+( To define an error reporting word, = 2* AND will be needed, test them first )
+( This assumes 2's complement arithmetic )
+1 1 = 1+ 1+ >IN +! x.MSG( Pass #12: testing = returns all 1's for true) CR
+1 0 = 1+ >IN +! x.MSG( Pass #13: testing = returns 0 for false) CR
+1 1 = -1 = 1+ 1+ >IN +! x.MSG( Pass #14: testing -1 interpreted correctly) CR
+
+1 2* >IN +! xx.MSG( Pass #15: testing 2*) CR
+-1 2* 1+ 1+ 1+ >IN +! x.MSG( Pass #16: testing 2*) CR
+
+-1 -1 AND 1+ 1+ >IN +! x.MSG( Pass #17: testing AND) CR
+-1  0 AND 1+ >IN +! x.MSG( Pass #18: testing AND) CR
+6  -1 AND >IN +! xxxxxx.MSG( Pass #19: testing AND) CR
+
+( Define ~ to use as a 'to end of line' comment. \ cannot be used as it a )
+( Core Extension word )
+: ~  ( -- )  SOURCE >IN ! Y ! ;
+
+( Rather than relying on a pass message test words can now be defined to )
+( report errors in the event of a failure. For convenience words ?T~ and )
+( ?F~ are defined together with a helper ?~~ to test for TRUE and FALSE  )
+( Usage is: <test> ?T~ Error #n: <message>                               )
+( Success makes >IN index the ~ in ?T~ or ?F~ to skip the error message. )
+( Hence it is essential there is only 1 space between ?T~ and Error      )
+
+: ?~~  ( -1 | 0 -- )  2* >IN +! ;
+: ?F~ ( f -- )   0 = ?~~ ;
+: ?T~ ( f -- )  -1 = ?~~ ;
+
+( Errors will be counted )
+VARIABLE #ERRS 0 #ERRS !
+: Error  1 #ERRS +! -6 >IN +! .MSG( CR ;
+: Pass  -1 #ERRS +! 1 >IN +! Error ;  ~ Pass is defined solely to test Error
+
+-1 ?F~ Pass #20: testing ?F~ ?~~ Pass Error
+-1 ?T~ Error #1: testing ?T~ ?~~ ~
+
+0  0 = 0= ?F~ Error #2: testing 0=
+1  0 = 0= ?T~ Error #3: testing 0=
+-1 0 = 0= ?T~ Error #4: testing 0=
+
+0  0 = ?T~ Error #5: testing =
+0  1 = ?F~ Error #6: testing =
+1  0 = ?F~ Error #7: testing =
+-1 1 = ?F~ Error #8: testing =
+1 -1 = ?F~ Error #9: testing =
+
+-1 0< ?T~ Error #10: testing 0<
+0  0< ?F~ Error #11: testing 0<
+1  0< ?F~ Error #12: testing 0<
+
+ DEPTH 1+ DEPTH = ?~~ Error #13: testing DEPTH
+ ~ Up to now whether the data stack was empty or not hasn't mattered as
+ ~ long as it didn't overflow. Now it will be emptied - also
+ ~ removing any unreported underflow
+ DEPTH 0< 0= 1+ >IN +! ~ 0 0 >IN ! Remove any underflow
+ DEPTH 0= 1+ >IN +! ~ Y !  0 >IN ! Empty the stack
+ DEPTH 0= ?T~ Error #14: data stack not emptied
+
+ 4 -5 SWAP 4 = SWAP -5 = = ?T~ Error #15: testing SWAP
+ 111 222 333 444
+ DEPTH 4 = ?T~ Error #16: testing DEPTH
+ 444 = SWAP 333 = = DEPTH 3 = = ?T~ Error #17: testing SWAP DEPTH
+ 222 = SWAP 111 = = DEPTH 1 = = ?T~ Error #18: testing SWAP DEPTH
+ DEPTH 0= ?T~ Error #19: testing DEPTH = 0
+
+~ From now on the stack is expected to be empty after a test so
+~ ?~ will be defined to include a check on the stack depth. Note
+~ that ?~~ was defined and used earlier instead of ?~ to avoid
+~ (irritating) redefinition messages that many systems display had
+~ ?~ simply been redefined
+
+: ?~  ( -1 | 0 -- )  DEPTH 1 = AND ?~~ ; ~ -1 test success, 0 test failure
+
+123 -1 ?~ Pass #21: testing ?~
+Y !   ~ equivalent to DROP
+
+~ Testing the remaining Core words used in the Hayes tester, with the above
+~ definitions these are straightforward
+
+1 DROP DEPTH 0= ?~ Error #20: testing DROP
+123 DUP  = ?~ Error #21: testing DUP
+123 ?DUP = ?~ Error #22: testing ?DUP
+0  ?DUP 0= ?~ Error #23: testing ?DUP
+123  111  + 234  = ?~ Error #24: testing +
+123  -111 + 12   = ?~ Error #25: testing +
+-123 111  + -12  = ?~ Error #26: testing +
+-123 -111 + -234 = ?~ Error #27: testing +
+-1 NEGATE 1 = ?~ Error #28: testing NEGATE
+0  NEGATE 0=  ?~ Error #29: testing NEGATE
+987 NEGATE -987 = ?~ Error #30: testing NEGATE
+HERE DEPTH SWAP DROP 1 = ?~ Error #31: testing HERE
+CREATE TST1 HERE TST1 = ?~ Error #32: testing CREATE HERE
+16  ALLOT HERE TST1 NEGATE + 16 = ?~ Error #33: testing ALLOT
+-16 ALLOT HERE TST1 = ?~ Error #34: testing ALLOT
+0 CELLS 0= ?~ Error #35: testing CELLS
+1 CELLS ALLOT HERE TST1 NEGATE + VARIABLE CSZ CSZ !
+CSZ @ 0= 0= ?~ Error #36: testing CELLS
+3 CELLS CSZ @ DUP 2* + = ?~ Error #37: testing CELLS
+-3 CELLS CSZ @ DUP 2* + + 0= ?~ Error #38: testing CELLS
+: TST2  ( f -- n )  DUP IF 1+ THEN ;
+0 TST2 0=  ?~ Error #39: testing IF THEN
+1 TST2 2 = ?~ Error #40: testing IF THEN
+: TST3  ( n1 -- n2 )  IF 123 ELSE 234 THEN ;
+0 TST3 234 = ?~ Error #41: testing IF ELSE THEN
+1 TST3 123 = ?~ Error #42: testing IF ELSE THEN
+: TST4  ( -- n )  0 5 0 DO 1+ LOOP ;
+TST4 5 = ?~ Error #43: testing DO LOOP
+: TST5  ( -- n )  0 10 0 DO I + LOOP ;
+TST5 45 = ?~ Error #44: testing I
+: TST6  ( -- n )  0 10 0 DO DUP 5 = IF LEAVE ELSE 1+ THEN LOOP ;
+TST6 5 = ?~ Error #45: testing LEAVE
+: TST7  ( -- n1 n2 ) 123 >R 234 R> ;
+TST7 NEGATE + 111 = ?~ Error #46: testing >R R>
+: TST8  ( -- ch )  [CHAR] a ;  \ vf: s/A/a/
+TST8 65 = ?~ Error #47: testing [CHAR]
+: TST9  ( -- )  [CHAR] s [CHAR] s [CHAR] a [CHAR] P 4 0 DO EMIT LOOP ;
+TST9 .MSG(  #22: testing EMIT) CR
+: TST10  ( -- )  S" Pass #23: testing S" TYPE [CHAR] " EMIT CR ; TST10
+
+~ The Hayes core test core.fr uses CONSTANT before it is tested therefore
+~ we test CONSTANT here
+
+1234 CONSTANT CTEST
+CTEST 1234 = ?~ Error #48: testing CONSTANT
+
+~ The Hayes tester uses some words from the Core extension word set
+~ These will be conditionally defined following definition of a
+~ word called ?DEFINED to determine whether these are already defined
+
+VARIABLE TIMM1 0 TIMM1 !
+: TIMM2  123 TIMM1 ! ; IMMEDIATE
+: TIMM3 TIMM2 ; TIMM1 @ 123 = ?~ Error #49: testing IMMEDIATE
+
+: ?DEFINED  ( "name" -- 0 | -1 )  32 WORD FIND SWAP DROP 0= 0= ;
+?DEFINED SWAP ?~ Error #50: testing FIND ?DEFINED
+?DEFINED <<no-such-word-hopefully>> 0= ?~ Error #51 testing FIND ?DEFINED
+
+?DEFINED \ ?~ : \ ~ ; IMMEDIATE
+\ Error #52: testing \
+: TIMM4  \ Error #53: testing \ is IMMEDIATE
+;
+
+~ TRUE and FALSE are defined as colon definitions as they have been used
+~ more than CONSTANT above
+
+?DEFINED TRUE  ?~ : TRUE 1 NEGATE ;
+?DEFINED FALSE ?~ : FALSE 0 ;
+?DEFINED HEX   ?~ : HEX 16 BASE ! ;
+
+TRUE -1 = ?~ Error #54: testing TRUE
+FALSE 0=  ?~ Error #55: testing FALSE
+10 HEX 0A = ?~ Error #56: testing HEX
+AB 0A BASE ! 171 = ?~ Error #57: testing hex number
+
+~ Delete the ~ on the next 2 lines to check the final error report
+~ Error #998: testing a deliberate failure
+~ Error #999: testing a deliberate failure
+
+~ Describe the messages that should be seen. The previously defined .MSG(
+~ can be used for text messages
+
+CR .MSG( Results: ) CR
+CR .MSG( Pass messages #1 to #23 should be displayed above)
+CR .MSG( and no error messages) CR
+
+~ Finally display a message giving the number of tests that failed.
+~ This is complicated by the fact that untested words including .( ." and .
+~ cannot be used. Also more colon definitions shouldn't be defined than are
+~ needed. To display a number, note that the number of errors will have
+~ one or two digits at most and an interpretive loop can be used to
+~ display those.
+
+CR
+0 #ERRS @
+~ Loop to calculate the 10's digit (if any)
+DUP NEGATE 9 + 0< NEGATE >IN +! ( -10 + SWAP 1+ SWAP 0 >IN ! )
+~ Display the error count
+SWAP ?DUP 0= 1+ >IN +! ( 48 + EMIT ( ) 48 + EMIT
+
+.MSG(  test) #ERRS @ 1 = 1+ >IN +! ~ .MSG( s)
+.MSG(  failed out of 57 additional tests) CR
+
+CR CR .MSG( --- End of Preliminary Tests --- ) CR

6502/C64/tests/run-vf-tests.fth

@@ -3,6 +3,8 @@
 
 include ans-shim.fth
 
+include prelimtest.fth
+
 include tester.fth
 
 \ 1 verbose !
@@ -10,3 +12,10 @@ include tester.fth
 include core.fr
 
 include coreplustest.fth
+
+include utilities.fth
+include errorreport.fth
+
+include coreexttest.fth
+
+REPORT-ERRORS

6502/C64/tests/utilities.fth

@@ -0,0 +1,143 @@
+( The ANS/Forth 2012 test suite is being modified so that the test programs  )
+( for the optional word sets only use standard words from the Core word set. )
+( This file, which is included *after* the Core test programs, contains      )
+( various definitions for use by the optional word set test programs to      )
+( remove any dependencies between word sets.                                 )
+
+DECIMAL
+
+( First a definition to see if a word is already defined. Note that          )
+( [DEFINED] [IF] [ELSE] and [THEN] are in the optional Programming Tools     )
+( word set.                                                                  )
+
+VARIABLE (\?) 0 (\?) !     ( Flag: Word defined = 0 | word undefined = -1 )
+
+( [?DEF]  followed by [?IF] cannot be used again until after [THEN] )
+: [?DEF]  ( "name" -- )
+   BL WORD FIND SWAP DROP 0= (\?) !
+;
+
+\ Test [?DEF]
+T{ 0 (\?) ! [?DEF] ?DEFTEST1 (\?) @ -> -1 }T
+: ?DEFTEST1 1 ;
+T{ -1 (\?) ! [?DEF] ?DEFTEST1 (\?) @ -> 0 }T
+
+: [?UNDEF] [?DEF] (\?) @ 0= (\?) ! ;
+
+\ Equivalents of [IF] [ELSE] [THEN], these must not be nested
+: [?IF]  ( f -- )  (\?) ! ; IMMEDIATE
+: [?ELSE]  ( -- )  (\?) @ 0= (\?) ! ; IMMEDIATE
+: [?THEN]  ( -- )  0 (\?) ! ; IMMEDIATE
+
+( A conditional comment and \ will be defined. Note that these definitions )
+( are inadequate for use in Forth blocks. If needed in the blocks test     )
+( program they will need to be modified here or redefined there )
+
+( \? is a conditional comment )
+: \?  ( "..." -- )  (\?) @ IF EXIT THEN SOURCE >IN ! DROP ; IMMEDIATE
+
+\ Test \?
+T{ [?DEF] ?DEFTEST1 \? : ?DEFTEST1 2 ;    \ Should not be redefined
+          ?DEFTEST1 -> 1 }T
+T{ [?DEF] ?DEFTEST2 \? : ?DEFTEST1 2 ;    \ Should be redefined
+          ?DEFTEST1 -> 2 }T
+
+[?DEF] TRUE  \? -1 CONSTANT TRUE
+[?DEF] FALSE \?  0 CONSTANT FALSE
+[?DEF] NIP   \?  : NIP SWAP DROP ;
+[?DEF] TUCK  \?  : TUCK SWAP OVER ;
+
+[?DEF] PARSE
+\? : BUMP  ( caddr u n -- caddr+n u-n )
+\?    TUCK - >R CHARS + R>
+\? ;
+
+\? : PARSE  ( ch "ccc<ch>" -- caddr u )
+\?    >R SOURCE >IN @ BUMP
+\?    OVER R> SWAP >R >R         ( -- start u1 ) ( R: -- start ch )
+\?    BEGIN
+\?       DUP
+\?    WHILE
+\?       OVER C@ R@ = 0=
+\?    WHILE
+\?       1 BUMP
+\?    REPEAT
+\?       1-                      ( end u2 )  \ delimiter found
+\?    THEN
+\?    SOURCE NIP SWAP - >IN !    ( -- end )
+\?    R> DROP R>                 ( -- end start )
+\?    TUCK - 1 CHARS /           ( -- start u )
+\? ;
+
+[?DEF] .(  \? : .(  [CHAR] ) PARSE TYPE ; IMMEDIATE
+
+\ S=  to compare (case sensitive) two strings to avoid use of COMPARE from
+\ the String word set. It is defined in core.fr and conditionally defined
+\ here if core.fr has not been included by the user
+
+[?DEF] S=
+\? : S=  ( caddr1 u1 caddr2 u2 -- f )   \ f = TRUE if strings are equal
+\?    ROT OVER = 0= IF DROP 2DROP FALSE EXIT THEN
+\?    DUP 0= IF DROP 2DROP TRUE EXIT THEN 
+\?    0 DO
+\?         OVER C@ OVER C@ = 0= IF 2DROP FALSE UNLOOP EXIT THEN
+\?         CHAR+ SWAP CHAR+
+\?      LOOP 2DROP TRUE
+\? ;
+
+\ Buffer for strings in interpretive mode since S" only valid in compilation
+\ mode when File-Access word set is defined
+
+64 CONSTANT SBUF-SIZE
+CREATE SBUF1 SBUF-SIZE CHARS ALLOT
+CREATE SBUF2 SBUF-SIZE CHARS ALLOT
+
+\ ($") saves a counted string at (caddr)
+: ($")  ( caddr "ccc" -- caddr' u )
+   [CHAR] " PARSE ROT 2DUP C!       ( -- ca2 u2 ca)
+   CHAR+ SWAP 2DUP 2>R CHARS MOVE   ( -- )  ( R: -- ca' u2 )
+   2R>
+;
+
+: $"   ( "ccc" -- caddr u )  SBUF1 ($") ;
+: $2"  ( "ccc" -- caddr u )  SBUF2 ($") ;
+: $CLEAR  ( caddr -- ) SBUF-SIZE BL FILL ;
+: CLEAR-SBUFS  ( -- )  SBUF1 $CLEAR SBUF2 $CLEAR ;
+
+\ More definitions in core.fr used in other test programs, conditionally
+\ defined here if core.fr has not been loaded
+
+[?DEF] MAX-UINT   \? 0 INVERT                 CONSTANT MAX-UINT
+[?DEF] MAX-INT    \? 0 INVERT 1 RSHIFT        CONSTANT MAX-INT
+[?DEF] MIN-INT    \? 0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT
+[?DEF] MID-UINT   \? 0 INVERT 1 RSHIFT        CONSTANT MID-UINT
+[?DEF] MID-UINT+1 \? 0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1
+
+[?DEF] 2CONSTANT \? : 2CONSTANT  CREATE , , DOES> 2@ ;
+
+BASE @ 2 BASE ! -1 0 <# #S #> SWAP DROP CONSTANT BITS/CELL BASE !
+
+
+\ ------------------------------------------------------------------------------
+\ Tests
+
+: STR1  S" abcd" ;  : STR2  S" abcde" ;
+: STR3  S" abCd" ;  : STR4  S" wbcd"  ;
+: S"" S" " ;
+
+T{ STR1 2DUP S= -> TRUE }T
+T{ STR2 2DUP S= -> TRUE }T
+T{ S""  2DUP S= -> TRUE }T
+T{ STR1 STR2 S= -> FALSE }T
+T{ STR1 STR3 S= -> FALSE }T
+T{ STR1 STR4 S= -> FALSE }T
+
+T{ CLEAR-SBUFS -> }T
+T{ $" abcdefghijklm"  SBUF1 COUNT S= -> TRUE  }T
+T{ $" nopqrstuvwxyz"  SBUF2 OVER  S= -> FALSE }T
+T{ $2" abcdefghijklm" SBUF1 COUNT S= -> FALSE }T
+T{ $2" nopqrstuvwxyz" SBUF1 COUNT S= -> TRUE  }T
+
+\ ------------------------------------------------------------------------------
+
+CR $" Test utilities loaded" TYPE CR