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

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

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