Return to ttester.fs CVS log | Up to [gforth] / gforth / test |

File:
[gforth] / gforth / test / ttester.fs

Revision**1.15**: download - view: text, annotated - select for diffs

*Mon Sep 21 15:17:03 2009 UTC* (9 years, 2 months ago) by *anton*

Branches: MAIN

CVS tags: HEAD

Revision

Branches: MAIN

CVS tags: HEAD

bugfix

1: \ This file contains the code for ttester, a utility for testing Forth words, 2: \ as developed by several authors (see below), together with some explanations 3: \ of its use. 4: 5: \ ttester is based on the original tester suite by Hayes: 6: \ From: John Hayes S1I 7: \ Subject: tester.fr 8: \ Date: Mon, 27 Nov 95 13:10:09 PST 9: \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY 10: \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. 11: \ VERSION 1.1 12: \ All the subsequent changes have been placed in the public domain. 13: \ The primary changes from the original are the replacement of "{" by "T{" 14: \ and "}" by "}T" (to avoid conflicts with the uses of { for locals and } 15: \ for FSL arrays), modifications so that the stack is allowed to be non-empty 16: \ before T{, and extensions for the handling of floating point tests. 17: \ Code for testing equality of floating point values comes 18: \ from ftester.fs written by David N. Williams, based on the idea of 19: \ approximate equality in Dirk Zoller's float.4th. 20: \ Further revisions were provided by Anton Ertl, including the ability 21: \ to handle either integrated or separate floating point stacks. 22: \ Revision history and possibly newer versions can be found at 23: \ http://www.complang.tuwien.ac.at/cvsweb/cgi-bin/cvsweb/gforth/test/ttester.fs 24: \ Explanatory material and minor reformatting (no code changes) by 25: \ C. G. Montgomery March 2009, with helpful comments from David Williams 26: \ and Krishna Myneni. 27: 28: \ Usage: 29: 30: \ The basic usage takes the form T{ <code> -> <expected stack> }T . 31: \ This executes <code> and compares the resulting stack contents with 32: \ the <expected stack> values, and reports any discrepancy between the 33: \ two sets of values. 34: \ For example: 35: \ T{ 1 2 3 swap -> 1 3 2 }T ok 36: \ T{ 1 2 3 swap -> 1 2 2 }T INCORRECT RESULT: T{ 1 2 3 swap -> 1 2 2 }T ok 37: \ T{ 1 2 3 swap -> 1 2 }T WRONG NUMBER OF RESULTS: T{ 1 2 3 swap -> 1 2 }T ok 38: 39: \ Floating point testing can involve further complications. The code 40: \ attempts to determine whether floating-point support is present, and 41: \ if so, whether there is a separate floating-point stack, and behave 42: \ accordingly. The CONSTANTs HAS-FLOATING and HAS-FLOATING-STACK 43: \ contain the results of its efforts, so the behavior of the code can 44: \ be modified by the user if necessary. 45: 46: \ Then there are the perennial issues of floating point value 47: \ comparisons. Exact equality is specified by SET-EXACT (the 48: \ default). If approximate equality tests are desired, execute 49: \ SET-NEAR . Then the FVARIABLEs REL-NEAR (default 1E-12) and 50: \ ABS-NEAR (default 0E) contain the values to be used in comparisons 51: \ by the (internal) word FNEARLY= . 52: 53: \ When there is not a separate floating point stack and you want to 54: \ use approximate equality for FP values, it is necessary to identify 55: \ which stack items are floating point quantities. This can be done 56: \ by replacing the closing }T with a version that specifies this, such 57: \ as RRXR}T which identifies the stack picture ( r r x r ). The code 58: \ provides such words for all combinations of R and X with up to four 59: \ stack items. They can be used with either an integrated or separate 60: \ floating point stacks. Adding more if you need them is 61: \ straightforward; see the examples in the source. Here is an example 62: \ which also illustrates controlling the precision of comparisons: 63: 64: \ SET-NEAR 65: \ 1E-6 REL-NEAR F! 66: \ T{ S" 3.14159E" >FLOAT -> -1E FACOS TRUE RX}T 67: 68: \ The word ERROR is now vectored, so that its action can be changed by 69: \ the user (for example, to add a counter for the number of errors). 70: \ The default action ERROR1 can be used as a factor in the display of 71: \ error reports. 72: 73: \ Loading ttester.fs does not change BASE. Remember that floating point input 74: \ is ambiguous if the base is not decimal. 75: 76: \ The file defines some 70 words in all, but in most cases only the 77: \ ones mentioned above will be needed for successful testing. 78: 79: BASE @ 80: HEX 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 ; \ for vectoring of error reporting 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 REL-NEAR DECIMAL 1E-12 HEX REL-NEAR F! 116: FVARIABLE ABS-NEAR DECIMAL 0E HEX ABS-NEAR F! 117: 118: \ When EXACT? is TRUE, }F uses FEXACTLY=, otherwise FNEARLY=. 119: 120: TRUE VALUE EXACT? 121: : SET-EXACT ( -- ) TRUE TO EXACT? ; 122: : SET-NEAR ( -- ) FALSE TO EXACT? ; 123: 124: DECIMAL 125: : FEXACTLY= ( F: X Y -- S: FLAG ) 126: ( 127: Leave TRUE if the two floats are identical. 128: ) 129: 0E F~ ; 130: HEX 131: 132: : FABS= ( F: X Y -- S: FLAG ) 133: ( 134: Leave TRUE if the two floats are equal within the tolerance 135: stored in ABS-NEAR. 136: ) 137: ABS-NEAR F@ F~ ; 138: 139: : FREL= ( F: X Y -- S: FLAG ) 140: ( 141: Leave TRUE if the two floats are relatively equal based on the 142: tolerance stored in ABS-NEAR. 143: ) 144: REL-NEAR F@ FNEGATE F~ ; 145: 146: : F2DUP FOVER FOVER ; 147: : F2DROP FDROP FDROP ; 148: 149: : FNEARLY= ( F: X Y -- S: FLAG ) 150: ( 151: Leave TRUE if the two floats are nearly equal. This is a 152: refinement of Dirk Zoller's FEQ to also allow X = Y, including 153: both zero, or to allow approximately equality when X and Y are too 154: small to satisfy the relative approximation mode in the F~ 155: specification. 156: ) 157: F2DUP FEXACTLY= IF F2DROP TRUE EXIT THEN 158: F2DUP FREL= IF F2DROP TRUE EXIT THEN 159: FABS= ; 160: 161: : FCONF= ( R1 R2 -- F ) 162: EXACT? IF 163: FEXACTLY= 164: ELSE 165: FNEARLY= 166: THEN ; 167: [THEN] 168: 169: HAS-FLOATING-STACK [IF] 170: VARIABLE ACTUAL-FDEPTH 171: CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT 172: VARIABLE START-FDEPTH 173: VARIABLE FCURSOR 174: 175: DECIMAL 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: HEX 184: 185: : F{ ( -- ) 186: FDEPTH START-FDEPTH ! 0 FCURSOR ! ; 187: 188: : F-> ( ... -- ... ) 189: FDEPTH DUP ACTUAL-FDEPTH ! 190: START-FDEPTH @ > IF 191: FDEPTH START-FDEPTH @ - 0 DO ACTUAL-FRESULTS I FLOATS + F! LOOP 192: THEN ; 193: 194: : F} ( ... -- ... ) 195: FDEPTH ACTUAL-FDEPTH @ = IF 196: FDEPTH START-FDEPTH @ > IF 197: FDEPTH START-FDEPTH @ - 0 DO 198: ACTUAL-FRESULTS I FLOATS + F@ FCONF= INVERT IF 199: S" INCORRECT FP RESULT: " ERROR LEAVE 200: THEN 201: LOOP 202: THEN 203: ELSE 204: S" WRONG NUMBER OF FP RESULTS: " ERROR 205: THEN ; 206: 207: : F...}T ( -- ) 208: FCURSOR @ START-FDEPTH @ + ACTUAL-FDEPTH @ <> IF 209: S" NUMBER OF FLOAT RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR 210: ELSE FDEPTH START-FDEPTH @ = 0= IF 211: S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR 212: THEN THEN ; 213: 214: 215: : FTESTER ( R -- ) 216: FDEPTH 0= ACTUAL-FDEPTH @ FCURSOR @ START-FDEPTH @ + 1+ < OR IF 217: S" NUMBER OF FLOAT RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR 218: ELSE ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF 219: S" INCORRECT FP RESULT: " ERROR 220: THEN THEN 221: 1 FCURSOR +! ; 222: 223: [ELSE] 224: : EMPTY-FSTACK ; 225: : F{ ; 226: : F-> ; 227: : F} ; 228: : F...}T ; 229: 230: HAS-FLOATING [IF] 231: DECIMAL 232: : COMPUTE-CELLS-PER-FP ( -- U ) 233: DEPTH 0E DEPTH 1- >R FDROP R> SWAP - ; 234: HEX 235: 236: COMPUTE-CELLS-PER-FP CONSTANT CELLS-PER-FP 237: 238: : FTESTER ( R -- ) 239: DEPTH CELLS-PER-FP < ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + CELLS-PER-FP + < OR IF 240: S" NUMBER OF RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT 241: ELSE ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF 242: S" INCORRECT FP RESULT: " ERROR 243: THEN THEN 244: CELLS-PER-FP XCURSOR +! ; 245: [THEN] 246: [THEN] 247: 248: : EMPTY-STACK \ ( ... -- ) empty stack; handles underflowed stack too. 249: DEPTH START-DEPTH @ < IF 250: DEPTH START-DEPTH @ SWAP DO 0 LOOP 251: THEN 252: DEPTH START-DEPTH @ > IF 253: DEPTH START-DEPTH @ DO DROP LOOP 254: THEN 255: EMPTY-FSTACK ; 256: 257: : ERROR1 \ ( C-ADDR U -- ) display an error message 258: \ followed by the line that had the error. 259: TYPE SOURCE TYPE CR \ display line corresponding to error 260: EMPTY-STACK \ throw away everything else 261: ; 262: 263: ' ERROR1 ERROR-XT ! 264: 265: : T{ \ ( -- ) syntactic sugar. 266: DEPTH START-DEPTH ! 0 XCURSOR ! F{ ; 267: 268: : -> \ ( ... -- ) record depth and contents of stack. 269: DEPTH DUP ACTUAL-DEPTH ! \ record depth 270: START-DEPTH @ > IF \ if there is something on the stack 271: DEPTH START-DEPTH @ - 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ save them 272: THEN 273: F-> ; 274: 275: : }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED 276: \ (ACTUAL) CONTENTS. 277: DEPTH ACTUAL-DEPTH @ = IF \ if depths match 278: DEPTH START-DEPTH @ > IF \ if there is something on the stack 279: DEPTH START-DEPTH @ - 0 DO \ for each stack item 280: ACTUAL-RESULTS I CELLS + @ \ compare actual with expected 281: <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN 282: LOOP 283: THEN 284: ELSE \ depth mismatch 285: S" WRONG NUMBER OF RESULTS: " ERROR 286: THEN 287: F} ; 288: 289: : ...}T ( -- ) 290: XCURSOR @ START-DEPTH @ + ACTUAL-DEPTH @ <> IF 291: S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR 292: ELSE DEPTH START-DEPTH @ = 0= IF 293: S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR 294: THEN THEN 295: F...}T ; 296: 297: : XTESTER ( X -- ) 298: DEPTH 0= ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + 1+ < OR IF 299: S" NUMBER OF CELL RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT 300: ELSE ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF 301: S" INCORRECT CELL RESULT: " ERROR 302: THEN THEN 303: 1 XCURSOR +! ; 304: 305: : X}T XTESTER ...}T ; 306: : XX}T XTESTER XTESTER ...}T ; 307: : XXX}T XTESTER XTESTER XTESTER ...}T ; 308: : XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ; 309: 310: HAS-FLOATING [IF] 311: : R}T FTESTER ...}T ; 312: : XR}T FTESTER XTESTER ...}T ; 313: : RX}T XTESTER FTESTER ...}T ; 314: : RR}T FTESTER FTESTER ...}T ; 315: : XXR}T FTESTER XTESTER XTESTER ...}T ; 316: : XRX}T XTESTER FTESTER XTESTER ...}T ; 317: : XRR}T FTESTER FTESTER XTESTER ...}T ; 318: : RXX}T XTESTER XTESTER FTESTER ...}T ; 319: : RXR}T FTESTER XTESTER FTESTER ...}T ; 320: : RRX}T XTESTER FTESTER FTESTER ...}T ; 321: : RRR}T FTESTER FTESTER FTESTER ...}T ; 322: : XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ; 323: : XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ; 324: : XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ; 325: : XRXX}T XTESTER XTESTER FTESTER XTESTER ...}T ; 326: : XRXR}T FTESTER XTESTER FTESTER XTESTER ...}T ; 327: : XRRX}T XTESTER FTESTER FTESTER XTESTER ...}T ; 328: : XRRR}T FTESTER FTESTER FTESTER XTESTER ...}T ; 329: : RXXX}T XTESTER XTESTER XTESTER FTESTER ...}T ; 330: : RXXR}T FTESTER XTESTER XTESTER FTESTER ...}T ; 331: : RXRX}T XTESTER FTESTER XTESTER FTESTER ...}T ; 332: : RXRR}T FTESTER FTESTER XTESTER FTESTER ...}T ; 333: : RRXX}T XTESTER XTESTER FTESTER FTESTER ...}T ; 334: : RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ; 335: : RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ; 336: : RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ; 337: [THEN] 338: 339: \ Set the following flag to TRUE for more verbose output; this may 340: \ allow you to tell which test caused your system to hang. 341: VARIABLE VERBOSE 342: FALSE VERBOSE ! 343: 344: : TESTING \ ( -- ) TALKING COMMENT. 345: SOURCE VERBOSE @ 346: IF DUP >R TYPE CR R> >IN ! 347: ELSE >IN ! DROP 348: THEN ; 349: 350: BASE ! 351: \ end of ttester.fs

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>