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/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