Annotation of gforth/test/ttester.fs, revision 1.14
1.14 ! anton 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:
1.7 anton 6: \ From: John Hayes S1I
7: \ Subject: tester.fr
8: \ Date: Mon, 27 Nov 95 13:10:09 PST
1.1 anton 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
1.14 ! anton 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
1.7 anton 18: \ from ftester.fs written by David N. Williams, based on the idea of
1.14 ! anton 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
1.13 anton 23: \ http://www.complang.tuwien.ac.at/cvsweb/cgi-bin/cvsweb/gforth/test/ttester.fs
1.14 ! anton 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.
1.13 anton 72:
1.14 ! anton 73: \ Loading ttester.fs does not change BASE. Remember that floating point input
! 74: \ is ambiguous if the base is not decimal.
1.7 anton 75:
1.14 ! anton 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.
1.1 anton 78:
1.4 anton 79: BASE @
1.1 anton 80: HEX
81:
1.14 ! anton 82: VARIABLE ACTUAL-DEPTH \ stack record
1.1 anton 83: CREATE ACTUAL-RESULTS 20 CELLS ALLOT
84: VARIABLE START-DEPTH
1.14 ! anton 85: VARIABLE XCURSOR \ for ...}T
1.1 anton 86: VARIABLE ERROR-XT
87:
1.14 ! anton 88: : ERROR ERROR-XT @ EXECUTE ; \ for vectoring of error reporting
1.1 anton 89:
1.14 ! anton 90: : "FLOATING" S" FLOATING" ; \ only compiled S" in CORE
1.1 anton 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]
1.14 ! anton 107: [ELSE] \ We don't know whether the FP stack is separate.
! 108: HAS-FLOATING \ If we have FLOATING, we assume it is.
1.1 anton 109: [THEN] CONSTANT HAS-FLOATING-STACK
110:
111: HAS-FLOATING [IF]
1.14 ! anton 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.
1.5 anton 115: FVARIABLE REL-NEAR DECIMAL 1E-12 HEX REL-NEAR F!
1.1 anton 116: FVARIABLE ABS-NEAR DECIMAL 0E HEX ABS-NEAR F!
117:
1.14 ! anton 118: \ When EXACT? is TRUE, }F uses FEXACTLY=, otherwise FNEARLY=.
1.1 anton 119:
120: TRUE VALUE EXACT?
121: : SET-EXACT ( -- ) TRUE TO EXACT? ;
122: : SET-NEAR ( -- ) FALSE TO EXACT? ;
123:
124: DECIMAL
125: : FEXACTLY= ( F: X Y -- S: FLAG )
126: (
1.14 ! anton 127: Leave TRUE if the two floats are identical.
1.1 anton 128: )
129: 0E F~ ;
130: HEX
131:
132: : FABS= ( F: X Y -- S: FLAG )
133: (
1.14 ! anton 134: Leave TRUE if the two floats are equal within the tolerance
! 135: stored in ABS-NEAR.
1.1 anton 136: )
137: ABS-NEAR F@ F~ ;
138:
139: : FREL= ( F: X Y -- S: FLAG )
140: (
1.14 ! anton 141: Leave TRUE if the two floats are relatively equal based on the
! 142: tolerance stored in ABS-NEAR.
1.1 anton 143: )
144: REL-NEAR F@ FNEGATE F~ ;
145:
146: : F2DUP FOVER FOVER ;
147: : F2DROP FDROP FDROP ;
148:
149: : FNEARLY= ( F: X Y -- S: FLAG )
150: (
1.14 ! anton 151: Leave TRUE if the two floats are nearly equal. This is a
! 152: refinement of Dirk Zoller's FEQ to also allow X = Y, including
! 153: both zero, or to allow approximately equality when X and Y are too
! 154: small to satisfy the relative approximation mode in the F~
! 155: specification.
1.1 anton 156: )
157: F2DUP FEXACTLY= IF F2DROP TRUE EXIT THEN
158: F2DUP FREL= IF F2DROP TRUE EXIT THEN
159: FABS= ;
160:
161: : FCONF= ( R1 R2 -- F )
162: EXACT? IF
163: FEXACTLY=
164: ELSE
165: FNEARLY=
166: THEN ;
167: [THEN]
168:
169: HAS-FLOATING-STACK [IF]
170: VARIABLE ACTUAL-FDEPTH
171: CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT
172: VARIABLE START-FDEPTH
173: VARIABLE FCURSOR
174:
175: : EMPTY-FSTACK ( ... -- ... )
176: FDEPTH START-FDEPTH @ < IF
177: FDEPTH START-FDEPTH @ SWAP DO 0E LOOP
178: THEN
179: FDEPTH START-FDEPTH @ > IF
180: FDEPTH START-FDEPTH @ DO FDROP LOOP
181: THEN ;
182:
183: : F{ ( -- )
184: FDEPTH START-FDEPTH ! 0 FCURSOR ! ;
185:
186: : F-> ( ... -- ... )
187: FDEPTH DUP ACTUAL-FDEPTH !
188: START-FDEPTH @ > IF
1.8 anton 189: FDEPTH START-FDEPTH @ - 0 DO ACTUAL-FRESULTS I FLOATS + F! LOOP
1.1 anton 190: THEN ;
191:
192: : F} ( ... -- ... )
193: FDEPTH ACTUAL-FDEPTH @ = IF
194: FDEPTH START-FDEPTH @ > IF
1.10 anton 195: FDEPTH START-FDEPTH @ - 0 DO
1.1 anton 196: ACTUAL-FRESULTS I FLOATS + F@ FCONF= INVERT IF
197: S" INCORRECT FP RESULT: " ERROR LEAVE
198: THEN
199: LOOP
200: THEN
201: ELSE
202: S" WRONG NUMBER OF FP RESULTS: " ERROR
203: THEN ;
204:
205: : F...}T ( -- )
1.6 anton 206: FCURSOR @ START-FDEPTH @ + ACTUAL-FDEPTH @ <> IF
1.11 anton 207: S" NUMBER OF FLOAT RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR
1.8 anton 208: ELSE FDEPTH START-FDEPTH @ = 0= IF
209: S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR
210: THEN THEN ;
211:
1.1 anton 212:
213: : FTESTER ( R -- )
1.6 anton 214: FDEPTH 0= ACTUAL-FDEPTH @ FCURSOR @ START-FDEPTH @ + 1+ < OR IF
1.8 anton 215: S" NUMBER OF FLOAT RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR
216: ELSE ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF
1.9 anton 217: S" INCORRECT FP RESULT: " ERROR
218: THEN THEN
1.1 anton 219: 1 FCURSOR +! ;
220:
221: [ELSE]
222: : EMPTY-FSTACK ;
223: : F{ ;
224: : F-> ;
225: : F} ;
226: : F...}T ;
227:
1.12 anton 228: HAS-FLOATING [IF]
1.3 anton 229: DECIMAL
1.1 anton 230: : COMPUTE-CELLS-PER-FP ( -- U )
1.3 anton 231: DEPTH 0E DEPTH 1- >R FDROP R> SWAP - ;
232: HEX
1.1 anton 233:
234: COMPUTE-CELLS-PER-FP CONSTANT CELLS-PER-FP
1.12 anton 235:
1.1 anton 236: : FTESTER ( R -- )
1.6 anton 237: DEPTH CELLS-PER-FP < ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + CELLS-PER-FP + < OR IF
238: S" NUMBER OF RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
1.9 anton 239: ELSE ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF
1.1 anton 240: S" INCORRECT FP RESULT: " ERROR
1.9 anton 241: THEN THEN
1.1 anton 242: CELLS-PER-FP XCURSOR +! ;
1.12 anton 243: [THEN]
244: [THEN]
1.1 anton 245:
1.14 ! anton 246: : EMPTY-STACK \ ( ... -- ) empty stack; handles underflowed stack too.
1.1 anton 247: DEPTH START-DEPTH @ < IF
248: DEPTH START-DEPTH @ SWAP DO 0 LOOP
249: THEN
250: DEPTH START-DEPTH @ > IF
251: DEPTH START-DEPTH @ DO DROP LOOP
252: THEN
253: EMPTY-FSTACK ;
254:
1.14 ! anton 255: : ERROR1 \ ( C-ADDR U -- ) display an error message
! 256: \ followed by the line that had the error.
! 257: TYPE SOURCE TYPE CR \ display line corresponding to error
! 258: EMPTY-STACK \ throw away everything else
1.1 anton 259: ;
260:
261: ' ERROR1 ERROR-XT !
262:
1.14 ! anton 263: : T{ \ ( -- ) syntactic sugar.
1.3 anton 264: DEPTH START-DEPTH ! 0 XCURSOR ! F{ ;
1.1 anton 265:
1.14 ! anton 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
1.1 anton 270: THEN
271: F-> ;
272:
273: : }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
274: \ (ACTUAL) CONTENTS.
1.14 ! anton 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
1.1 anton 279: <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
280: LOOP
281: THEN
1.14 ! anton 282: ELSE \ depth mismatch
1.1 anton 283: S" WRONG NUMBER OF RESULTS: " ERROR
284: THEN
285: F} ;
286:
287: : ...}T ( -- )
1.6 anton 288: XCURSOR @ START-DEPTH @ + ACTUAL-DEPTH @ <> IF
1.7 anton 289: S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR
1.8 anton 290: ELSE DEPTH START-DEPTH @ = 0= IF
291: S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR
292: THEN THEN
1.1 anton 293: F...}T ;
294:
295: : XTESTER ( X -- )
1.6 anton 296: DEPTH 0= ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + 1+ < OR IF
297: S" NUMBER OF CELL RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
1.8 anton 298: ELSE ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF
1.9 anton 299: S" INCORRECT CELL RESULT: " ERROR
300: THEN THEN
1.1 anton 301: 1 XCURSOR +! ;
302:
303: : X}T XTESTER ...}T ;
1.12 anton 304: : XX}T XTESTER XTESTER ...}T ;
305: : XXX}T XTESTER XTESTER XTESTER ...}T ;
306: : XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ;
307:
308: HAS-FLOATING [IF]
1.1 anton 309: : R}T FTESTER ...}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 ;
1.12 anton 335: [THEN]
1.1 anton 336:
1.14 ! anton 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.
! 339: VARIABLE VERBOSE
! 340: FALSE VERBOSE !
! 341:
1.1 anton 342: : TESTING \ ( -- ) TALKING COMMENT.
343: SOURCE VERBOSE @
344: IF DUP >R TYPE CR R> >IN !
345: ELSE >IN ! DROP
346: THEN ;
1.4 anton 347:
1.6 anton 348: BASE !
1.14 ! anton 349: \ end of ttester.fs
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to ttester.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / test