Annotation of gforth/test/ttester.fs, revision 1.13

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

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