mirror of
https://github.com/forth-ev/VolksForth.git
synced 2025-02-16 21:30:59 +00:00
Initial checkin of errorreport.fth and utilities.fth from ans test suite
This commit is contained in:
Philip Zembrod
parent
2dc1619ed8
commit
d1b75d6feb
88
6502/C64/tests/errorreport.fth
Normal file
88
6502/C64/tests/errorreport.fth
Normal file
@ -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
|
||||
;
|
||||
143
6502/C64/tests/utilities.fth
Normal file
143
6502/C64/tests/utilities.fth
Normal file
@ -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
|
||||
Loading…
x
Reference in New Issue
Block a user