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 62BASE @ 63HEX 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. 67VARIABLE VERBOSE 68 FALSE VERBOSE ! 69 70VARIABLE ACTUAL-DEPTH \ STACK RECORD 71CREATE ACTUAL-RESULTS 20 CELLS ALLOT 72VARIABLE START-DEPTH 73VARIABLE XCURSOR \ FOR ...}T 74VARIABLE 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 99HAS-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 157HAS-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 @ - 0 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 @ - 0 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 FCURSOR @ START-FDEPTH @ + ACTUAL-FDEPTH @ <> IF 195 S" NUMBER OF FLOAT RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR 196 ELSE FDEPTH START-FDEPTH @ = 0= IF 197 S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR 198 THEN THEN ; 199 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 204 ELSE ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF 205 S" INCORRECT FP RESULT: " ERROR 206 THEN THEN 207 1 FCURSOR +! ; 208 209[ELSE] 210 : EMPTY-FSTACK ; 211 : F{ ; 212 : F-> ; 213 : F} ; 214 : F...}T ; 215 216 DECIMAL 217 : COMPUTE-CELLS-PER-FP ( -- U ) 218 DEPTH 0E DEPTH 1- >R FDROP R> SWAP - ; 219 HEX 220 221 COMPUTE-CELLS-PER-FP CONSTANT CELLS-PER-FP 222 223 : FTESTER ( R -- ) 224 DEPTH CELLS-PER-FP < ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + CELLS-PER-FP + < OR IF 225 S" NUMBER OF RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT 226 ELSE ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF 227 S" INCORRECT FP RESULT: " ERROR 228 THEN THEN 229 CELLS-PER-FP XCURSOR +! ; 230 [THEN] 231 232: EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. 233 DEPTH START-DEPTH @ < IF 234 DEPTH START-DEPTH @ SWAP DO 0 LOOP 235 THEN 236 DEPTH START-DEPTH @ > IF 237 DEPTH START-DEPTH @ DO DROP LOOP 238 THEN 239 EMPTY-FSTACK ; 240 241: ERROR1 \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY 242 \ THE LINE THAT HAD THE ERROR. 243 TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR 244 EMPTY-STACK \ THROW AWAY EVERY THING ELSE 245; 246 247' ERROR1 ERROR-XT ! 248 249: T{ \ ( -- ) SYNTACTIC SUGAR. 250 DEPTH START-DEPTH ! 0 XCURSOR ! F{ ; 251 252: -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. 253 DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH 254 START-DEPTH @ > IF \ IF THERE IS SOMETHING ON STACK 255 DEPTH START-DEPTH @ - 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM 256 THEN 257 F-> ; 258 259: }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED 260 \ (ACTUAL) CONTENTS. 261 DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH 262 DEPTH START-DEPTH @ > IF \ IF THERE IS SOMETHING ON THE STACK 263 DEPTH START-DEPTH @ - 0 DO \ FOR EACH STACK ITEM 264 ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED 265 <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN 266 LOOP 267 THEN 268 ELSE \ DEPTH MISMATCH 269 S" WRONG NUMBER OF RESULTS: " ERROR 270 THEN 271 F} ; 272 273: ...}T ( -- ) 274 XCURSOR @ START-DEPTH @ + ACTUAL-DEPTH @ <> IF 275 S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR 276 ELSE DEPTH START-DEPTH @ = 0= IF 277 S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR 278 THEN THEN 279 F...}T ; 280 281: XTESTER ( X -- ) 282 DEPTH 0= ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + 1+ < OR IF 283 S" NUMBER OF CELL RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT 284 ELSE ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF 285 S" INCORRECT CELL RESULT: " ERROR 286 THEN THEN 287 1 XCURSOR +! ; 288 289: X}T XTESTER ...}T ; 290: R}T FTESTER ...}T ; 291: XX}T XTESTER XTESTER ...}T ; 292: XR}T FTESTER XTESTER ...}T ; 293: RX}T XTESTER FTESTER ...}T ; 294: RR}T FTESTER FTESTER ...}T ; 295: XXX}T XTESTER XTESTER XTESTER ...}T ; 296: XXR}T FTESTER XTESTER XTESTER ...}T ; 297: XRX}T XTESTER FTESTER XTESTER ...}T ; 298: XRR}T FTESTER FTESTER XTESTER ...}T ; 299: RXX}T XTESTER XTESTER FTESTER ...}T ; 300: RXR}T FTESTER XTESTER FTESTER ...}T ; 301: RRX}T XTESTER FTESTER FTESTER ...}T ; 302: RRR}T FTESTER FTESTER FTESTER ...}T ; 303: XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ; 304: XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ; 305: XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ; 306: XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ; 307: XRXX}T XTESTER XTESTER FTESTER XTESTER ...}T ; 308: XRXR}T FTESTER XTESTER FTESTER XTESTER ...}T ; 309: XRRX}T XTESTER FTESTER FTESTER XTESTER ...}T ; 310: XRRR}T FTESTER FTESTER FTESTER XTESTER ...}T ; 311: RXXX}T XTESTER XTESTER XTESTER FTESTER ...}T ; 312: RXXR}T FTESTER XTESTER XTESTER FTESTER ...}T ; 313: RXRX}T XTESTER FTESTER XTESTER FTESTER ...}T ; 314: RXRR}T FTESTER FTESTER XTESTER FTESTER ...}T ; 315: RRXX}T XTESTER XTESTER FTESTER FTESTER ...}T ; 316: RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ; 317: RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ; 318: RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ; 319 320: TESTING \ ( -- ) TALKING COMMENT. 321 SOURCE VERBOSE @ 322 IF DUP >R TYPE CR R> >IN ! 323 ELSE >IN ! DROP 324 THEN ; 325 326BASE ! 327