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