Return to tester.fs CVS log

Up to [gforth] / gforth / test

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

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
        !            10: \   added fp comparisons (note: BASE is HEX after loading this file)
        !            11: \         environmental dependency on separate fp stack
        !            12: \         the sensitivity of the fp comparison is determined by FSENSITIVITY
        !            13: \   added support for non-empty stack at the start
1.1       anton      14: HEX
                     15: 
                     16: \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
                     17: \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
                     18: VARIABLE VERBOSE
                     19:    FALSE VERBOSE !
                     20: 
1.3     ! anton      21: VARIABLE ACTUAL-DEPTH                  \ STACK RECORD
        !            22: CREATE ACTUAL-RESULTS 20 CELLS ALLOT
        !            23: VARIABLE START-DEPTH
        !            24: VARIABLE ERROR-XT
        !            25: 
        !            26: : ERROR ERROR-XT @ EXECUTE ;
        !            27: 
        !            28: : "FLOATING" S" FLOATING" ; \ ONLY COMPILED S" IN CORE
        !            29: : "FLOATING-STACK" S" FLOATING-STACK" ;
        !            30: "FLOATING" ENVIRONMENT? [IF]
        !            31:     [IF]
        !            32:         "FLOATING-STACK" ENVIRONMENT? [IF]
        !            33:             [IF]
        !            34:                 TRUE
        !            35:             [ELSE]
        !            36:                 FALSE
        !            37:             [THEN]
        !            38:         [ELSE] \ WE DON'T KNOW WHETHER THE FP STACK IS SEPARATE
        !            39:             TRUE \ SAFER CHOICE TO ASSUME IT IS
        !            40:         [THEN]  
        !            41:     [ELSE]
        !            42:         FALSE
        !            43:     [THEN]
        !            44: [ELSE]
        !            45:     FALSE
        !            46: [THEN]
        !            47: [IF] \ WE HAVE FP WORDS AND A SEPARATE FP STACK
        !            48:     FVARIABLE FSENSITIVITY -1E-12 FSENSITIVITY F!
        !            49:     VARIABLE ACTUAL-FDEPTH
        !            50:     CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT
        !            51:     VARIABLE START-FDEPTH
        !            52: 
        !            53:     : EMPTY-FSTACK ( ... -- ... )
        !            54:         FDEPTH START-FDEPTH @ < IF
        !            55:             FDEPTH START-FDEPTH @ SWAP DO 0E LOOP
        !            56:         THEN
        !            57:         FDEPTH START-FDEPTH @ > IF
        !            58:             FDEPTH START-FDEPTH @ DO FDROP LOOP
        !            59:         THEN ;
        !            60: 
        !            61:     : F{ ( -- )
        !            62:         FDEPTH START-FDEPTH ! ;
        !            63: 
        !            64:     : F-> ( ... -- ... )
        !            65:         FDEPTH DUP ACTUAL-FDEPTH !
        !            66:         START-FDEPTH @ > IF
        !            67:             FDEPTH START-FDEPTH @ DO ACTUAL-FRESULTS I FLOATS + F! LOOP
        !            68:         THEN ;
        !            69: 
        !            70:     : F} ( ... -- ... )
        !            71:         FDEPTH ACTUAL-FDEPTH @ = IF
        !            72:             FDEPTH START-FDEPTH @ > IF
        !            73:                 FDEPTH START-FDEPTH @ DO
        !            74:                     ACTUAL-FRESULTS I FLOATS + F@
        !            75:                     FSENSITIVITY F@ F~ INVERT IF
        !            76:                         S" INCORRECT RESULT: " ERROR LEAVE
        !            77:                     THEN
        !            78:                 LOOP
        !            79:             THEN
        !            80:         ELSE
        !            81:             S" WRONG NUMBER OF RESULTS: " ERROR
        !            82:         THEN ;
        !            83: [ELSE]
        !            84:     : EMPTY-FSTACK ;
        !            85:     : F{ ;
        !            86:     : F-> ;
        !            87:     : F} ;
        !            88: [THEN]    
        !            89: 
1.1       anton      90: : EMPTY-STACK  \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
1.3     ! anton      91:     DEPTH START-DEPTH @ < IF
        !            92:         DEPTH START-DEPTH @ SWAP DO 0 LOOP
        !            93:     THEN
        !            94:     DEPTH START-DEPTH @ > IF
        !            95:         DEPTH START-DEPTH @ DO DROP LOOP
        !            96:     THEN
        !            97:     EMPTY-FSTACK ;
1.1       anton      98: 
1.3     ! anton      99: : ERROR1       \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
1.1       anton     100:                \ THE LINE THAT HAD THE ERROR.
                    101:    TYPE SOURCE TYPE CR                 \ DISPLAY LINE CORRESPONDING TO ERROR
                    102:    EMPTY-STACK                         \ THROW AWAY EVERY THING ELSE
                    103: ;
                    104: 
1.3     ! anton     105: ' ERROR1 ERROR-XT !
1.1       anton     106: 
                    107: : {            \ ( -- ) SYNTACTIC SUGAR.
1.3     ! anton     108:    DEPTH START-DEPTH ! F{ ;
1.1       anton     109: 
                    110: : ->           \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
                    111:    DEPTH DUP ACTUAL-DEPTH !            \ RECORD DEPTH
1.2       anton     112:    START-DEPTH @ > IF          \ IF THERE IS SOMETHING ON STACK
                    113:        DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
1.3     ! anton     114:    THEN
        !           115:    F-> ;
1.1       anton     116: 
                    117: : }            \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
                    118:                \ (ACTUAL) CONTENTS.
                    119:    DEPTH ACTUAL-DEPTH @ = IF           \ IF DEPTHS MATCH
1.2       anton     120:       DEPTH START-DEPTH @ > IF         \ IF THERE IS SOMETHING ON THE STACK
                    121:          DEPTH START-DEPTH @ DO                \ FOR EACH STACK ITEM
1.1       anton     122:            ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED
                    123:            <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
                    124:         LOOP
                    125:       THEN
                    126:    ELSE                                        \ DEPTH MISMATCH
                    127:       S" WRONG NUMBER OF RESULTS: " ERROR
1.3     ! anton     128:    THEN
        !           129:    F} ;
1.1       anton     130: 
                    131: : TESTING      \ ( -- ) TALKING COMMENT.
                    132:    SOURCE VERBOSE @
                    133:    IF DUP >R TYPE CR R> >IN !
                    134:    ELSE >IN ! DROP
                    135:    THEN ;
                    136: