version 1.1, 2007/08/19 21:33:50

version 1.11, 2008/03/06 19:24:30

Line 1

Line 1


\ for the original tester 
\ 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 


\ revised by Anton Ertl 20070812, 20070819 
\ for the FNEARLY= stuff: 

\ from ftester.fs written by David N. Williams, based on the idea of 

\ approximate equality in Dirk Zoller's float.4th 

\ public domain 



\ for the rest: 

\ revised by Anton Ertl 20070812, 20070819, 20070828 

\ public domain 


\ The original has the following shortcomings: 
\ The original has the following shortcomings: 


\  It does not work as expected if the stack is nonempty before the {. 
\  It does not work as expected if the stack is nonempty before the {. 
Line 22

Line 30

\ http://www.forth200x.org/tests/ttester.fs 
\ http://www.forth200x.org/tests/ttester.fs 


\ tester.fs is intended to be a dropin replacement of the original. 
\ tester.fs is intended to be a dropin replacement of the original. 
\ ttester.fs is a version that uses T{ and }T instead of { and }. 


\ ttester.fs is a version that uses T{ and }T instead of { and } and 

\ keeps the BASE as it was before loading ttester.fs 


\ In spirit of the original, I have strived to avoid any potential 
\ In spirit of the original, I have strived to avoid any potential 
\ nonportabilities and stayed as much within the CORE words as 
\ nonportabilities and stayed as much within the CORE words as 
Line 31

Line 41



\ There are a few things to be noted: 
\ There are a few things to be noted: 


\  Following the despicable practice of the original, this version 
\  Loading ttester.fs does not change BASE. Loading tester.fs 
\ sets the base to HEX for everything that gets loaded later. 
\ changes BASE to HEX (like the original tester). Floatingpoint 
\ Floatingpoint input is ambiguous when the base is not decimal, so 
\ input is ambiguous when the base is not decimal, so you have to set 
\ you have to set it to decimal yourself when you want to deal with 
\ it to decimal yourself when you want to deal with decimal numbers. 
\ decimal numbers. 



\  For FP it is often useful to use approximate equality for checking 
\  For FP it is often useful to use approximate equality for checking 
\ the results. You can turn on approximate matching with SETNEAR 
\ the results. You can turn on approximate matching with SETNEAR 
Line 50

Line 59

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



BASE @ 
HEX 
HEX 


\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY 
\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY 
Line 90 HASFLOATING [IF]

Line 100 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 FSENSITIVITY DECIMAL 1E12 HEX FSENSITIVITY F! 
FVARIABLE RELNEAR DECIMAL 1E12 HEX RELNEAR F! 
: RELNEAR FSENSITIVITY ; 

FVARIABLE ABSNEAR DECIMAL 0E HEX ABSNEAR F! 
FVARIABLE ABSNEAR DECIMAL 0E HEX ABSNEAR F! 


\ WHEN EXACT? IS TRUE, }F USES FEXACTLY=, OTHERWISE FNEARLY=. 
\ WHEN EXACT? IS TRUE, }F USES FEXACTLY=, OTHERWISE FNEARLY=. 
Line 165 HASFLOATINGSTACK [IF]

Line 174 HASFLOATINGSTACK [IF]

: F> ( ...  ... ) 
: F> ( ...  ... ) 
FDEPTH DUP ACTUALFDEPTH ! 
FDEPTH DUP ACTUALFDEPTH ! 
STARTFDEPTH @ > IF 
STARTFDEPTH @ > IF 
FDEPTH STARTFDEPTH @ DO ACTUALFRESULTS I FLOATS + F! LOOP 
FDEPTH STARTFDEPTH @  0 DO ACTUALFRESULTS I FLOATS + F! LOOP 
THEN ; 
THEN ; 


: 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 182 HASFLOATINGSTACK [IF]

Line 191 HASFLOATINGSTACK [IF]

THEN ; 
THEN ; 


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



: FTESTER ( R  ) 
: FTESTER ( R  ) 
FDEPTH 0= ACTUALFDEPTH @ FCURSOR @ 1+ < OR IF 
FDEPTH 0= ACTUALFDEPTH @ FCURSOR @ STARTFDEPTH @ + 1+ < OR IF 
S" WRONG NUMBER OF FP RESULTS: " ERROR EXIT 
S" NUMBER OF FLOAT RESULTS AFTER '>' BELOW ...}T SPECIFICATION: " ERROR 
THEN 
ELSE ACTUALFRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF 
ACTUALFRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF 

S" INCORRECT FP RESULT: " ERROR 
S" INCORRECT FP RESULT: " ERROR 
THEN 
THEN THEN 
1 FCURSOR +! ; 
1 FCURSOR +! ; 


[ELSE] 
[ELSE] 
Line 205 HASFLOATINGSTACK [IF]

Line 213 HASFLOATINGSTACK [IF]

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



DECIMAL 
: COMPUTECELLSPERFP (  U ) 
: COMPUTECELLSPERFP (  U ) 
DEPTH 0E DEPTH >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 @ CELLSPERFP + < OR IF 
DEPTH CELLSPERFP < ACTUALDEPTH @ XCURSOR @ STARTDEPTH @ + CELLSPERFP + < OR IF 
S" WRONG NUMBER OF RESULTS: " ERROR EXIT 
S" NUMBER OF RESULTS AFTER '>' BELOW ...}T SPECIFICATION: " ERROR EXIT 
THEN 
ELSE ACTUALRESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF 
ACTUALRESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF 

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


Line 238 HASFLOATINGSTACK [IF]

Line 247 HASFLOATINGSTACK [IF]

' ERROR1 ERRORXT ! 
' ERROR1 ERRORXT ! 


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


: > \ ( ...  ) RECORD DEPTH AND CONTENT OF STACK. 
: > \ ( ...  ) RECORD DEPTH AND CONTENT 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 STACK 
DEPTH STARTDEPTH @ DO ACTUALRESULTS I CELLS + ! LOOP \ SAVE THEM 
DEPTH STARTDEPTH @  0 DO ACTUALRESULTS I CELLS + ! LOOP \ SAVE THEM 
THEN 
THEN 
F> ; 
F> ; 


Line 251 HASFLOATINGSTACK [IF]

Line 260 HASFLOATINGSTACK [IF]

\ (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 
Line 262 HASFLOATINGSTACK [IF]

Line 271 HASFLOATINGSTACK [IF]

F} ; 
F} ; 


: ...}T (  ) 
: ...}T (  ) 
DEPTH STARTDEPTH @ = 0= IF 
XCURSOR @ STARTDEPTH @ + ACTUALDEPTH @ <> IF 
S" WRONG NUMBER OF RESULTS" ERROR 
S" NUMBER OF CELL RESULTS BEFORE '>' DOES NOT MATCH ...}T SPECIFICATION: " ERROR 
THEN 
ELSE DEPTH STARTDEPTH @ = 0= IF 
XCURSOR @ ACTUALDEPTH @ <> IF 
S" NUMBER OF CELL RESULTS BEFORE AND AFTER '>' DOES NOT MATCH: " ERROR 
S" WRONG NUMBER OF RESULTS" ERROR 
THEN THEN 
THEN 

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


: XTESTER ( X  ) 
: XTESTER ( X  ) 
DEPTH 0= ACTUALDEPTH @ XCURSOR @ 1+ < OR IF 
DEPTH 0= ACTUALDEPTH @ XCURSOR @ STARTDEPTH @ + 1+ < OR IF 
S" WRONG NUMBER OF RESULTS: " ERROR EXIT 
S" NUMBER OF CELL RESULTS AFTER '>' BELOW ...}T SPECIFICATION: " ERROR EXIT 
THEN 
ELSE ACTUALRESULTS XCURSOR @ CELLS + @ <> IF 
ACTUALRESULTS XCURSOR @ CELLS + @ <> IF 

S" INCORRECT CELL RESULT: " ERROR 
S" INCORRECT CELL RESULT: " ERROR 
THEN 
THEN THEN 
1 XCURSOR +! ; 
1 XCURSOR +! ; 


: X}T XTESTER ...}T ; 
: X}T XTESTER ...}T ; 
Line 315 HASFLOATINGSTACK [IF]

Line 322 HASFLOATINGSTACK [IF]

IF DUP >R TYPE CR R> >IN ! 
IF DUP >R TYPE CR R> >IN ! 
ELSE >IN ! DROP 
ELSE >IN ! DROP 
THEN ; 
THEN ; 



BASE ! 