Annotation of gforth/test/tester.fs, revision 1.5
1.1 anton 1: \ From: John Hayes S1I
2: \ Subject: tester.fr
3: \ Date: Mon, 27 Nov 95 13:10:09 PST
4:
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
1.3 anton 8:
9: \ revised by Anton Ertl 2007-08-12
1.5 ! anton 10: \ The original has two shortcomings:
! 11:
! 12: \ - It does not work as expected if the stack is non-empty before the {.
! 13:
! 14: \ - It does not check FP results if the system has a separate FP stack.
! 15:
! 16: \ I have revised it to address both shortcomings. You can find the
! 17: \ result at
! 18:
! 19: \ http://www.forth200x.org/tests/tester.fs
! 20:
! 21: \ It is intended to be a drop-in replacement of the original.
! 22:
! 23: \ In spirit of the original, I have strived to avoid any potential
! 24: \ non-portabilities and stayed as much within the CORE words as
! 25: \ possible; e.g., FLOATING words are used only if the FLOATING wordset
! 26: \ is present and the FP stack is separate.
! 27:
! 28: \ There are a few things to be noted:
! 29:
! 30: \ - Following the despicable practice of the original, this version sets
! 31: \ the base to HEX for everything that gets loaded later.
! 32: \ Floating-point input is ambiguous when the base is not decimal, so
! 33: \ you have to set it to decimal yourself when you want to deal with
! 34: \ decimal numbers.
! 35:
! 36: \ - The separate-FP-stack code has an fvariable FSENSITIVITY that allows
! 37: \ approximate matching of FP results (it's used as the r3 parameter of
! 38: \ F~). However, that's used only in the separate-fp-stack case. With
! 39: \ a shared-fp-stack you get exact matching in any case (actually
! 40: \ FSENSITIVITY variable is not even defined in that case). So if you
! 41: \ define an FP test case and want to support shared-FP-stack systems,
! 42: \ better do the approximate matching yourself. E.g., instead of
! 43:
! 44: \ -1e-12 fsensitivity f!
! 45: \ { ... computation ... -> 2.345678901e }
! 46:
! 47: \ write
! 48:
! 49: \ { ... computation ... 2.345678901e -1e-12 f~ -> true }
1.1 anton 50: HEX
51:
52: \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
53: \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
54: VARIABLE VERBOSE
55: FALSE VERBOSE !
56:
1.3 anton 57: VARIABLE ACTUAL-DEPTH \ STACK RECORD
58: CREATE ACTUAL-RESULTS 20 CELLS ALLOT
59: VARIABLE START-DEPTH
60: VARIABLE ERROR-XT
61:
62: : ERROR ERROR-XT @ EXECUTE ;
63:
64: : "FLOATING" S" FLOATING" ; \ ONLY COMPILED S" IN CORE
65: : "FLOATING-STACK" S" FLOATING-STACK" ;
66: "FLOATING" ENVIRONMENT? [IF]
67: [IF]
68: "FLOATING-STACK" ENVIRONMENT? [IF]
69: [IF]
70: TRUE
71: [ELSE]
72: FALSE
73: [THEN]
74: [ELSE] \ WE DON'T KNOW WHETHER THE FP STACK IS SEPARATE
75: TRUE \ SAFER CHOICE TO ASSUME IT IS
76: [THEN]
77: [ELSE]
78: FALSE
79: [THEN]
80: [ELSE]
81: FALSE
82: [THEN]
83: [IF] \ WE HAVE FP WORDS AND A SEPARATE FP STACK
1.4 anton 84: FVARIABLE FSENSITIVITY DECIMAL 0E HEX FSENSITIVITY F!
1.3 anton 85: VARIABLE ACTUAL-FDEPTH
86: CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT
87: VARIABLE START-FDEPTH
88:
89: : EMPTY-FSTACK ( ... -- ... )
90: FDEPTH START-FDEPTH @ < IF
91: FDEPTH START-FDEPTH @ SWAP DO 0E LOOP
92: THEN
93: FDEPTH START-FDEPTH @ > IF
94: FDEPTH START-FDEPTH @ DO FDROP LOOP
95: THEN ;
96:
97: : F{ ( -- )
98: FDEPTH START-FDEPTH ! ;
99:
100: : F-> ( ... -- ... )
101: FDEPTH DUP ACTUAL-FDEPTH !
102: START-FDEPTH @ > IF
103: FDEPTH START-FDEPTH @ DO ACTUAL-FRESULTS I FLOATS + F! LOOP
104: THEN ;
105:
106: : F} ( ... -- ... )
107: FDEPTH ACTUAL-FDEPTH @ = IF
108: FDEPTH START-FDEPTH @ > IF
109: FDEPTH START-FDEPTH @ DO
110: ACTUAL-FRESULTS I FLOATS + F@
111: FSENSITIVITY F@ F~ INVERT IF
112: S" INCORRECT RESULT: " ERROR LEAVE
113: THEN
114: LOOP
115: THEN
116: ELSE
117: S" WRONG NUMBER OF RESULTS: " ERROR
118: THEN ;
119: [ELSE]
120: : EMPTY-FSTACK ;
121: : F{ ;
122: : F-> ;
123: : F} ;
124: [THEN]
125:
1.1 anton 126: : EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
1.3 anton 127: DEPTH START-DEPTH @ < IF
128: DEPTH START-DEPTH @ SWAP DO 0 LOOP
129: THEN
130: DEPTH START-DEPTH @ > IF
131: DEPTH START-DEPTH @ DO DROP LOOP
132: THEN
133: EMPTY-FSTACK ;
1.1 anton 134:
1.3 anton 135: : ERROR1 \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
1.1 anton 136: \ THE LINE THAT HAD THE ERROR.
137: TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR
138: EMPTY-STACK \ THROW AWAY EVERY THING ELSE
139: ;
140:
1.3 anton 141: ' ERROR1 ERROR-XT !
1.1 anton 142:
143: : { \ ( -- ) SYNTACTIC SUGAR.
1.3 anton 144: DEPTH START-DEPTH ! F{ ;
1.1 anton 145:
146: : -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
147: DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH
1.2 anton 148: START-DEPTH @ > IF \ IF THERE IS SOMETHING ON STACK
149: DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
1.3 anton 150: THEN
151: F-> ;
1.1 anton 152:
153: : } \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
154: \ (ACTUAL) CONTENTS.
155: DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH
1.2 anton 156: DEPTH START-DEPTH @ > IF \ IF THERE IS SOMETHING ON THE STACK
157: DEPTH START-DEPTH @ DO \ FOR EACH STACK ITEM
1.1 anton 158: ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED
159: <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
160: LOOP
161: THEN
162: ELSE \ DEPTH MISMATCH
163: S" WRONG NUMBER OF RESULTS: " ERROR
1.3 anton 164: THEN
165: F} ;
1.1 anton 166:
167: : TESTING \ ( -- ) TALKING COMMENT.
168: SOURCE VERBOSE @
169: IF DUP >R TYPE CR R> >IN !
170: ELSE >IN ! DROP
171: THEN ;
172:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>