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