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>