diff --git a/6502/C64/emulator/x11_sym_vf_de.vkm b/6502/C64/emulator/x11_sym_vf_de.vkm index 7b9741e..c3b65d7 100644 --- a/6502/C64/emulator/x11_sym_vf_de.vkm +++ b/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 diff --git a/6502/C64/tests/ans-shim.fth b/6502/C64/tests/ans-shim.fth index 871e600..3ca4d8a 100644 --- a/6502/C64/tests/ans-shim.fth +++ b/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 ; diff --git a/6502/C64/tests/coreexttest.fth b/6502/C64/tests/coreexttest.fth new file mode 100644 index 0000000..990ba89 --- /dev/null +++ b/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 and 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 + + diff --git a/6502/C64/tests/errorreport.fth b/6502/C64/tests/errorreport.fth new file mode 100644 index 0000000..24e7bd1 --- /dev/null +++ b/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 +; diff --git a/6502/C64/tests/prelimtest.fth b/6502/C64/tests/prelimtest.fth new file mode 100644 index 0000000..6c38da8 --- /dev/null +++ b/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: ?T~ Error #n: ) +( 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 <> 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 diff --git a/6502/C64/tests/run-vf-tests.fth b/6502/C64/tests/run-vf-tests.fth index 905c7a4..b0e540a 100644 --- a/6502/C64/tests/run-vf-tests.fth +++ b/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 diff --git a/6502/C64/tests/utilities.fth b/6502/C64/tests/utilities.fth new file mode 100644 index 0000000..b224c79 --- /dev/null +++ b/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" -- 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