1: \ This file contains the code for ttester, a utility for testing Forth words,
2: \ as developed by several authors (see below), together with some explanations
3: \ of its use.
4:
5: \ ttester is based on the original tester suite by Hayes:
6: \ From: John Hayes S1I
7: \ Subject: tester.fr
8: \ Date: Mon, 27 Nov 95 13:10:09 PST
9: \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
10: \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
11: \ VERSION 1.1
12: \ All the subsequent changes have been placed in the public domain.
13: \ The primary changes from the original are the replacement of "{" by "T{"
14: \ and "}" by "}T" (to avoid conflicts with the uses of { for locals and }
15: \ for FSL arrays), modifications so that the stack is allowed to be non-empty
16: \ before T{, and extensions for the handling of floating point tests.
17: \ Code for testing equality of floating point values comes
18: \ from ftester.fs written by David N. Williams, based on the idea of
19: \ approximate equality in Dirk Zoller's float.4th.
20: \ Further revisions were provided by Anton Ertl, including the ability
21: \ to handle either integrated or separate floating point stacks.
22: \ Revision history and possibly newer versions can be found at
23: \ http://www.complang.tuwien.ac.at/cvsweb/cgi-bin/cvsweb/gforth/test/ttester.fs
24: \ Explanatory material and minor reformatting (no code changes) by
25: \ C. G. Montgomery March 2009, with helpful comments from David Williams
26: \ and Krishna Myneni.
27:
28: \ Usage:
29:
30: \ The basic usage takes the form T{ <code> -> <expected stack> }T .
31: \ This executes <code> and compares the resulting stack contents with
32: \ the <expected stack> values, and reports any discrepancy between the
33: \ two sets of values.
34: \ For example:
35: \ T{ 1 2 3 swap -> 1 3 2 }T ok
36: \ T{ 1 2 3 swap -> 1 2 2 }T INCORRECT RESULT: T{ 1 2 3 swap -> 1 2 2 }T ok
37: \ T{ 1 2 3 swap -> 1 2 }T WRONG NUMBER OF RESULTS: T{ 1 2 3 swap -> 1 2 }T ok
38:
39: \ Floating point testing can involve further complications. The code
40: \ attempts to determine whether floating-point support is present, and
41: \ if so, whether there is a separate floating-point stack, and behave
42: \ accordingly. The CONSTANTs HAS-FLOATING and HAS-FLOATING-STACK
43: \ contain the results of its efforts, so the behavior of the code can
44: \ be modified by the user if necessary.
45:
46: \ Then there are the perennial issues of floating point value
47: \ comparisons. Exact equality is specified by SET-EXACT (the
48: \ default). If approximate equality tests are desired, execute
49: \ SET-NEAR . Then the FVARIABLEs REL-NEAR (default 1E-12) and
50: \ ABS-NEAR (default 0E) contain the values to be used in comparisons
51: \ by the (internal) word FNEARLY= .
52:
53: \ When there is not a separate floating point stack and you want to
54: \ use approximate equality for FP values, it is necessary to identify
55: \ which stack items are floating point quantities. This can be done
56: \ by replacing the closing }T with a version that specifies this, such
57: \ as RRXR}T which identifies the stack picture ( r r x r ). The code
58: \ provides such words for all combinations of R and X with up to four
59: \ stack items. They can be used with either an integrated or separate
60: \ floating point stacks. Adding more if you need them is
61: \ straightforward; see the examples in the source. Here is an example
62: \ which also illustrates controlling the precision of comparisons:
63:
64: \ SET-NEAR
65: \ 1E-6 REL-NEAR F!
66: \ T{ S" 3.14159E" >FLOAT -> -1E FACOS TRUE RX}T
67:
68: \ The word ERROR is now vectored, so that its action can be changed by
69: \ the user (for example, to add a counter for the number of errors).
70: \ The default action ERROR1 can be used as a factor in the display of
71: \ error reports.
72:
73: \ Loading ttester.fs does not change BASE. Remember that floating point input
74: \ is ambiguous if the base is not decimal.
75:
76: \ The file defines some 70 words in all, but in most cases only the
77: \ ones mentioned above will be needed for successful testing.
78:
79: BASE @
80: DECIMAL
81:
82: VARIABLE ACTUAL-DEPTH \ stack record
83: CREATE ACTUAL-RESULTS 32 CELLS ALLOT
84: VARIABLE START-DEPTH
85: VARIABLE XCURSOR \ for ...}T
86: VARIABLE ERROR-XT
87:
88: : ERROR ERROR-XT @ EXECUTE ; \ for vectoring of error reporting
89:
90: : "FLOATING" S" FLOATING" ; \ only compiled S" in CORE
91: : "FLOATING-STACK" S" FLOATING-STACK" ;
92: "FLOATING" ENVIRONMENT? [IF]
93: [IF]
94: TRUE
95: [ELSE]
96: FALSE
97: [THEN]
98: [ELSE]
99: FALSE
100: [THEN] CONSTANT HAS-FLOATING
101: "FLOATING-STACK" ENVIRONMENT? [IF]
102: [IF]
103: TRUE
104: [ELSE]
105: FALSE
106: [THEN]
107: [ELSE] \ We don't know whether the FP stack is separate.
108: HAS-FLOATING \ If we have FLOATING, we assume it is.
109: [THEN] CONSTANT HAS-FLOATING-STACK
110:
111: HAS-FLOATING [IF]
112: \ Set the following to the relative and absolute tolerances you
113: \ want for approximate float equality, to be used with F~ in
114: \ FNEARLY=. Keep the signs, because F~ needs them.
115: FVARIABLE REL-NEAR 1E-12 REL-NEAR F!
116: FVARIABLE ABS-NEAR 0E ABS-NEAR F!
117:
118: \ When EXACT? is TRUE, }F uses FEXACTLY=, otherwise FNEARLY=.
119:
120: TRUE VALUE EXACT?
121: : SET-EXACT ( -- ) TRUE TO EXACT? ;
122: : SET-NEAR ( -- ) FALSE TO EXACT? ;
123:
124: : FEXACTLY= ( F: X Y -- S: FLAG )
125: (
126: Leave TRUE if the two floats are identical.
127: )
128: 0E F~ ;
129:
130: : FABS= ( F: X Y -- S: FLAG )
131: (
132: Leave TRUE if the two floats are equal within the tolerance
133: stored in ABS-NEAR.
134: )
135: ABS-NEAR F@ F~ ;
136:
137: : FREL= ( F: X Y -- S: FLAG )
138: (
139: Leave TRUE if the two floats are relatively equal based on the
140: tolerance stored in ABS-NEAR.
141: )
142: REL-NEAR F@ FNEGATE F~ ;
143:
144: : F2DUP FOVER FOVER ;
145: : F2DROP FDROP FDROP ;
146:
147: : FNEARLY= ( F: X Y -- S: FLAG )
148: (
149: Leave TRUE if the two floats are nearly equal. This is a
150: refinement of Dirk Zoller's FEQ to also allow X = Y, including
151: both zero, or to allow approximately equality when X and Y are too
152: small to satisfy the relative approximation mode in the F~
153: specification.
154: )
155: F2DUP FEXACTLY= IF F2DROP TRUE EXIT THEN
156: F2DUP FREL= IF F2DROP TRUE EXIT THEN
157: FABS= ;
158:
159: : FCONF= ( R1 R2 -- F )
160: EXACT? IF
161: FEXACTLY=
162: ELSE
163: FNEARLY=
164: THEN ;
165: [THEN]
166:
167: HAS-FLOATING-STACK [IF]
168: VARIABLE ACTUAL-FDEPTH
169: CREATE ACTUAL-FRESULTS 32 FLOATS ALLOT
170: VARIABLE START-FDEPTH
171: VARIABLE FCURSOR
172:
173: : EMPTY-FSTACK ( ... -- ... )
174: FDEPTH START-FDEPTH @ < IF
175: FDEPTH START-FDEPTH @ SWAP DO 0E LOOP
176: THEN
177: FDEPTH START-FDEPTH @ > IF
178: FDEPTH START-FDEPTH @ DO FDROP LOOP
179: THEN ;
180:
181: : F{ ( -- )
182: FDEPTH START-FDEPTH ! 0 FCURSOR ! ;
183:
184: : F-> ( ... -- ... )
185: FDEPTH DUP ACTUAL-FDEPTH !
186: START-FDEPTH @ > IF
187: FDEPTH START-FDEPTH @ - 0 DO ACTUAL-FRESULTS I FLOATS + F! LOOP
188: THEN ;
189:
190: : F} ( ... -- ... )
191: FDEPTH ACTUAL-FDEPTH @ = IF
192: FDEPTH START-FDEPTH @ > IF
193: FDEPTH START-FDEPTH @ - 0 DO
194: ACTUAL-FRESULTS I FLOATS + F@ FCONF= INVERT IF
195: S" INCORRECT FP RESULT: " ERROR LEAVE
196: THEN
197: LOOP
198: THEN
199: ELSE
200: S" WRONG NUMBER OF FP RESULTS: " ERROR
201: THEN ;
202:
203: : F...}T ( -- )
204: FCURSOR @ START-FDEPTH @ + ACTUAL-FDEPTH @ <> IF
205: S" NUMBER OF FLOAT RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR
206: ELSE FDEPTH START-FDEPTH @ = 0= IF
207: S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR
208: THEN THEN ;
209:
210:
211: : FTESTER ( R -- )
212: FDEPTH 0= ACTUAL-FDEPTH @ FCURSOR @ START-FDEPTH @ + 1+ < OR IF
213: S" NUMBER OF FLOAT RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR
214: ELSE ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF
215: S" INCORRECT FP RESULT: " ERROR
216: THEN THEN
217: 1 FCURSOR +! ;
218:
219: [ELSE]
220: : EMPTY-FSTACK ;
221: : F{ ;
222: : F-> ;
223: : F} ;
224: : F...}T ;
225:
226: HAS-FLOATING [IF]
227: : COMPUTE-CELLS-PER-FP ( -- U )
228: DEPTH 0E DEPTH 1- >R FDROP R> SWAP - ;
229:
230: COMPUTE-CELLS-PER-FP CONSTANT CELLS-PER-FP
231:
232: : FTESTER ( R -- )
233: DEPTH CELLS-PER-FP < ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + CELLS-PER-FP + < OR IF
234: S" NUMBER OF RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
235: ELSE ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF
236: S" INCORRECT FP RESULT: " ERROR
237: THEN THEN
238: CELLS-PER-FP XCURSOR +! ;
239: [THEN]
240: [THEN]
241:
242: : EMPTY-STACK \ ( ... -- ) empty stack; handles underflowed stack too.
243: DEPTH START-DEPTH @ < IF
244: DEPTH START-DEPTH @ SWAP DO 0 LOOP
245: THEN
246: DEPTH START-DEPTH @ > IF
247: DEPTH START-DEPTH @ DO DROP LOOP
248: THEN
249: EMPTY-FSTACK ;
250:
251: : ERROR1 \ ( C-ADDR U -- ) display an error message
252: \ followed by the line that had the error.
253: TYPE SOURCE TYPE CR \ display line corresponding to error
254: EMPTY-STACK \ throw away everything else
255: ;
256:
257: ' ERROR1 ERROR-XT !
258:
259: : T{ \ ( -- ) syntactic sugar.
260: DEPTH START-DEPTH ! 0 XCURSOR ! F{ ;
261:
262: : -> \ ( ... -- ) record depth and contents of stack.
263: DEPTH DUP ACTUAL-DEPTH ! \ record depth
264: START-DEPTH @ > IF \ if there is something on the stack
265: DEPTH START-DEPTH @ - 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ save them
266: THEN
267: F-> ;
268:
269: : }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
270: \ (ACTUAL) CONTENTS.
271: DEPTH ACTUAL-DEPTH @ = IF \ if depths match
272: DEPTH START-DEPTH @ > IF \ if there is something on the stack
273: DEPTH START-DEPTH @ - 0 DO \ for each stack item
274: ACTUAL-RESULTS I CELLS + @ \ compare actual with expected
275: <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
276: LOOP
277: THEN
278: ELSE \ depth mismatch
279: S" WRONG NUMBER OF RESULTS: " ERROR
280: THEN
281: F} ;
282:
283: : ...}T ( -- )
284: XCURSOR @ START-DEPTH @ + ACTUAL-DEPTH @ <> IF
285: S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR
286: ELSE DEPTH START-DEPTH @ = 0= IF
287: S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR
288: THEN THEN
289: F...}T ;
290:
291: : XTESTER ( X -- )
292: DEPTH 0= ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + 1+ < OR IF
293: S" NUMBER OF CELL RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
294: ELSE ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF
295: S" INCORRECT CELL RESULT: " ERROR
296: THEN THEN
297: 1 XCURSOR +! ;
298:
299: : X}T XTESTER ...}T ;
300: : XX}T XTESTER XTESTER ...}T ;
301: : XXX}T XTESTER XTESTER XTESTER ...}T ;
302: : XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ;
303:
304: HAS-FLOATING [IF]
305: : R}T FTESTER ...}T ;
306: : XR}T FTESTER XTESTER ...}T ;
307: : RX}T XTESTER FTESTER ...}T ;
308: : RR}T FTESTER FTESTER ...}T ;
309: : XXR}T FTESTER XTESTER XTESTER ...}T ;
310: : XRX}T XTESTER FTESTER XTESTER ...}T ;
311: : XRR}T FTESTER FTESTER XTESTER ...}T ;
312: : RXX}T XTESTER XTESTER FTESTER ...}T ;
313: : RXR}T FTESTER XTESTER FTESTER ...}T ;
314: : RRX}T XTESTER FTESTER FTESTER ...}T ;
315: : RRR}T FTESTER FTESTER FTESTER ...}T ;
316: : XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ;
317: : XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ;
318: : XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ;
319: : XRXX}T XTESTER XTESTER FTESTER XTESTER ...}T ;
320: : XRXR}T FTESTER XTESTER FTESTER XTESTER ...}T ;
321: : XRRX}T XTESTER FTESTER FTESTER XTESTER ...}T ;
322: : XRRR}T FTESTER FTESTER FTESTER XTESTER ...}T ;
323: : RXXX}T XTESTER XTESTER XTESTER FTESTER ...}T ;
324: : RXXR}T FTESTER XTESTER XTESTER FTESTER ...}T ;
325: : RXRX}T XTESTER FTESTER XTESTER FTESTER ...}T ;
326: : RXRR}T FTESTER FTESTER XTESTER FTESTER ...}T ;
327: : RRXX}T XTESTER XTESTER FTESTER FTESTER ...}T ;
328: : RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ;
329: : RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ;
330: : RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ;
331: [THEN]
332:
333: \ Set the following flag to TRUE for more verbose output; this may
334: \ allow you to tell which test caused your system to hang.
335: VARIABLE VERBOSE
336: FALSE VERBOSE !
337:
338: : TESTING \ ( -- ) TALKING COMMENT.
339: SOURCE VERBOSE @
340: IF DUP >R TYPE CR R> >IN !
341: ELSE >IN ! DROP
342: THEN ;
343:
344: BASE !
345: \ end of ttester.fs
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>