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
5
\ ttester is based on the original tester suite by Hayes:
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.
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
27
\ 25/4/2015 Variable #ERRORS added to accumulate count of errors for
28
\ error report at end of tests
32
\ The basic usage takes the form T{ <code> -> <expected stack> }T .
33
\ This executes <code> and compares the resulting stack contents with
34
\ the <expected stack> values, and reports any discrepancy between the
37
\ T{ 1 2 3 swap -> 1 3 2 }T ok
38
\ T{ 1 2 3 swap -> 1 2 2 }T INCORRECT RESULT: T{ 1 2 3 swap -> 1 2 2 }T ok
39
\ T{ 1 2 3 swap -> 1 2 }T WRONG NUMBER OF RESULTS: T{ 1 2 3 swap -> 1 2 }T ok
41
\ Floating point testing can involve further complications. The code
42
\ attempts to determine whether floating-point support is present, and
43
\ if so, whether there is a separate floating-point stack, and behave
44
\ accordingly. The CONSTANTs HAS-FLOATING and HAS-FLOATING-STACK
45
\ contain the results of its efforts, so the behavior of the code can
46
\ be modified by the user if necessary.
48
\ Then there are the perennial issues of floating point value
49
\ comparisons. Exact equality is specified by SET-EXACT (the
50
\ default). If approximate equality tests are desired, execute
51
\ SET-NEAR . Then the FVARIABLEs REL-NEAR (default 1E-12) and
52
\ ABS-NEAR (default 0E) contain the values to be used in comparisons
53
\ by the (internal) word FNEARLY= .
55
\ When there is not a separate floating point stack and you want to
56
\ use approximate equality for FP values, it is necessary to identify
57
\ which stack items are floating point quantities. This can be done
58
\ by replacing the closing }T with a version that specifies this, such
59
\ as RRXR}T which identifies the stack picture ( r r x r ). The code
60
\ provides such words for all combinations of R and X with up to four
61
\ stack items. They can be used with either an integrated or separate
62
\ floating point stacks. Adding more if you need them is
63
\ straightforward; see the examples in the source. Here is an example
64
\ which also illustrates controlling the precision of comparisons:
68
\ T{ S" 3.14159E" >FLOAT -> -1E FACOS TRUE RX}T
70
\ The word ERROR is now vectored, so that its action can be changed by
71
\ the user (for example, to improve the basic error counter for the
72
\ number of errors). The default action ERROR1 can be used as a factor
73
\ in the display of error reports.
75
\ Loading ttester.fs does not change BASE. Remember that floating point input
76
\ is ambiguous if the base is not decimal.
78
\ The file defines some 70 words in all, but in most cases only the
79
\ ones mentioned above will be needed for successful testing.
84
VARIABLE ACTUAL-DEPTH \ stack record
85
CREATE ACTUAL-RESULTS 32 CELLS ALLOT
87
VARIABLE XCURSOR \ for ...}T
89
VARIABLE #ERRORS 0 #ERRORS ! \ For counting errors
91
: ERROR ERROR-XT @ EXECUTE ; \ for vectoring of error reporting
93
: "FLOATING" S" FLOATING" ; \ only compiled S" in CORE
94
: "FLOATING-STACK" S" FLOATING-STACK" ;
95
"FLOATING" ENVIRONMENT? [IF]
103
[THEN] CONSTANT HAS-FLOATING
104
"FLOATING-STACK" ENVIRONMENT? [IF]
110
[ELSE] \ We don't know whether the FP stack is separate.
111
HAS-FLOATING \ If we have FLOATING, we assume it is.
112
[THEN] CONSTANT HAS-FLOATING-STACK
115
\ Set the following to the relative and absolute tolerances you
116
\ want for approximate float equality, to be used with F~ in
117
\ FNEARLY=. Keep the signs, because F~ needs them.
118
FVARIABLE REL-NEAR 1E-12 REL-NEAR F!
119
FVARIABLE ABS-NEAR 0E ABS-NEAR F!
121
\ When EXACT? is TRUE, }F uses FEXACTLY=, otherwise FNEARLY=.
124
: SET-EXACT ( -- ) TRUE TO EXACT? ;
125
: SET-NEAR ( -- ) FALSE TO EXACT? ;
127
: FEXACTLY= ( F: X Y -- S: FLAG )
129
Leave TRUE if the two floats are identical.
133
: FABS= ( F: X Y -- S: FLAG )
135
Leave TRUE if the two floats are equal within the tolerance
140
: FREL= ( F: X Y -- S: FLAG )
142
Leave TRUE if the two floats are relatively equal based on the
143
tolerance stored in ABS-NEAR.
145
REL-NEAR F@ FNEGATE F~ ;
147
: F2DUP FOVER FOVER ;
148
: F2DROP FDROP FDROP ;
150
: FNEARLY= ( F: X Y -- S: FLAG )
152
Leave TRUE if the two floats are nearly equal. This is a
153
refinement of Dirk Zoller's FEQ to also allow X = Y, including
154
both zero, or to allow approximately equality when X and Y are too
155
small to satisfy the relative approximation mode in the F~
158
F2DUP FEXACTLY= IF F2DROP TRUE EXIT THEN
159
F2DUP FREL= IF F2DROP TRUE EXIT THEN
162
: FCONF= ( R1 R2 -- F )
170
HAS-FLOATING-STACK [IF]
171
VARIABLE ACTUAL-FDEPTH
172
CREATE ACTUAL-FRESULTS 32 FLOATS ALLOT
173
VARIABLE START-FDEPTH
176
: EMPTY-FSTACK ( ... -- ... )
177
FDEPTH START-FDEPTH @ < IF
178
FDEPTH START-FDEPTH @ SWAP DO 0E LOOP
180
FDEPTH START-FDEPTH @ > IF
181
FDEPTH START-FDEPTH @ DO FDROP LOOP
185
FDEPTH START-FDEPTH ! 0 FCURSOR ! ;
188
FDEPTH DUP ACTUAL-FDEPTH !
190
FDEPTH START-FDEPTH @ - 0 DO ACTUAL-FRESULTS I FLOATS + F! LOOP
194
FDEPTH ACTUAL-FDEPTH @ = IF
195
FDEPTH START-FDEPTH @ > IF
196
FDEPTH START-FDEPTH @ - 0 DO
197
ACTUAL-FRESULTS I FLOATS + F@ FCONF= INVERT IF
198
S" INCORRECT FP RESULT: " ERROR LEAVE
203
S" WRONG NUMBER OF FP RESULTS: " ERROR
207
FCURSOR @ START-FDEPTH @ + ACTUAL-FDEPTH @ <> IF
208
S" NUMBER OF FLOAT RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR
209
ELSE FDEPTH START-FDEPTH @ = 0= IF
210
S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR
215
FDEPTH 0= ACTUAL-FDEPTH @ FCURSOR @ START-FDEPTH @ + 1+ < OR IF
216
S" NUMBER OF FLOAT RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR
217
ELSE ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF
218
S" INCORRECT FP RESULT: " ERROR
230
: COMPUTE-CELLS-PER-FP ( -- U )
231
DEPTH 0E DEPTH 1- >R FDROP R> SWAP - ;
233
COMPUTE-CELLS-PER-FP CONSTANT CELLS-PER-FP
236
DEPTH CELLS-PER-FP < ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + CELLS-PER-FP + < OR IF
237
S" NUMBER OF RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
238
ELSE ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF
239
S" INCORRECT FP RESULT: " ERROR
241
CELLS-PER-FP XCURSOR +! ;
245
: EMPTY-STACK \ ( ... -- ) empty stack; handles underflowed stack too.
246
DEPTH START-DEPTH @ < IF
247
DEPTH START-DEPTH @ SWAP DO 0 LOOP
249
DEPTH START-DEPTH @ > IF
250
DEPTH START-DEPTH @ DO DROP LOOP
254
: ERROR1 \ ( C-ADDR U -- ) display an error message
255
\ followed by the line that had the error.
256
TYPE SOURCE TYPE CR \ display line corresponding to error
257
EMPTY-STACK \ throw away everything else
258
#ERRORS @ 1 + #ERRORS ! \ update error count
263
: T{ \ ( -- ) syntactic sugar.
264
DEPTH START-DEPTH ! 0 XCURSOR ! F{ ;
266
: -> \ ( ... -- ) record depth and contents of stack.
267
DEPTH DUP ACTUAL-DEPTH ! \ record depth
268
START-DEPTH @ > IF \ if there is something on the stack
269
DEPTH START-DEPTH @ - 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ save them
273
: }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
275
DEPTH ACTUAL-DEPTH @ = IF \ if depths match
276
DEPTH START-DEPTH @ > IF \ if there is something on the stack
277
DEPTH START-DEPTH @ - 0 DO \ for each stack item
278
ACTUAL-RESULTS I CELLS + @ \ compare actual with expected
279
<> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
282
ELSE \ depth mismatch
283
S" WRONG NUMBER OF RESULTS: " ERROR
288
XCURSOR @ START-DEPTH @ + ACTUAL-DEPTH @ <> IF
289
S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR
290
ELSE DEPTH START-DEPTH @ = 0= IF
291
S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR
296
DEPTH 0= ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + 1+ < OR IF
297
S" NUMBER OF CELL RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
298
ELSE ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF
299
S" INCORRECT CELL RESULT: " ERROR
304
: XX}T XTESTER XTESTER ...}T ;
305
: XXX}T XTESTER XTESTER XTESTER ...}T ;
306
: XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ;
310
: XR}T FTESTER XTESTER ...}T ;
311
: RX}T XTESTER FTESTER ...}T ;
312
: RR}T FTESTER FTESTER ...}T ;
313
: XXR}T FTESTER XTESTER XTESTER ...}T ;
314
: XRX}T XTESTER FTESTER XTESTER ...}T ;
315
: XRR}T FTESTER FTESTER XTESTER ...}T ;
316
: RXX}T XTESTER XTESTER FTESTER ...}T ;
317
: RXR}T FTESTER XTESTER FTESTER ...}T ;
318
: RRX}T XTESTER FTESTER FTESTER ...}T ;
319
: RRR}T FTESTER FTESTER FTESTER ...}T ;
320
: XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ;
321
: XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ;
322
: XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ;
323
: XRXX}T XTESTER XTESTER FTESTER XTESTER ...}T ;
324
: XRXR}T FTESTER XTESTER FTESTER XTESTER ...}T ;
325
: XRRX}T XTESTER FTESTER FTESTER XTESTER ...}T ;
326
: XRRR}T FTESTER FTESTER FTESTER XTESTER ...}T ;
327
: RXXX}T XTESTER XTESTER XTESTER FTESTER ...}T ;
328
: RXXR}T FTESTER XTESTER XTESTER FTESTER ...}T ;
329
: RXRX}T XTESTER FTESTER XTESTER FTESTER ...}T ;
330
: RXRR}T FTESTER FTESTER XTESTER FTESTER ...}T ;
331
: RRXX}T XTESTER XTESTER FTESTER FTESTER ...}T ;
332
: RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ;
333
: RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ;
334
: RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ;
337
\ Set the following flag to TRUE for more verbose output; this may
338
\ allow you to tell which test caused your system to hang.
342
: TESTING \ ( -- ) TALKING COMMENT.
344
IF DUP >R TYPE CR R> >IN !