Annotation of gforth/test/tester.fs, revision 1.5

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
1.3       anton       8: 
                      9: \ revised by Anton Ertl 2007-08-12
1.5     ! anton      10: \ The original has two 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: \ I have revised it to address both shortcomings.  You can find the
        !            17: \ result at
        !            18: 
        !            19: \ http://www.forth200x.org/tests/tester.fs
        !            20: 
        !            21: \ It is intended to be a drop-in replacement of the original.
        !            22: 
        !            23: \ In spirit of the original, I have strived to avoid any potential
        !            24: \ non-portabilities and stayed as much within the CORE words as
        !            25: \ possible; e.g., FLOATING words are used only if the FLOATING wordset
        !            26: \ is present and the FP stack is separate.
        !            27: 
        !            28: \ There are a few things to be noted:
        !            29: 
        !            30: \ - Following the despicable practice of the original, this version sets
        !            31: \   the base to HEX for everything that gets loaded later.
        !            32: \   Floating-point input is ambiguous when the base is not decimal, so
        !            33: \   you have to set it to decimal yourself when you want to deal with
        !            34: \   decimal numbers.
        !            35: 
        !            36: \ - The separate-FP-stack code has an fvariable FSENSITIVITY that allows
        !            37: \   approximate matching of FP results (it's used as the r3 parameter of
        !            38: \   F~).  However, that's used only in the separate-fp-stack case.  With
        !            39: \   a shared-fp-stack you get exact matching in any case (actually
        !            40: \   FSENSITIVITY variable is not even defined in that case).  So if you
        !            41: \   define an FP test case and want to support shared-FP-stack systems,
        !            42: \   better do the approximate matching yourself.  E.g., instead of
        !            43: 
        !            44: \   -1e-12 fsensitivity f!
        !            45: \   { ... computation ... -> 2.345678901e }
        !            46: 
        !            47: \   write
        !            48: 
        !            49: \   { ... computation ... 2.345678901e -1e-12 f~ -> true }
1.1       anton      50: HEX
                     51: 
                     52: \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
                     53: \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
                     54: VARIABLE VERBOSE
                     55:    FALSE VERBOSE !
                     56: 
1.3       anton      57: VARIABLE ACTUAL-DEPTH                  \ STACK RECORD
                     58: CREATE ACTUAL-RESULTS 20 CELLS ALLOT
                     59: VARIABLE START-DEPTH
                     60: VARIABLE ERROR-XT
                     61: 
                     62: : ERROR ERROR-XT @ EXECUTE ;
                     63: 
                     64: : "FLOATING" S" FLOATING" ; \ ONLY COMPILED S" IN CORE
                     65: : "FLOATING-STACK" S" FLOATING-STACK" ;
                     66: "FLOATING" ENVIRONMENT? [IF]
                     67:     [IF]
                     68:         "FLOATING-STACK" ENVIRONMENT? [IF]
                     69:             [IF]
                     70:                 TRUE
                     71:             [ELSE]
                     72:                 FALSE
                     73:             [THEN]
                     74:         [ELSE] \ WE DON'T KNOW WHETHER THE FP STACK IS SEPARATE
                     75:             TRUE \ SAFER CHOICE TO ASSUME IT IS
                     76:         [THEN]  
                     77:     [ELSE]
                     78:         FALSE
                     79:     [THEN]
                     80: [ELSE]
                     81:     FALSE
                     82: [THEN]
                     83: [IF] \ WE HAVE FP WORDS AND A SEPARATE FP STACK
1.4       anton      84:     FVARIABLE FSENSITIVITY DECIMAL 0E HEX FSENSITIVITY F!
1.3       anton      85:     VARIABLE ACTUAL-FDEPTH
                     86:     CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT
                     87:     VARIABLE START-FDEPTH
                     88: 
                     89:     : EMPTY-FSTACK ( ... -- ... )
                     90:         FDEPTH START-FDEPTH @ < IF
                     91:             FDEPTH START-FDEPTH @ SWAP DO 0E LOOP
                     92:         THEN
                     93:         FDEPTH START-FDEPTH @ > IF
                     94:             FDEPTH START-FDEPTH @ DO FDROP LOOP
                     95:         THEN ;
                     96: 
                     97:     : F{ ( -- )
                     98:         FDEPTH START-FDEPTH ! ;
                     99: 
                    100:     : F-> ( ... -- ... )
                    101:         FDEPTH DUP ACTUAL-FDEPTH !
                    102:         START-FDEPTH @ > IF
                    103:             FDEPTH START-FDEPTH @ DO ACTUAL-FRESULTS I FLOATS + F! LOOP
                    104:         THEN ;
                    105: 
                    106:     : F} ( ... -- ... )
                    107:         FDEPTH ACTUAL-FDEPTH @ = IF
                    108:             FDEPTH START-FDEPTH @ > IF
                    109:                 FDEPTH START-FDEPTH @ DO
                    110:                     ACTUAL-FRESULTS I FLOATS + F@
                    111:                     FSENSITIVITY F@ F~ INVERT IF
                    112:                         S" INCORRECT RESULT: " ERROR LEAVE
                    113:                     THEN
                    114:                 LOOP
                    115:             THEN
                    116:         ELSE
                    117:             S" WRONG NUMBER OF RESULTS: " ERROR
                    118:         THEN ;
                    119: [ELSE]
                    120:     : EMPTY-FSTACK ;
                    121:     : F{ ;
                    122:     : F-> ;
                    123:     : F} ;
                    124: [THEN]    
                    125: 
1.1       anton     126: : EMPTY-STACK  \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
1.3       anton     127:     DEPTH START-DEPTH @ < IF
                    128:         DEPTH START-DEPTH @ SWAP DO 0 LOOP
                    129:     THEN
                    130:     DEPTH START-DEPTH @ > IF
                    131:         DEPTH START-DEPTH @ DO DROP LOOP
                    132:     THEN
                    133:     EMPTY-FSTACK ;
1.1       anton     134: 
1.3       anton     135: : ERROR1       \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
1.1       anton     136:                \ THE LINE THAT HAD THE ERROR.
                    137:    TYPE SOURCE TYPE CR                 \ DISPLAY LINE CORRESPONDING TO ERROR
                    138:    EMPTY-STACK                         \ THROW AWAY EVERY THING ELSE
                    139: ;
                    140: 
1.3       anton     141: ' ERROR1 ERROR-XT !
1.1       anton     142: 
                    143: : {            \ ( -- ) SYNTACTIC SUGAR.
1.3       anton     144:    DEPTH START-DEPTH ! F{ ;
1.1       anton     145: 
                    146: : ->           \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
                    147:    DEPTH DUP ACTUAL-DEPTH !            \ RECORD DEPTH
1.2       anton     148:    START-DEPTH @ > IF          \ IF THERE IS SOMETHING ON STACK
                    149:        DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
1.3       anton     150:    THEN
                    151:    F-> ;
1.1       anton     152: 
                    153: : }            \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
                    154:                \ (ACTUAL) CONTENTS.
                    155:    DEPTH ACTUAL-DEPTH @ = IF           \ IF DEPTHS MATCH
1.2       anton     156:       DEPTH START-DEPTH @ > IF         \ IF THERE IS SOMETHING ON THE STACK
                    157:          DEPTH START-DEPTH @ DO                \ FOR EACH STACK ITEM
1.1       anton     158:            ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED
                    159:            <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
                    160:         LOOP
                    161:       THEN
                    162:    ELSE                                        \ DEPTH MISMATCH
                    163:       S" WRONG NUMBER OF RESULTS: " ERROR
1.3       anton     164:    THEN
                    165:    F} ;
1.1       anton     166: 
                    167: : TESTING      \ ( -- ) TALKING COMMENT.
                    168:    SOURCE VERBOSE @
                    169:    IF DUP >R TYPE CR R> >IN !
                    170:    ELSE >IN ! DROP
                    171:    THEN ;
                    172: 

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