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

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

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