Annotation of gforth/test/ttester.fs, revision 1.3
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:
10: \ from ftester.fs written by David N. Williams, based on the
11: \ approximate equality in Dirk Zoller's float.4th
12:
13: \ This library is free software; you can redistribute it and/or
14: \ modify it under the terms of the GNU Lesser General Public
15: \ License as published by the Free Software Foundation; either
16: \ version 2.1 of the License, or at your option any later version.
17:
18: \ This library is distributed in the hope that it will be useful,
19: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
20: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21: \ Lesser General Public License for more details.
22:
23: \ You should have received a copy of the GNU Lesser General Public
24: \ License along with this library; if not, write to the Free
25: \ Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
26: \ MA 02111-1307 USA.
27:
28: \ for the rest:
1.1 anton 29: \ revised by Anton Ertl 2007-08-12, 2007-08-19
1.2 anton 30: \ public domain
31:
1.1 anton 32: \ The original has the following shortcomings:
33:
34: \ - It does not work as expected if the stack is non-empty before the {.
35:
36: \ - It does not check FP results if the system has a separate FP stack.
37:
38: \ - There is a conflict with the use of } for FSL arrays and { for locals.
39:
40: \ I have revised it to address these shortcomings. You can find the
41: \ result at
42:
43: \ http://www.forth200x.org/tests/tester.fs
44: \ http://www.forth200x.org/tests/ttester.fs
45:
46: \ tester.fs is intended to be a drop-in replacement of the original.
47: \ ttester.fs is a version that uses T{ and }T instead of { and }.
48:
49: \ In spirit of the original, I have strived to avoid any potential
50: \ non-portabilities and stayed as much within the CORE words as
51: \ possible; e.g., FLOATING words are used only if the FLOATING wordset
52: \ is present
53:
54: \ There are a few things to be noted:
55:
56: \ - Following the despicable practice of the original, this version
57: \ sets the base to HEX for everything that gets loaded later.
58: \ Floating-point input is ambiguous when the base is not decimal, so
59: \ you have to set it to decimal yourself when you want to deal with
60: \ decimal numbers.
61:
62: \ - For FP it is often useful to use approximate equality for checking
63: \ the results. You can turn on approximate matching with SET-NEAR
64: \ (and turn it off (default) with SET-EXACT, and you can tune it by
65: \ setting the variables REL-NEAR and ABS-NEAR. If you want your tests
66: \ to work with a shared stack, you have to specify the types of the
67: \ elements on the stack by using one of the closing words that specify
68: \ types, e.g. RRRX}T for checking the stack picture ( r r r x ).
69: \ There are such words for all combination of R and X with up to 4
70: \ stack items, and defining more if you need them is straightforward
71: \ (see source). If your tests are only intended for a separate-stack
72: \ system or if you need only exact matching, you can use the plain }T
73: \ instead.
74:
75: HEX
76:
77: \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
78: \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
79: VARIABLE VERBOSE
80: FALSE VERBOSE !
81:
82: VARIABLE ACTUAL-DEPTH \ STACK RECORD
83: CREATE ACTUAL-RESULTS 20 CELLS ALLOT
84: VARIABLE START-DEPTH
85: VARIABLE XCURSOR \ FOR ...}T
86: VARIABLE ERROR-XT
87:
88: : ERROR ERROR-XT @ EXECUTE ;
89:
90: : "FLOATING" S" FLOATING" ; \ ONLY COMPILED S" IN CORE
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]
107: [ELSE] \ WE DON'T KNOW WHETHER THE FP STACK IS SEPARATE
108: HAS-FLOATING \ IF WE HAVE FLOATING, WE ASSUME IT IS
109: [THEN] CONSTANT HAS-FLOATING-STACK
110:
111: HAS-FLOATING [IF]
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.
115: FVARIABLE FSENSITIVITY DECIMAL 1E-12 HEX FSENSITIVITY F!
116: : REL-NEAR FSENSITIVITY ;
117: FVARIABLE ABS-NEAR DECIMAL 0E HEX ABS-NEAR F!
118:
119: \ WHEN EXACT? IS TRUE, }F USES FEXACTLY=, OTHERWISE FNEARLY=.
120:
121: TRUE VALUE EXACT?
122: : SET-EXACT ( -- ) TRUE TO EXACT? ;
123: : SET-NEAR ( -- ) FALSE TO EXACT? ;
124:
125: DECIMAL
126: : FEXACTLY= ( F: X Y -- S: FLAG )
127: (
128: LEAVE TRUE IF THE TWO FLOATS ARE IDENTICAL.
129: )
130: 0E F~ ;
131: HEX
132:
133: : FABS= ( F: X Y -- S: FLAG )
134: (
135: LEAVE TRUE IF THE TWO FLOATS ARE EQUAL WITHIN THE TOLERANCE
136: STORED IN ABS-NEAR.
137: )
138: ABS-NEAR F@ F~ ;
139:
140: : FREL= ( F: X Y -- S: FLAG )
141: (
142: LEAVE TRUE IF THE TWO FLOATS ARE RELATIVELY EQUAL BASED ON THE
143: TOLERANCE STORED IN ABS-NEAR.
144: )
145: REL-NEAR F@ FNEGATE F~ ;
146:
147: : F2DUP FOVER FOVER ;
148: : F2DROP FDROP FDROP ;
149:
150: : FNEARLY= ( F: X Y -- S: FLAG )
151: (
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 APPROXIMATE EQUALITY WHEN X AND Y ARE TOO
155: SMALL TO SATISFY THE RELATIVE APPROXIMATION MODE IN THE F~
156: SPECIFICATION.
157: )
158: F2DUP FEXACTLY= IF F2DROP TRUE EXIT THEN
159: F2DUP FREL= IF F2DROP TRUE EXIT THEN
160: FABS= ;
161:
162: : FCONF= ( R1 R2 -- F )
163: EXACT? IF
164: FEXACTLY=
165: ELSE
166: FNEARLY=
167: THEN ;
168: [THEN]
169:
170: HAS-FLOATING-STACK [IF]
171: VARIABLE ACTUAL-FDEPTH
172: CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT
173: VARIABLE START-FDEPTH
174: VARIABLE FCURSOR
175:
176: : EMPTY-FSTACK ( ... -- ... )
177: FDEPTH START-FDEPTH @ < IF
178: FDEPTH START-FDEPTH @ SWAP DO 0E LOOP
179: THEN
180: FDEPTH START-FDEPTH @ > IF
181: FDEPTH START-FDEPTH @ DO FDROP LOOP
182: THEN ;
183:
184: : F{ ( -- )
185: FDEPTH START-FDEPTH ! 0 FCURSOR ! ;
186:
187: : F-> ( ... -- ... )
188: FDEPTH DUP ACTUAL-FDEPTH !
189: START-FDEPTH @ > IF
190: FDEPTH START-FDEPTH @ DO ACTUAL-FRESULTS I FLOATS + F! LOOP
191: THEN ;
192:
193: : F} ( ... -- ... )
194: FDEPTH ACTUAL-FDEPTH @ = IF
195: FDEPTH START-FDEPTH @ > IF
196: FDEPTH START-FDEPTH @ DO
197: ACTUAL-FRESULTS I FLOATS + F@ FCONF= INVERT IF
198: S" INCORRECT FP RESULT: " ERROR LEAVE
199: THEN
200: LOOP
201: THEN
202: ELSE
203: S" WRONG NUMBER OF FP RESULTS: " ERROR
204: THEN ;
205:
206: : F...}T ( -- )
207: FDEPTH START-FDEPTH @ = 0= IF
208: S" WRONG NUMBER OF FP RESULTS" ERROR
209: THEN
210: FCURSOR @ ACTUAL-FDEPTH @ <> IF
211: S" WRONG NUMBER OF FP RESULTS" ERROR
212: THEN ;
213:
214: : FTESTER ( R -- )
215: FDEPTH 0= ACTUAL-FDEPTH @ FCURSOR @ 1+ < OR IF
216: S" WRONG NUMBER OF FP RESULTS: " ERROR EXIT
217: THEN
218: ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF
219: S" INCORRECT FP RESULT: " ERROR
220: THEN
221: 1 FCURSOR +! ;
222:
223: [ELSE]
224: : EMPTY-FSTACK ;
225: : F{ ;
226: : F-> ;
227: : F} ;
228: : F...}T ;
229:
1.3 ! anton 230: DECIMAL
1.1 anton 231: : COMPUTE-CELLS-PER-FP ( -- U )
1.3 ! anton 232: DEPTH 0E DEPTH 1- >R FDROP R> SWAP - ;
! 233: HEX
1.1 anton 234:
235: COMPUTE-CELLS-PER-FP CONSTANT CELLS-PER-FP
236:
237: : FTESTER ( R -- )
238: DEPTH CELLS-PER-FP < ACTUAL-DEPTH @ XCURSOR @ CELLS-PER-FP + < OR IF
239: S" WRONG NUMBER OF RESULTS: " ERROR EXIT
240: THEN
241: ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF
242: S" INCORRECT FP RESULT: " ERROR
243: THEN
244: CELLS-PER-FP XCURSOR +! ;
245: [THEN]
246:
247: : EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
248: DEPTH START-DEPTH @ < IF
249: DEPTH START-DEPTH @ SWAP DO 0 LOOP
250: THEN
251: DEPTH START-DEPTH @ > IF
252: DEPTH START-DEPTH @ DO DROP LOOP
253: THEN
254: EMPTY-FSTACK ;
255:
256: : ERROR1 \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
257: \ THE LINE THAT HAD THE ERROR.
258: TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR
259: EMPTY-STACK \ THROW AWAY EVERY THING ELSE
260: ;
261:
262: ' ERROR1 ERROR-XT !
263:
264: : T{ \ ( -- ) SYNTACTIC SUGAR.
1.3 ! anton 265: DEPTH START-DEPTH ! 0 XCURSOR ! F{ ;
1.1 anton 266:
267: : -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
268: DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH
269: START-DEPTH @ > IF \ IF THERE IS SOMETHING ON STACK
270: DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
271: THEN
272: F-> ;
273:
274: : }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
275: \ (ACTUAL) CONTENTS.
276: DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH
277: DEPTH START-DEPTH @ > IF \ IF THERE IS SOMETHING ON THE STACK
278: DEPTH START-DEPTH @ DO \ FOR EACH STACK ITEM
279: ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED
280: <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
281: LOOP
282: THEN
283: ELSE \ DEPTH MISMATCH
284: S" WRONG NUMBER OF RESULTS: " ERROR
285: THEN
286: F} ;
287:
288: : ...}T ( -- )
289: DEPTH START-DEPTH @ = 0= IF
290: S" WRONG NUMBER OF RESULTS" ERROR
291: THEN
292: XCURSOR @ ACTUAL-DEPTH @ <> IF
293: S" WRONG NUMBER OF RESULTS" ERROR
294: THEN
295: F...}T ;
296:
297: : XTESTER ( X -- )
298: DEPTH 0= ACTUAL-DEPTH @ XCURSOR @ 1+ < OR IF
299: S" WRONG NUMBER OF RESULTS: " ERROR EXIT
300: THEN
301: ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF
302: S" INCORRECT CELL RESULT: " ERROR
303: THEN
304: 1 XCURSOR +! ;
305:
306: : X}T XTESTER ...}T ;
307: : R}T FTESTER ...}T ;
308: : XX}T XTESTER XTESTER ...}T ;
309: : XR}T FTESTER XTESTER ...}T ;
310: : RX}T XTESTER FTESTER ...}T ;
311: : RR}T FTESTER FTESTER ...}T ;
312: : XXX}T XTESTER XTESTER XTESTER ...}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: : XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ;
321: : XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ;
322: : XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ;
323: : XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ;
324: : XRXX}T XTESTER XTESTER FTESTER XTESTER ...}T ;
325: : XRXR}T FTESTER XTESTER FTESTER XTESTER ...}T ;
326: : XRRX}T XTESTER FTESTER FTESTER XTESTER ...}T ;
327: : XRRR}T FTESTER FTESTER FTESTER XTESTER ...}T ;
328: : RXXX}T XTESTER XTESTER XTESTER FTESTER ...}T ;
329: : RXXR}T FTESTER XTESTER XTESTER FTESTER ...}T ;
330: : RXRX}T XTESTER FTESTER XTESTER FTESTER ...}T ;
331: : RXRR}T FTESTER FTESTER XTESTER FTESTER ...}T ;
332: : RRXX}T XTESTER XTESTER FTESTER FTESTER ...}T ;
333: : RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ;
334: : RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ;
335: : RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ;
336:
337: : TESTING \ ( -- ) TALKING COMMENT.
338: SOURCE VERBOSE @
339: IF DUP >R TYPE CR R> >IN !
340: ELSE >IN ! DROP
341: THEN ;
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