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