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 2007-08-12, 2007-08-19, 2007-08-28
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: \ TESTER.FS IS INTENDED TO BE A DROP-IN REPLACEMENT OF THE ORIGINAL.
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
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: \ - LOADING TTESTER.FS DOES NOT CHANGE BASE. LOADING TESTER.FS
45: \ CHANGES BASE TO HEX (LIKE THE ORIGINAL TESTER). FLOATING-POINT
46: \ INPUT IS AMBIGUOUS WHEN THE BASE IS NOT DECIMAL, SO YOU HAVE TO SET
47: \ IT TO DECIMAL YOURSELF WHEN YOU WANT TO DEAL WITH DECIMAL NUMBERS.
48:
49: \ - FOR FP IT IS OFTEN USEFUL TO USE APPROXIMATE EQUALITY FOR CHECKING
50: \ THE RESULTS. YOU CAN TURN ON APPROXIMATE MATCHING WITH SET-NEAR
51: \ (AND TURN IT OFF (DEFAULT) WITH SET-EXACT, AND YOU CAN TUNE IT BY
52: \ SETTING THE VARIABLES REL-NEAR AND ABS-NEAR. IF YOU WANT YOUR TESTS
53: \ TO WORK WITH A SHARED STACK, YOU HAVE TO SPECIFY THE TYPES OF THE
54: \ ELEMENTS ON THE STACK BY USING ONE OF THE CLOSING WORDS THAT SPECIFY
55: \ TYPES, E.G. RRRX}T FOR CHECKING THE STACK PICTURE ( R R R X ).
56: \ THERE ARE SUCH WORDS FOR ALL COMBINATION OF R AND X WITH UP TO 4
57: \ STACK ITEMS, AND DEFINING MORE IF YOU NEED THEM IS STRAIGHTFORWARD
58: \ (SEE SOURCE). IF YOUR TESTS ARE ONLY INTENDED FOR A SEPARATE-STACK
59: \ SYSTEM OR IF YOU NEED ONLY EXACT MATCHING, YOU CAN USE THE PLAIN }T
60: \ INSTEAD.
61:
62: BASE @
63: HEX
64:
65: \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
66: \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
67: VARIABLE VERBOSE
68: FALSE VERBOSE !
69:
70: VARIABLE ACTUAL-DEPTH \ STACK RECORD
71: CREATE ACTUAL-RESULTS 20 CELLS ALLOT
72: VARIABLE START-DEPTH
73: VARIABLE XCURSOR \ FOR ...}T
74: VARIABLE ERROR-XT
75:
76: : ERROR ERROR-XT @ EXECUTE ;
77:
78: : "FLOATING" S" FLOATING" ; \ ONLY COMPILED S" IN CORE
79: : "FLOATING-STACK" S" FLOATING-STACK" ;
80: "FLOATING" ENVIRONMENT? [IF]
81: [IF]
82: TRUE
83: [ELSE]
84: FALSE
85: [THEN]
86: [ELSE]
87: FALSE
88: [THEN] CONSTANT HAS-FLOATING
89: "FLOATING-STACK" ENVIRONMENT? [IF]
90: [IF]
91: TRUE
92: [ELSE]
93: FALSE
94: [THEN]
95: [ELSE] \ WE DON'T KNOW WHETHER THE FP STACK IS SEPARATE
96: HAS-FLOATING \ IF WE HAVE FLOATING, WE ASSUME IT IS
97: [THEN] CONSTANT HAS-FLOATING-STACK
98:
99: HAS-FLOATING [IF]
100: \ SET THE FOLLOWING TO THE RELATIVE AND ABSOLUTE TOLERANCES YOU
101: \ WANT FOR APPROXIMATE FLOAT EQUALITY, TO BE USED WITH F~ IN
102: \ FNEARLY=. KEEP THE SIGNS, BECAUSE F~ NEEDS THEM.
103: FVARIABLE REL-NEAR DECIMAL 1E-12 HEX REL-NEAR F!
104: FVARIABLE ABS-NEAR DECIMAL 0E HEX ABS-NEAR F!
105:
106: \ WHEN EXACT? IS TRUE, }F USES FEXACTLY=, OTHERWISE FNEARLY=.
107:
108: TRUE VALUE EXACT?
109: : SET-EXACT ( -- ) TRUE TO EXACT? ;
110: : SET-NEAR ( -- ) FALSE TO EXACT? ;
111:
112: DECIMAL
113: : FEXACTLY= ( F: X Y -- S: FLAG )
114: (
115: LEAVE TRUE IF THE TWO FLOATS ARE IDENTICAL.
116: )
117: 0E F~ ;
118: HEX
119:
120: : FABS= ( F: X Y -- S: FLAG )
121: (
122: LEAVE TRUE IF THE TWO FLOATS ARE EQUAL WITHIN THE TOLERANCE
123: STORED IN ABS-NEAR.
124: )
125: ABS-NEAR F@ F~ ;
126:
127: : FREL= ( F: X Y -- S: FLAG )
128: (
129: LEAVE TRUE IF THE TWO FLOATS ARE RELATIVELY EQUAL BASED ON THE
130: TOLERANCE STORED IN ABS-NEAR.
131: )
132: REL-NEAR F@ FNEGATE F~ ;
133:
134: : F2DUP FOVER FOVER ;
135: : F2DROP FDROP FDROP ;
136:
137: : FNEARLY= ( F: X Y -- S: FLAG )
138: (
139: LEAVE TRUE IF THE TWO FLOATS ARE NEARLY EQUAL. THIS IS A
140: REFINEMENT OF DIRK ZOLLER'S FEQ TO ALSO ALLOW X = Y, INCLUDING
141: BOTH ZERO, OR TO ALLOW APPROXIMATE EQUALITY WHEN X AND Y ARE TOO
142: SMALL TO SATISFY THE RELATIVE APPROXIMATION MODE IN THE F~
143: SPECIFICATION.
144: )
145: F2DUP FEXACTLY= IF F2DROP TRUE EXIT THEN
146: F2DUP FREL= IF F2DROP TRUE EXIT THEN
147: FABS= ;
148:
149: : FCONF= ( R1 R2 -- F )
150: EXACT? IF
151: FEXACTLY=
152: ELSE
153: FNEARLY=
154: THEN ;
155: [THEN]
156:
157: HAS-FLOATING-STACK [IF]
158: VARIABLE ACTUAL-FDEPTH
159: CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT
160: VARIABLE START-FDEPTH
161: VARIABLE FCURSOR
162:
163: : EMPTY-FSTACK ( ... -- ... )
164: FDEPTH START-FDEPTH @ < IF
165: FDEPTH START-FDEPTH @ SWAP DO 0E LOOP
166: THEN
167: FDEPTH START-FDEPTH @ > IF
168: FDEPTH START-FDEPTH @ DO FDROP LOOP
169: THEN ;
170:
171: : F{ ( -- )
172: FDEPTH START-FDEPTH ! 0 FCURSOR ! ;
173:
174: : F-> ( ... -- ... )
175: FDEPTH DUP ACTUAL-FDEPTH !
176: START-FDEPTH @ > IF
177: FDEPTH START-FDEPTH @ DO ACTUAL-FRESULTS I FLOATS + F! LOOP
178: THEN ;
179:
180: : F} ( ... -- ... )
181: FDEPTH ACTUAL-FDEPTH @ = IF
182: FDEPTH START-FDEPTH @ > IF
183: FDEPTH START-FDEPTH @ DO
184: ACTUAL-FRESULTS I FLOATS + F@ FCONF= INVERT IF
185: S" INCORRECT FP RESULT: " ERROR LEAVE
186: THEN
187: LOOP
188: THEN
189: ELSE
190: S" WRONG NUMBER OF FP RESULTS: " ERROR
191: THEN ;
192:
193: : F...}T ( -- )
194: FDEPTH START-FDEPTH @ = 0= IF
195: S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR
196: THEN
197: FCURSOR @ START-FDEPTH @ + ACTUAL-FDEPTH @ <> IF
198: S" NUMBER OF FLOAT RESULTS BEFORE '->' DOES NOT MATCH ...}T SPRECIFICATION: " ERROR
199: THEN ;
200:
201: : FTESTER ( R -- )
202: FDEPTH 0= ACTUAL-FDEPTH @ FCURSOR @ START-FDEPTH @ + 1+ < OR IF
203: S" NUMBER OF FLOAT RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
204: THEN
205: ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF
206: S" INCORRECT FP RESULT: " ERROR
207: THEN
208: 1 FCURSOR +! ;
209:
210: [ELSE]
211: : EMPTY-FSTACK ;
212: : F{ ;
213: : F-> ;
214: : F} ;
215: : F...}T ;
216:
217: DECIMAL
218: : COMPUTE-CELLS-PER-FP ( -- U )
219: DEPTH 0E DEPTH 1- >R FDROP R> SWAP - ;
220: HEX
221:
222: COMPUTE-CELLS-PER-FP CONSTANT CELLS-PER-FP
223:
224: : FTESTER ( R -- )
225: DEPTH CELLS-PER-FP < ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + CELLS-PER-FP + < OR IF
226: S" NUMBER OF RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
227: THEN
228: ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF
229: S" INCORRECT FP RESULT: " ERROR
230: THEN
231: CELLS-PER-FP XCURSOR +! ;
232: [THEN]
233:
234: : EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
235: DEPTH START-DEPTH @ < IF
236: DEPTH START-DEPTH @ SWAP DO 0 LOOP
237: THEN
238: DEPTH START-DEPTH @ > IF
239: DEPTH START-DEPTH @ DO DROP LOOP
240: THEN
241: EMPTY-FSTACK ;
242:
243: : ERROR1 \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
244: \ THE LINE THAT HAD THE ERROR.
245: TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR
246: EMPTY-STACK \ THROW AWAY EVERY THING ELSE
247: ;
248:
249: ' ERROR1 ERROR-XT !
250:
251: : T{ \ ( -- ) SYNTACTIC SUGAR.
252: DEPTH START-DEPTH ! 0 XCURSOR ! F{ ;
253:
254: : -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
255: DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH
256: START-DEPTH @ > IF \ IF THERE IS SOMETHING ON STACK
257: DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
258: THEN
259: F-> ;
260:
261: : }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
262: \ (ACTUAL) CONTENTS.
263: DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH
264: DEPTH START-DEPTH @ > IF \ IF THERE IS SOMETHING ON THE STACK
265: DEPTH START-DEPTH @ DO \ FOR EACH STACK ITEM
266: ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED
267: <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
268: LOOP
269: THEN
270: ELSE \ DEPTH MISMATCH
271: S" WRONG NUMBER OF RESULTS: " ERROR
272: THEN
273: F} ;
274:
275: : ...}T ( -- )
276: DEPTH START-DEPTH @ = 0= IF
277: S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR
278: THEN
279: XCURSOR @ START-DEPTH @ + ACTUAL-DEPTH @ <> IF
280: S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T SPRECIFICATION: " ERROR
281: THEN
282: F...}T ;
283:
284: : XTESTER ( X -- )
285: DEPTH 0= ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + 1+ < OR IF
286: S" NUMBER OF CELL RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
287: THEN
288: ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF
289: S" INCORRECT CELL RESULT: " ERROR
290: THEN
291: 1 XCURSOR +! ;
292:
293: : X}T XTESTER ...}T ;
294: : R}T FTESTER ...}T ;
295: : XX}T XTESTER XTESTER ...}T ;
296: : XR}T FTESTER XTESTER ...}T ;
297: : RX}T XTESTER FTESTER ...}T ;
298: : RR}T FTESTER FTESTER ...}T ;
299: : XXX}T XTESTER XTESTER XTESTER ...}T ;
300: : XXR}T FTESTER XTESTER XTESTER ...}T ;
301: : XRX}T XTESTER FTESTER XTESTER ...}T ;
302: : XRR}T FTESTER FTESTER XTESTER ...}T ;
303: : RXX}T XTESTER XTESTER FTESTER ...}T ;
304: : RXR}T FTESTER XTESTER FTESTER ...}T ;
305: : RRX}T XTESTER FTESTER FTESTER ...}T ;
306: : RRR}T FTESTER FTESTER FTESTER ...}T ;
307: : XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ;
308: : XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ;
309: : XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ;
310: : XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ;
311: : XRXX}T XTESTER XTESTER FTESTER XTESTER ...}T ;
312: : XRXR}T FTESTER XTESTER FTESTER XTESTER ...}T ;
313: : XRRX}T XTESTER FTESTER FTESTER XTESTER ...}T ;
314: : XRRR}T FTESTER FTESTER FTESTER XTESTER ...}T ;
315: : RXXX}T XTESTER XTESTER XTESTER FTESTER ...}T ;
316: : RXXR}T FTESTER XTESTER XTESTER FTESTER ...}T ;
317: : RXRX}T XTESTER FTESTER XTESTER FTESTER ...}T ;
318: : RXRR}T FTESTER FTESTER XTESTER FTESTER ...}T ;
319: : RRXX}T XTESTER XTESTER FTESTER FTESTER ...}T ;
320: : RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ;
321: : RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ;
322: : RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ;
323:
324: : TESTING \ ( -- ) TALKING COMMENT.
325: SOURCE VERBOSE @
326: IF DUP >R TYPE CR R> >IN !
327: ELSE >IN ! DROP
328: THEN ;
329:
330: 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