Annotation of gforth/test/tester.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: HEX
        !             9: 
        !            10: \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
        !            11: \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
        !            12: VARIABLE VERBOSE
        !            13:    FALSE VERBOSE !
        !            14: 
        !            15: : EMPTY-STACK  \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
        !            16:    DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ;
        !            17: 
        !            18: : ERROR                \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
        !            19:                \ THE LINE THAT HAD THE ERROR.
        !            20:    TYPE SOURCE TYPE CR                 \ DISPLAY LINE CORRESPONDING TO ERROR
        !            21:    EMPTY-STACK                         \ THROW AWAY EVERY THING ELSE
        !            22: ;
        !            23: 
        !            24: VARIABLE ACTUAL-DEPTH                  \ STACK RECORD
        !            25: CREATE ACTUAL-RESULTS 20 CELLS ALLOT
        !            26: 
        !            27: : {            \ ( -- ) SYNTACTIC SUGAR.
        !            28:    ;
        !            29: 
        !            30: : ->           \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
        !            31:    DEPTH DUP ACTUAL-DEPTH !            \ RECORD DEPTH
        !            32:    ?DUP IF                             \ IF THERE IS SOMETHING ON STACK
        !            33:       0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
        !            34:    THEN ;
        !            35: 
        !            36: : }            \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
        !            37:                \ (ACTUAL) CONTENTS.
        !            38:    DEPTH ACTUAL-DEPTH @ = IF           \ IF DEPTHS MATCH
        !            39:       DEPTH ?DUP IF                    \ IF THERE IS SOMETHING ON THE STACK
        !            40:          0 DO                          \ FOR EACH STACK ITEM
        !            41:            ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED
        !            42:            <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
        !            43:         LOOP
        !            44:       THEN
        !            45:    ELSE                                        \ DEPTH MISMATCH
        !            46:       S" WRONG NUMBER OF RESULTS: " ERROR
        !            47:    THEN ;
        !            48: 
        !            49: : TESTING      \ ( -- ) TALKING COMMENT.
        !            50:    SOURCE VERBOSE @
        !            51:    IF DUP >R TYPE CR R> >IN !
        !            52:    ELSE >IN ! DROP
        !            53:    THEN ;
        !            54: 

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