 gforth/test/ttester.fs 2007/08/21 09:22:28 1.2
+++ gforth/test/ttester.fs 2008/11/08 18:28:22 1.12
@@ 7,26 +7,12 @@
\ VERSION 1.1
\ for the FNEARLY= stuff:
\ from ftester.fs written by David N. Williams, based on the
+\ from ftester.fs written by David N. Williams, based on the idea of
\ approximate equality in Dirk Zoller's float.4th

\ This library is free software; you can redistribute it and/or
\ modify it under the terms of the GNU Lesser General Public
\ License as published by the Free Software Foundation; either
\ version 2.1 of the License, or at your option any later version.

\ This library 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. See the GNU
\ Lesser General Public License for more details.

\ You should have received a copy of the GNU Lesser General Public
\ License along with this library; if not, write to the Free
\ Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
\ MA 021111307 USA.
+\ public domain
\ for the rest:
\ revised by Anton Ertl 20070812, 20070819
+\ revised by Anton Ertl 20070812, 20070819, 20070828
\ public domain
\ The original has the following shortcomings:
@@ 44,7 +30,9 @@
\ http://www.forth200x.org/tests/ttester.fs
\ 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
\ nonportabilities and stayed as much within the CORE words as
@@ 53,11 +41,10 @@
\ There are a few things to be noted:
\  Following the despicable practice of the original, this version
\ sets the base to HEX for everything that gets loaded later.
\ 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.
+\  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
@@ 72,6 +59,7 @@
\ system or if you need only exact matching, you can use the plain }T
\ instead.
+BASE @
HEX
\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
@@ 112,8 +100,7 @@ HASFLOATING [IF]
\ SET THE FOLLOWING TO THE RELATIVE AND ABSOLUTE TOLERANCES YOU
\ WANT FOR APPROXIMATE FLOAT EQUALITY, TO BE USED WITH F~ IN
\ FNEARLY=. KEEP THE SIGNS, BECAUSE F~ NEEDS THEM.
 FVARIABLE FSENSITIVITY DECIMAL 1E12 HEX FSENSITIVITY F!
 : RELNEAR FSENSITIVITY ;
+ FVARIABLE RELNEAR DECIMAL 1E12 HEX RELNEAR F!
FVARIABLE ABSNEAR DECIMAL 0E HEX ABSNEAR F!
\ WHEN EXACT? IS TRUE, }F USES FEXACTLY=, OTHERWISE FNEARLY=.
@@ 187,13 +174,13 @@ HASFLOATINGSTACK [IF]
: F> ( ...  ... )
FDEPTH DUP ACTUALFDEPTH !
STARTFDEPTH @ > IF
 FDEPTH STARTFDEPTH @ DO ACTUALFRESULTS I FLOATS + F! LOOP
+ FDEPTH STARTFDEPTH @  0 DO ACTUALFRESULTS I FLOATS + F! LOOP
THEN ;
: F} ( ...  ... )
FDEPTH ACTUALFDEPTH @ = IF
FDEPTH STARTFDEPTH @ > IF
 FDEPTH STARTFDEPTH @ DO
+ FDEPTH STARTFDEPTH @  0 DO
ACTUALFRESULTS I FLOATS + F@ FCONF= INVERT IF
S" INCORRECT FP RESULT: " ERROR LEAVE
THEN
@@ 204,20 +191,19 @@ HASFLOATINGSTACK [IF]
THEN ;
: F...}T (  )
 FDEPTH STARTFDEPTH @ = 0= IF
 S" WRONG NUMBER OF FP RESULTS" ERROR
 THEN
 FCURSOR @ ACTUALFDEPTH @ <> IF
 S" WRONG NUMBER OF FP RESULTS" ERROR
 THEN ;
+ FCURSOR @ STARTFDEPTH @ + ACTUALFDEPTH @ <> IF
+ S" NUMBER OF FLOAT RESULTS BEFORE '>' DOES NOT MATCH ...}T SPECIFICATION: " ERROR
+ ELSE FDEPTH STARTFDEPTH @ = 0= IF
+ S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '>' DOES NOT MATCH: " ERROR
+ THEN THEN ;
+
: FTESTER ( R  )
 FDEPTH 0= ACTUALFDEPTH @ FCURSOR @ 1+ < OR IF
 S" WRONG NUMBER OF FP RESULTS: " ERROR EXIT
 THEN
 ACTUALFRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF
+ FDEPTH 0= ACTUALFDEPTH @ FCURSOR @ STARTFDEPTH @ + 1+ < OR IF
+ S" NUMBER OF FLOAT RESULTS AFTER '>' BELOW ...}T SPECIFICATION: " ERROR
+ ELSE ACTUALFRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF
S" INCORRECT FP RESULT: " ERROR
 THEN
+ THEN THEN
1 FCURSOR +! ;
[ELSE]
@@ 227,20 +213,23 @@ HASFLOATINGSTACK [IF]
: F} ;
: F...}T ;
+ HASFLOATING [IF]
+ DECIMAL
: COMPUTECELLSPERFP (  U )
 DEPTH 0E DEPTH >R FDROP R> SWAP  ;
+ DEPTH 0E DEPTH 1 >R FDROP R> SWAP  ;
+ HEX
COMPUTECELLSPERFP CONSTANT CELLSPERFP

+
: FTESTER ( R  )
 DEPTH CELLSPERFP < ACTUALDEPTH @ XCURSOR @ CELLSPERFP + < OR IF
 S" WRONG NUMBER OF RESULTS: " ERROR EXIT
 THEN
 ACTUALRESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF
+ DEPTH CELLSPERFP < ACTUALDEPTH @ XCURSOR @ STARTDEPTH @ + CELLSPERFP + < OR IF
+ S" NUMBER OF RESULTS AFTER '>' BELOW ...}T SPECIFICATION: " ERROR EXIT
+ ELSE ACTUALRESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF
S" INCORRECT FP RESULT: " ERROR
 THEN
+ THEN THEN
CELLSPERFP XCURSOR +! ;
 [THEN]
+ [THEN]
+[THEN]
: EMPTYSTACK \ ( ...  ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
DEPTH STARTDEPTH @ < IF
@@ 260,12 +249,12 @@ HASFLOATINGSTACK [IF]
' ERROR1 ERRORXT !
: T{ \ (  ) SYNTACTIC SUGAR.
 DEPTH STARTDEPTH ! F{ ;
+ DEPTH STARTDEPTH ! 0 XCURSOR ! F{ ;
: > \ ( ...  ) RECORD DEPTH AND CONTENT OF STACK.
DEPTH DUP ACTUALDEPTH ! \ RECORD DEPTH
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
F> ;
@@ 273,7 +262,7 @@ HASFLOATINGSTACK [IF]
\ (ACTUAL) CONTENTS.
DEPTH ACTUALDEPTH @ = IF \ IF DEPTHS MATCH
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
<> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
LOOP
@@ 284,30 +273,31 @@ HASFLOATINGSTACK [IF]
F} ;
: ...}T (  )
 DEPTH STARTDEPTH @ = 0= IF
 S" WRONG NUMBER OF RESULTS" ERROR
 THEN
 XCURSOR @ ACTUALDEPTH @ <> IF
 S" WRONG NUMBER OF RESULTS" ERROR
 THEN
+ XCURSOR @ STARTDEPTH @ + ACTUALDEPTH @ <> IF
+ S" NUMBER OF CELL RESULTS BEFORE '>' DOES NOT MATCH ...}T SPECIFICATION: " ERROR
+ ELSE DEPTH STARTDEPTH @ = 0= IF
+ S" NUMBER OF CELL RESULTS BEFORE AND AFTER '>' DOES NOT MATCH: " ERROR
+ THEN THEN
F...}T ;
: XTESTER ( X  )
 DEPTH 0= ACTUALDEPTH @ XCURSOR @ 1+ < OR IF
 S" WRONG NUMBER OF RESULTS: " ERROR EXIT
 THEN
 ACTUALRESULTS XCURSOR @ CELLS + @ <> IF
+ DEPTH 0= ACTUALDEPTH @ XCURSOR @ STARTDEPTH @ + 1+ < OR IF
+ S" NUMBER OF CELL RESULTS AFTER '>' BELOW ...}T SPECIFICATION: " ERROR EXIT
+ ELSE ACTUALRESULTS XCURSOR @ CELLS + @ <> IF
S" INCORRECT CELL RESULT: " ERROR
 THEN
+ THEN THEN
1 XCURSOR +! ;
: X}T XTESTER ...}T ;
: R}T FTESTER ...}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 ;
: RX}T XTESTER FTESTER ...}T ;
: RR}T FTESTER FTESTER ...}T ;
: XXX}T XTESTER XTESTER XTESTER ...}T ;
: XXR}T FTESTER XTESTER XTESTER ...}T ;
: XRX}T XTESTER FTESTER XTESTER ...}T ;
: XRR}T FTESTER FTESTER XTESTER ...}T ;
@@ 315,7 +305,6 @@ HASFLOATINGSTACK [IF]
: RXR}T FTESTER XTESTER FTESTER ...}T ;
: RRX}T XTESTER FTESTER FTESTER ...}T ;
: RRR}T FTESTER FTESTER FTESTER ...}T ;
: XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ;
: XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ;
: XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ;
: XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ;
@@ 331,9 +320,12 @@ HASFLOATINGSTACK [IF]
: RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ;
: RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ;
: RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ;
+[THEN]
: TESTING \ (  ) TALKING COMMENT.
SOURCE VERBOSE @
IF DUP >R TYPE CR R> >IN !
ELSE >IN ! DROP
THEN ;
+
+BASE !