version 1.9, 2007/11/03 08:27:14

version 1.16, 2009/09/21 15:32:56

Line 1

Line 1

\ for the original tester 
\ This file contains the code for ttester, a utility for testing Forth words, 

\ as developed by several authors (see below), together with some explanations 

\ of its use. 



\ ttester is based on the original tester suite by Hayes: 
\ From: John Hayes S1I 
\ From: John Hayes S1I 
\ Subject: tester.fr 
\ Subject: tester.fr 
\ Date: Mon, 27 Nov 95 13:10:09 PST 
\ Date: Mon, 27 Nov 95 13:10:09 PST 
\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY 
\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY 
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. 
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. 
\ VERSION 1.1 
\ VERSION 1.1 

\ All the subsequent changes have been placed in the public domain. 
\ for the FNEARLY= stuff: 
\ The primary changes from the original are the replacement of "{" by "T{" 

\ and "}" by "}T" (to avoid conflicts with the uses of { for locals and } 

\ for FSL arrays), modifications so that the stack is allowed to be nonempty 

\ before T{, and extensions for the handling of floating point tests. 

\ Code for testing equality of floating point values comes 
\ from ftester.fs written by David N. Williams, based on the idea of 
\ from ftester.fs written by David N. Williams, based on the idea of 
\ approximate equality in Dirk Zoller's float.4th 
\ approximate equality in Dirk Zoller's float.4th. 
\ public domain 
\ Further revisions were provided by Anton Ertl, including the ability 

\ to handle either integrated or separate floating point stacks. 
\ for the rest: 
\ Revision history and possibly newer versions can be found at 
\ revised by Anton Ertl 20070812, 20070819, 20070828 
\ http://www.complang.tuwien.ac.at/cvsweb/cgibin/cvsweb/gforth/test/ttester.fs 
\ public domain 
\ Explanatory material and minor reformatting (no code changes) by 

\ C. G. Montgomery March 2009, with helpful comments from David Williams 
\ The original has the following shortcomings: 
\ and Krishna Myneni. 


\  It does not work as expected if the stack is nonempty before the {. 
\ Usage: 


\  It does not check FP results if the system has a separate FP stack. 
\ The basic usage takes the form T{ <code> > <expected stack> }T . 

\ This executes <code> and compares the resulting stack contents with 
\  There is a conflict with the use of } for FSL arrays and { for locals. 
\ the <expected stack> values, and reports any discrepancy between the 

\ two sets of values. 
\ I have revised it to address these shortcomings. You can find the 
\ For example: 
\ result at 
\ T{ 1 2 3 swap > 1 3 2 }T ok 

\ T{ 1 2 3 swap > 1 2 2 }T INCORRECT RESULT: T{ 1 2 3 swap > 1 2 2 }T ok 
\ http://www.forth200x.org/tests/tester.fs 
\ T{ 1 2 3 swap > 1 2 }T WRONG NUMBER OF RESULTS: T{ 1 2 3 swap > 1 2 }T ok 
\ http://www.forth200x.org/tests/ttester.fs 


\ Floating point testing can involve further complications. The code 

\ attempts to determine whether floatingpoint support is present, and 

\ if so, whether there is a separate floatingpoint stack, and behave 

\ accordingly. The CONSTANTs HASFLOATING and HASFLOATINGSTACK 

\ contain the results of its efforts, so the behavior of the code can 

\ be modified by the user if necessary. 



\ Then there are the perennial issues of floating point value 

\ comparisons. Exact equality is specified by SETEXACT (the 

\ default). If approximate equality tests are desired, execute 

\ SETNEAR . Then the FVARIABLEs RELNEAR (default 1E12) and 

\ ABSNEAR (default 0E) contain the values to be used in comparisons 

\ by the (internal) word FNEARLY= . 



\ When there is not a separate floating point stack and you want to 

\ use approximate equality for FP values, it is necessary to identify 

\ which stack items are floating point quantities. This can be done 

\ by replacing the closing }T with a version that specifies this, such 

\ as RRXR}T which identifies the stack picture ( r r x r ). The code 

\ provides such words for all combinations of R and X with up to four 

\ stack items. They can be used with either an integrated or separate 

\ floating point stacks. Adding more if you need them is 

\ straightforward; see the examples in the source. Here is an example 

\ which also illustrates controlling the precision of comparisons: 



\ SETNEAR 

\ 1E6 RELNEAR F! 

\ T{ S" 3.14159E" >FLOAT > 1E FACOS TRUE RX}T 



\ The word ERROR is now vectored, so that its action can be changed by 

\ the user (for example, to add a counter for the number of errors). 

\ The default action ERROR1 can be used as a factor in the display of 

\ error reports. 


\ tester.fs is intended to be a dropin replacement of the original. 
\ Loading ttester.fs does not change BASE. Remember that floating point input 

\ is ambiguous if the base is not decimal. 


\ ttester.fs is a version that uses T{ and }T instead of { and } and 
\ The file defines some 70 words in all, but in most cases only the 
\ keeps the BASE as it was before loading ttester.fs 
\ ones mentioned above will be needed for successful testing. 


\ In spirit of the original, I have strived to avoid any potential 

\ nonportabilities and stayed as much within the CORE words as 

\ possible; e.g., FLOATING words are used only if the FLOATING wordset 

\ is present 



\ There are a few things to be noted: 



\  Loading ttester.fs does not change BASE. Loading tester.fs 

\ changes BASE to HEX (like the original tester). Floatingpoint 

\ input is ambiguous when the base is not decimal, so you have to set 

\ it to decimal yourself when you want to deal with decimal numbers. 



\  For FP it is often useful to use approximate equality for checking 

\ the results. You can turn on approximate matching with SETNEAR 

\ (and turn it off (default) with SETEXACT, and you can tune it by 

\ setting the variables RELNEAR and ABSNEAR. If you want your tests 

\ to work with a shared stack, you have to specify the types of the 

\ elements on the stack by using one of the closing words that specify 

\ types, e.g. RRRX}T for checking the stack picture ( r r r x ). 

\ There are such words for all combination of R and X with up to 4 

\ stack items, and defining more if you need them is straightforward 

\ (see source). If your tests are only intended for a separatestack 

\ system or if you need only exact matching, you can use the plain }T 

\ instead. 



BASE @ 
BASE @ 
HEX 
DECIMAL 


\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY 
VARIABLE ACTUALDEPTH \ stack record 
\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. 
CREATE ACTUALRESULTS 32 CELLS ALLOT 
VARIABLE VERBOSE 

FALSE VERBOSE ! 



VARIABLE ACTUALDEPTH \ STACK RECORD 

CREATE ACTUALRESULTS 20 CELLS ALLOT 

VARIABLE STARTDEPTH 
VARIABLE STARTDEPTH 
VARIABLE XCURSOR \ FOR ...}T 
VARIABLE XCURSOR \ for ...}T 
VARIABLE ERRORXT 
VARIABLE ERRORXT 


: ERROR ERRORXT @ EXECUTE ; 
: ERROR ERRORXT @ EXECUTE ; \ for vectoring of error reporting 


: "FLOATING" S" FLOATING" ; \ ONLY COMPILED S" IN CORE 
: "FLOATING" S" FLOATING" ; \ only compiled S" in CORE 
: "FLOATINGSTACK" S" FLOATINGSTACK" ; 
: "FLOATINGSTACK" S" FLOATINGSTACK" ; 
"FLOATING" ENVIRONMENT? [IF] 
"FLOATING" ENVIRONMENT? [IF] 
[IF] 
[IF] 
Line 92 VARIABLE ERRORXT

Line 104 VARIABLE ERRORXT

[ELSE] 
[ELSE] 
FALSE 
FALSE 
[THEN] 
[THEN] 
[ELSE] \ WE DON'T KNOW WHETHER THE FP STACK IS SEPARATE 
[ELSE] \ We don't know whether the FP stack is separate. 
HASFLOATING \ IF WE HAVE FLOATING, WE ASSUME IT IS 
HASFLOATING \ If we have FLOATING, we assume it is. 
[THEN] CONSTANT HASFLOATINGSTACK 
[THEN] CONSTANT HASFLOATINGSTACK 


HASFLOATING [IF] 
HASFLOATING [IF] 
\ SET THE FOLLOWING TO THE RELATIVE AND ABSOLUTE TOLERANCES YOU 
\ Set the following to the relative and absolute tolerances you 
\ WANT FOR APPROXIMATE FLOAT EQUALITY, TO BE USED WITH F~ IN 
\ want for approximate float equality, to be used with F~ in 
\ FNEARLY=. KEEP THE SIGNS, BECAUSE F~ NEEDS THEM. 
\ FNEARLY=. Keep the signs, because F~ needs them. 
FVARIABLE RELNEAR DECIMAL 1E12 HEX RELNEAR F! 
FVARIABLE RELNEAR 1E12 RELNEAR F! 
FVARIABLE ABSNEAR DECIMAL 0E HEX ABSNEAR F! 
FVARIABLE ABSNEAR 0E ABSNEAR F! 


\ WHEN EXACT? IS TRUE, }F USES FEXACTLY=, OTHERWISE FNEARLY=. 
\ When EXACT? is TRUE, }F uses FEXACTLY=, otherwise FNEARLY=. 


TRUE VALUE EXACT? 
TRUE VALUE EXACT? 
: SETEXACT (  ) TRUE TO EXACT? ; 
: SETEXACT (  ) TRUE TO EXACT? ; 
: SETNEAR (  ) FALSE TO EXACT? ; 
: SETNEAR (  ) FALSE TO EXACT? ; 


DECIMAL 

: FEXACTLY= ( F: X Y  S: FLAG ) 
: FEXACTLY= ( F: X Y  S: FLAG ) 
( 
( 
LEAVE TRUE IF THE TWO FLOATS ARE IDENTICAL. 
Leave TRUE if the two floats are identical. 
) 
) 
0E F~ ; 
0E F~ ; 
HEX 



: FABS= ( F: X Y  S: FLAG ) 
: FABS= ( F: X Y  S: FLAG ) 
( 
( 
LEAVE TRUE IF THE TWO FLOATS ARE EQUAL WITHIN THE TOLERANCE 
Leave TRUE if the two floats are equal within the tolerance 
STORED IN ABSNEAR. 
stored in ABSNEAR. 
) 
) 
ABSNEAR F@ F~ ; 
ABSNEAR F@ F~ ; 


: FREL= ( F: X Y  S: FLAG ) 
: FREL= ( F: X Y  S: FLAG ) 
( 
( 
LEAVE TRUE IF THE TWO FLOATS ARE RELATIVELY EQUAL BASED ON THE 
Leave TRUE if the two floats are relatively equal based on the 
TOLERANCE STORED IN ABSNEAR. 
tolerance stored in ABSNEAR. 
) 
) 
RELNEAR F@ FNEGATE F~ ; 
RELNEAR F@ FNEGATE F~ ; 


Line 136 HASFLOATING [IF]

Line 146 HASFLOATING [IF]



: FNEARLY= ( F: X Y  S: FLAG ) 
: FNEARLY= ( F: X Y  S: FLAG ) 
( 
( 
LEAVE TRUE IF THE TWO FLOATS ARE NEARLY EQUAL. THIS IS A 
Leave TRUE if the two floats are nearly equal. This is a 
REFINEMENT OF DIRK ZOLLER'S FEQ TO ALSO ALLOW X = Y, INCLUDING 
refinement of Dirk Zoller's FEQ to also allow X = Y, including 
BOTH ZERO, OR TO ALLOW APPROXIMATE EQUALITY WHEN X AND Y ARE TOO 
both zero, or to allow approximately equality when X and Y are too 
SMALL TO SATISFY THE RELATIVE APPROXIMATION MODE IN THE F~ 
small to satisfy the relative approximation mode in the F~ 
SPECIFICATION. 
specification. 
) 
) 
F2DUP FEXACTLY= IF F2DROP TRUE EXIT THEN 
F2DUP FEXACTLY= IF F2DROP TRUE EXIT THEN 
F2DUP FREL= IF F2DROP TRUE EXIT THEN 
F2DUP FREL= IF F2DROP TRUE EXIT THEN 
Line 156 HASFLOATING [IF]

Line 166 HASFLOATING [IF]



HASFLOATINGSTACK [IF] 
HASFLOATINGSTACK [IF] 
VARIABLE ACTUALFDEPTH 
VARIABLE ACTUALFDEPTH 
CREATE ACTUALFRESULTS 20 FLOATS ALLOT 
CREATE ACTUALFRESULTS 32 FLOATS ALLOT 
VARIABLE STARTFDEPTH 
VARIABLE STARTFDEPTH 
VARIABLE FCURSOR 
VARIABLE FCURSOR 


Line 167 HASFLOATINGSTACK [IF]

Line 177 HASFLOATINGSTACK [IF]

FDEPTH STARTFDEPTH @ > IF 
FDEPTH STARTFDEPTH @ > IF 
FDEPTH STARTFDEPTH @ DO FDROP LOOP 
FDEPTH STARTFDEPTH @ DO FDROP LOOP 
THEN ; 
THEN ; 


: F{ (  ) 
: F{ (  ) 
FDEPTH STARTFDEPTH ! 0 FCURSOR ! ; 
FDEPTH STARTFDEPTH ! 0 FCURSOR ! ; 


Line 180 HASFLOATINGSTACK [IF]

Line 190 HASFLOATINGSTACK [IF]

: F} ( ...  ... ) 
: F} ( ...  ... ) 
FDEPTH ACTUALFDEPTH @ = IF 
FDEPTH ACTUALFDEPTH @ = IF 
FDEPTH STARTFDEPTH @ > IF 
FDEPTH STARTFDEPTH @ > IF 
FDEPTH STARTFDEPTH @ DO 
FDEPTH STARTFDEPTH @  0 DO 
ACTUALFRESULTS I FLOATS + F@ FCONF= INVERT IF 
ACTUALFRESULTS I FLOATS + F@ FCONF= INVERT IF 
S" INCORRECT FP RESULT: " ERROR LEAVE 
S" INCORRECT FP RESULT: " ERROR LEAVE 
THEN 
THEN 
Line 192 HASFLOATINGSTACK [IF]

Line 202 HASFLOATINGSTACK [IF]



: F...}T (  ) 
: F...}T (  ) 
FCURSOR @ STARTFDEPTH @ + ACTUALFDEPTH @ <> IF 
FCURSOR @ STARTFDEPTH @ + ACTUALFDEPTH @ <> IF 
S" NUMBER OF FLOAT RESULTS BEFORE '>' DOES NOT MATCH ...}T SPRECIFICATION: " ERROR 
S" NUMBER OF FLOAT RESULTS BEFORE '>' DOES NOT MATCH ...}T SPECIFICATION: " ERROR 
ELSE FDEPTH STARTFDEPTH @ = 0= IF 
ELSE FDEPTH STARTFDEPTH @ = 0= IF 
S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '>' DOES NOT MATCH: " ERROR 
S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '>' DOES NOT MATCH: " ERROR 
THEN THEN ; 
THEN THEN ; 
Line 213 HASFLOATINGSTACK [IF]

Line 223 HASFLOATINGSTACK [IF]

: F} ; 
: F} ; 
: F...}T ; 
: F...}T ; 


DECIMAL 
HASFLOATING [IF] 
: COMPUTECELLSPERFP (  U ) 
: COMPUTECELLSPERFP (  U ) 
DEPTH 0E DEPTH 1 >R FDROP R> SWAP  ; 
DEPTH 0E DEPTH 1 >R FDROP R> SWAP  ; 
HEX 



COMPUTECELLSPERFP CONSTANT CELLSPERFP 
COMPUTECELLSPERFP CONSTANT CELLSPERFP 


: FTESTER ( R  ) 
: FTESTER ( R  ) 
DEPTH CELLSPERFP < ACTUALDEPTH @ XCURSOR @ STARTDEPTH @ + CELLSPERFP + < OR IF 
DEPTH CELLSPERFP < ACTUALDEPTH @ XCURSOR @ STARTDEPTH @ + CELLSPERFP + < OR IF 
S" NUMBER OF RESULTS AFTER '>' BELOW ...}T SPECIFICATION: " ERROR EXIT 
S" NUMBER OF RESULTS AFTER '>' BELOW ...}T SPECIFICATION: " ERROR EXIT 
Line 227 HASFLOATINGSTACK [IF]

Line 236 HASFLOATINGSTACK [IF]

S" INCORRECT FP RESULT: " ERROR 
S" INCORRECT FP RESULT: " ERROR 
THEN THEN 
THEN THEN 
CELLSPERFP XCURSOR +! ; 
CELLSPERFP XCURSOR +! ; 
[THEN] 
[THEN] 

[THEN] 


: EMPTYSTACK \ ( ...  ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. 
: EMPTYSTACK \ ( ...  ) empty stack; handles underflowed stack too. 
DEPTH STARTDEPTH @ < IF 
DEPTH STARTDEPTH @ < IF 
DEPTH STARTDEPTH @ SWAP DO 0 LOOP 
DEPTH STARTDEPTH @ SWAP DO 0 LOOP 
THEN 
THEN 
Line 238 HASFLOATINGSTACK [IF]

Line 248 HASFLOATINGSTACK [IF]

THEN 
THEN 
EMPTYFSTACK ; 
EMPTYFSTACK ; 


: ERROR1 \ ( CADDR U  ) DISPLAY AN ERROR MESSAGE FOLLOWED BY 
: ERROR1 \ ( CADDR U  ) display an error message 
\ THE LINE THAT HAD THE ERROR. 
\ followed by the line that had the error. 
TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR 
TYPE SOURCE TYPE CR \ display line corresponding to error 
EMPTYSTACK \ THROW AWAY EVERY THING ELSE 
EMPTYSTACK \ throw away everything else 
; 
; 


' ERROR1 ERRORXT ! 
' ERROR1 ERRORXT ! 


: T{ \ (  ) SYNTACTIC SUGAR. 
: T{ \ (  ) syntactic sugar. 
DEPTH STARTDEPTH ! 0 XCURSOR ! F{ ; 
DEPTH STARTDEPTH ! 0 XCURSOR ! F{ ; 


: > \ ( ...  ) RECORD DEPTH AND CONTENT OF STACK. 
: > \ ( ...  ) record depth and contents of stack. 
DEPTH DUP ACTUALDEPTH ! \ RECORD DEPTH 
DEPTH DUP ACTUALDEPTH ! \ record depth 
STARTDEPTH @ > IF \ IF THERE IS SOMETHING ON STACK 
STARTDEPTH @ > IF \ if there is something on the stack 
DEPTH STARTDEPTH @  0 DO ACTUALRESULTS I CELLS + ! LOOP \ SAVE THEM 
DEPTH STARTDEPTH @  0 DO ACTUALRESULTS I CELLS + ! LOOP \ save them 
THEN 
THEN 
F> ; 
F> ; 


: }T \ ( ...  ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED 
: }T \ ( ...  ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED 
\ (ACTUAL) CONTENTS. 
\ (ACTUAL) CONTENTS. 
DEPTH ACTUALDEPTH @ = IF \ IF DEPTHS MATCH 
DEPTH ACTUALDEPTH @ = IF \ if depths match 
DEPTH STARTDEPTH @ > IF \ IF THERE IS SOMETHING ON THE STACK 
DEPTH STARTDEPTH @ > IF \ if there is something on the stack 
DEPTH STARTDEPTH @ DO \ FOR EACH STACK ITEM 
DEPTH STARTDEPTH @  0 DO \ for each stack item 
ACTUALRESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED 
ACTUALRESULTS I CELLS + @ \ compare actual with expected 
<> IF S" INCORRECT RESULT: " ERROR LEAVE THEN 
<> IF S" INCORRECT RESULT: " ERROR LEAVE THEN 
LOOP 
LOOP 
THEN 
THEN 
ELSE \ DEPTH MISMATCH 
ELSE \ depth mismatch 
S" WRONG NUMBER OF RESULTS: " ERROR 
S" WRONG NUMBER OF RESULTS: " ERROR 
THEN 
THEN 
F} ; 
F} ; 
Line 287 HASFLOATINGSTACK [IF]

Line 297 HASFLOATINGSTACK [IF]

1 XCURSOR +! ; 
1 XCURSOR +! ; 


: X}T XTESTER ...}T ; 
: X}T XTESTER ...}T ; 
: R}T FTESTER ...}T ; 

: XX}T XTESTER XTESTER ...}T ; 
: XX}T XTESTER XTESTER ...}T ; 

: XXX}T XTESTER XTESTER XTESTER ...}T ; 

: XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ; 



HASFLOATING [IF] 

: R}T FTESTER ...}T ; 
: XR}T FTESTER XTESTER ...}T ; 
: XR}T FTESTER XTESTER ...}T ; 
: RX}T XTESTER FTESTER ...}T ; 
: RX}T XTESTER FTESTER ...}T ; 
: RR}T FTESTER FTESTER ...}T ; 
: RR}T FTESTER FTESTER ...}T ; 
: XXX}T XTESTER XTESTER XTESTER ...}T ; 

: XXR}T FTESTER XTESTER XTESTER ...}T ; 
: XXR}T FTESTER XTESTER XTESTER ...}T ; 
: XRX}T XTESTER FTESTER XTESTER ...}T ; 
: XRX}T XTESTER FTESTER XTESTER ...}T ; 
: XRR}T FTESTER FTESTER XTESTER ...}T ; 
: XRR}T FTESTER FTESTER XTESTER ...}T ; 
Line 300 HASFLOATINGSTACK [IF]

Line 313 HASFLOATINGSTACK [IF]

: RXR}T FTESTER XTESTER FTESTER ...}T ; 
: RXR}T FTESTER XTESTER FTESTER ...}T ; 
: RRX}T XTESTER FTESTER FTESTER ...}T ; 
: RRX}T XTESTER FTESTER FTESTER ...}T ; 
: RRR}T FTESTER FTESTER FTESTER ...}T ; 
: RRR}T FTESTER FTESTER FTESTER ...}T ; 
: XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ; 

: XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ; 
: XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ; 
: XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ; 
: XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ; 
: XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ; 
: XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ; 
Line 316 HASFLOATINGSTACK [IF]

Line 328 HASFLOATINGSTACK [IF]

: RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ; 
: RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ; 
: RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ; 
: RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ; 
: RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ; 
: RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ; 

[THEN] 



\ Set the following flag to TRUE for more verbose output; this may 

\ allow you to tell which test caused your system to hang. 

VARIABLE VERBOSE 

FALSE VERBOSE ! 


: TESTING \ (  ) TALKING COMMENT. 
: TESTING \ (  ) TALKING COMMENT. 
SOURCE VERBOSE @ 
SOURCE VERBOSE @ 
Line 324 HASFLOATINGSTACK [IF]

Line 342 HASFLOATINGSTACK [IF]

THEN ; 
THEN ; 


BASE ! 
BASE ! 

\ end of ttester.fs 