1\ for the original tester
2\ From: John Hayes S1I
3\ Subject: tester.fr
4\ Date: Mon, 27 Nov 95 13:10:09 PST
5\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
6\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
7\ VERSION 1.1
8
9\ for the FNEARLY= stuff:
10\ from ftester.fs written by David N. Williams, based on the idea of
11\ approximate equality in Dirk Zoller's float.4th
12\ public domain
13
14\ for the rest:
15\ revised by Anton Ertl 2007-08-12, 2007-08-19, 2007-08-28
16\ public domain
17
18\ The original has the following shortcomings:
19
20\ - It does not work as expected if the stack is non-empty before the {.
21
22\ - It does not check FP results if the system has a separate FP stack.
23
24\ - There is a conflict with the use of } for FSL arrays and { for locals.
25
26\ I have revised it to address these shortcomings.  You can find the
27\ result at
28
29\ http://www.forth200x.org/tests/tester.fs
30\ http://www.forth200x.org/tests/ttester.fs
31
32\ tester.fs is intended to be a drop-in replacement of the original.
33
34\ ttester.fs is a version that uses T{ and }T instead of { and } and
35\ keeps the BASE as it was before loading ttester.fs
36
37\ In spirit of the original, I have strived to avoid any potential
38\ non-portabilities and stayed as much within the CORE words as
39\ possible; e.g., FLOATING words are used only if the FLOATING wordset
40\ is present
41
42\ There are a few things to be noted:
43
44\ - Loading ttester.fs does not change BASE.  Loading tester.fs
45\ changes BASE to HEX (like the original tester).  Floating-point
46\ input is ambiguous when the base is not decimal, so you have to set
47\ it to decimal yourself when you want to deal with decimal numbers.
48
49\ - For FP it is often useful to use approximate equality for checking
50\ the results.  You can turn on approximate matching with SET-NEAR
51\ (and turn it off (default) with SET-EXACT, and you can tune it by
52\ setting the variables REL-NEAR and ABS-NEAR.  If you want your tests
53\ to work with a shared stack, you have to specify the types of the
54\ elements on the stack by using one of the closing words that specify
55\ types, e.g. RRRX}T for checking the stack picture ( r r r x ).
56\ There are such words for all combination of R and X with up to 4
57\ stack items, and defining more if you need them is straightforward
58\ (see source).  If your tests are only intended for a separate-stack
59\ system or if you need only exact matching, you can use the plain }T
60\ instead.
61
62BASE @
63HEX
64
65\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
66\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
67VARIABLE VERBOSE
68   FALSE VERBOSE !
69
70VARIABLE ACTUAL-DEPTH			\ STACK RECORD
71CREATE ACTUAL-RESULTS 20 CELLS ALLOT
72VARIABLE START-DEPTH
73VARIABLE XCURSOR \ FOR ...}T
74VARIABLE ERROR-XT
75
76: ERROR ERROR-XT @ EXECUTE ;
77
78: "FLOATING" S" FLOATING" ; \ ONLY COMPILED S" IN CORE
79: "FLOATING-STACK" S" FLOATING-STACK" ;
80"FLOATING" ENVIRONMENT? [IF]
81    [IF]
82        TRUE
83    [ELSE]
84        FALSE
85    [THEN]
86[ELSE]
87    FALSE
88[THEN] CONSTANT HAS-FLOATING
89"FLOATING-STACK" ENVIRONMENT? [IF]
90    [IF]
91        TRUE
92    [ELSE]
93        FALSE
94    [THEN]
95[ELSE] \ WE DON'T KNOW WHETHER THE FP STACK IS SEPARATE
96    HAS-FLOATING \ IF WE HAVE FLOATING, WE ASSUME IT IS
97[THEN] CONSTANT HAS-FLOATING-STACK
98
99HAS-FLOATING [IF]
100    \ SET THE FOLLOWING TO THE RELATIVE AND ABSOLUTE TOLERANCES YOU
101    \ WANT FOR APPROXIMATE FLOAT EQUALITY, TO BE USED WITH F~ IN
102    \ FNEARLY=.  KEEP THE SIGNS, BECAUSE F~ NEEDS THEM.
103    FVARIABLE REL-NEAR DECIMAL 1E-12 HEX REL-NEAR F!
104    FVARIABLE ABS-NEAR    DECIMAL 0E HEX ABS-NEAR F!
105
106    \ WHEN EXACT? IS TRUE, }F USES FEXACTLY=, OTHERWISE FNEARLY=.
107
108    TRUE VALUE EXACT?
109    : SET-EXACT  ( -- )   TRUE TO EXACT? ;
110    : SET-NEAR   ( -- )  FALSE TO EXACT? ;
111
112    DECIMAL
113    : FEXACTLY=  ( F: X Y -- S: FLAG )
114        (
115        LEAVE TRUE IF THE TWO FLOATS ARE IDENTICAL.
116        )
117        0E F~ ;
118    HEX
119
120    : FABS=  ( F: X Y -- S: FLAG )
121        (
122        LEAVE TRUE IF THE TWO FLOATS ARE EQUAL WITHIN THE TOLERANCE
123        STORED IN ABS-NEAR.
124        )
125        ABS-NEAR F@ F~ ;
126
127    : FREL=  ( F: X Y -- S: FLAG )
128        (
129        LEAVE TRUE IF THE TWO FLOATS ARE RELATIVELY EQUAL BASED ON THE
130        TOLERANCE STORED IN ABS-NEAR.
131        )
132        REL-NEAR F@ FNEGATE F~ ;
133
134    : F2DUP  FOVER FOVER ;
135    : F2DROP FDROP FDROP ;
136
137    : FNEARLY=  ( F: X Y -- S: FLAG )
138        (
139        LEAVE TRUE IF THE TWO FLOATS ARE NEARLY EQUAL.  THIS IS A
140        REFINEMENT OF DIRK ZOLLER'S FEQ TO ALSO ALLOW X = Y, INCLUDING
141        BOTH ZERO, OR TO ALLOW APPROXIMATE EQUALITY WHEN X AND Y ARE TOO
142        SMALL TO SATISFY THE RELATIVE APPROXIMATION MODE IN THE F~
143        SPECIFICATION.
144        )
145        F2DUP FEXACTLY= IF F2DROP TRUE EXIT THEN
146        F2DUP FREL=     IF F2DROP TRUE EXIT THEN
147        FABS= ;
148
149    : FCONF= ( R1 R2 -- F )
150        EXACT? IF
151            FEXACTLY=
152        ELSE
153            FNEARLY=
154        THEN ;
155[THEN]
156
157HAS-FLOATING-STACK [IF]
158    VARIABLE ACTUAL-FDEPTH
159    CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT
160    VARIABLE START-FDEPTH
161    VARIABLE FCURSOR
162
163    : EMPTY-FSTACK ( ... -- ... )
164        FDEPTH START-FDEPTH @ < IF
165            FDEPTH START-FDEPTH @ SWAP DO 0E LOOP
166        THEN
167        FDEPTH START-FDEPTH @ > IF
168            FDEPTH START-FDEPTH @ DO FDROP LOOP
169        THEN ;
170
171    : F{ ( -- )
172        FDEPTH START-FDEPTH ! 0 FCURSOR ! ;
173
174    : F-> ( ... -- ... )
175        FDEPTH DUP ACTUAL-FDEPTH !
176        START-FDEPTH @ > IF
177            FDEPTH START-FDEPTH @ - 0 DO ACTUAL-FRESULTS I FLOATS + F! LOOP
178        THEN ;
179
180    : F} ( ... -- ... )
181        FDEPTH ACTUAL-FDEPTH @ = IF
182            FDEPTH START-FDEPTH @ > IF
183                FDEPTH START-FDEPTH @ - 0 DO
184                    ACTUAL-FRESULTS I FLOATS + F@ FCONF= INVERT IF
185                        S" INCORRECT FP RESULT: " ERROR LEAVE
186                    THEN
187                LOOP
188            THEN
189        ELSE
190            S" WRONG NUMBER OF FP RESULTS: " ERROR
191        THEN ;
192
193    : F...}T ( -- )
194        FCURSOR @ START-FDEPTH @ + ACTUAL-FDEPTH @ <> IF
195            S" NUMBER OF FLOAT RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR
196        ELSE FDEPTH START-FDEPTH @ = 0= IF
197            S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR
198        THEN THEN ;
199
200
201    : FTESTER ( R -- )
202        FDEPTH 0= ACTUAL-FDEPTH @ FCURSOR @ START-FDEPTH @ + 1+ < OR IF
203            S" NUMBER OF FLOAT RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR
204        ELSE ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF
205            S" INCORRECT FP RESULT: " ERROR
206        THEN THEN
207        1 FCURSOR +! ;
208
209[ELSE]
210    : EMPTY-FSTACK ;
211    : F{ ;
212    : F-> ;
213    : F} ;
214    : F...}T ;
215
216    DECIMAL
217    : COMPUTE-CELLS-PER-FP ( -- U )
218        DEPTH 0E DEPTH 1- >R FDROP R> SWAP - ;
219    HEX
220
221    COMPUTE-CELLS-PER-FP CONSTANT CELLS-PER-FP
222
223    : FTESTER ( R -- )
224        DEPTH CELLS-PER-FP < ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + CELLS-PER-FP + < OR IF
225            S" NUMBER OF RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
226        ELSE ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF
227            S" INCORRECT FP RESULT: " ERROR
228        THEN THEN
229        CELLS-PER-FP XCURSOR +! ;
230 [THEN]
231
232: EMPTY-STACK	\ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
233    DEPTH START-DEPTH @ < IF
234        DEPTH START-DEPTH @ SWAP DO 0 LOOP
235    THEN
236    DEPTH START-DEPTH @ > IF
237        DEPTH START-DEPTH @ DO DROP LOOP
238    THEN
239    EMPTY-FSTACK ;
240
241: ERROR1	\ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
242		\ THE LINE THAT HAD THE ERROR.
243   TYPE SOURCE TYPE CR			\ DISPLAY LINE CORRESPONDING TO ERROR
244   EMPTY-STACK				\ THROW AWAY EVERY THING ELSE
245;
246
247' ERROR1 ERROR-XT !
248
249: T{		\ ( -- ) SYNTACTIC SUGAR.
250   DEPTH START-DEPTH ! 0 XCURSOR ! F{ ;
251
252: ->		\ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
253   DEPTH DUP ACTUAL-DEPTH !		\ RECORD DEPTH
254   START-DEPTH @ > IF		\ IF THERE IS SOMETHING ON STACK
255       DEPTH START-DEPTH @ - 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
256   THEN
257   F-> ;
258
259: }T		\ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
260		\ (ACTUAL) CONTENTS.
261   DEPTH ACTUAL-DEPTH @ = IF		\ IF DEPTHS MATCH
262      DEPTH START-DEPTH @ > IF		\ IF THERE IS SOMETHING ON THE STACK
263         DEPTH START-DEPTH @ - 0 DO	\ FOR EACH STACK ITEM
264	    ACTUAL-RESULTS I CELLS + @	\ COMPARE ACTUAL WITH EXPECTED
265	    <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
266	 LOOP
267      THEN
268   ELSE					\ DEPTH MISMATCH
269      S" WRONG NUMBER OF RESULTS: " ERROR
270   THEN
271   F} ;
272
273: ...}T ( -- )
274    XCURSOR @ START-DEPTH @ + ACTUAL-DEPTH @ <> IF
275        S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR
276    ELSE DEPTH START-DEPTH @ = 0= IF
277        S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR
278    THEN THEN
279    F...}T ;
280
281: XTESTER ( X -- )
282    DEPTH 0= ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + 1+ < OR IF
283        S" NUMBER OF CELL RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
284    ELSE ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF
285        S" INCORRECT CELL RESULT: " ERROR
286    THEN THEN
287    1 XCURSOR +! ;
288
289: X}T XTESTER ...}T ;
290: R}T FTESTER ...}T ;
291: XX}T XTESTER XTESTER ...}T ;
292: XR}T FTESTER XTESTER ...}T ;
293: RX}T XTESTER FTESTER ...}T ;
294: RR}T FTESTER FTESTER ...}T ;
295: XXX}T XTESTER XTESTER XTESTER ...}T ;
296: XXR}T FTESTER XTESTER XTESTER ...}T ;
297: XRX}T XTESTER FTESTER XTESTER ...}T ;
298: XRR}T FTESTER FTESTER XTESTER ...}T ;
299: RXX}T XTESTER XTESTER FTESTER ...}T ;
300: RXR}T FTESTER XTESTER FTESTER ...}T ;
301: RRX}T XTESTER FTESTER FTESTER ...}T ;
302: RRR}T FTESTER FTESTER FTESTER ...}T ;
303: XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ;
304: XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ;
305: XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ;
306: XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ;
307: XRXX}T XTESTER XTESTER FTESTER XTESTER ...}T ;
308: XRXR}T FTESTER XTESTER FTESTER XTESTER ...}T ;
309: XRRX}T XTESTER FTESTER FTESTER XTESTER ...}T ;
310: XRRR}T FTESTER FTESTER FTESTER XTESTER ...}T ;
311: RXXX}T XTESTER XTESTER XTESTER FTESTER ...}T ;
312: RXXR}T FTESTER XTESTER XTESTER FTESTER ...}T ;
313: RXRX}T XTESTER FTESTER XTESTER FTESTER ...}T ;
314: RXRR}T FTESTER FTESTER XTESTER FTESTER ...}T ;
315: RRXX}T XTESTER XTESTER FTESTER FTESTER ...}T ;
316: RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ;
317: RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ;
318: RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ;
319
320: TESTING	\ ( -- ) TALKING COMMENT.
321   SOURCE VERBOSE @
322   IF DUP >R TYPE CR R> >IN !
323   ELSE >IN ! DROP
324   THEN ;
325
326BASE !
327