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

1.1       anton       1: \ From: John Hayes S1I
                      2: \ Subject: tester.fr
                      3: \ Date: Mon, 27 Nov 95 13:10:09 PST  
1.2     ! anton       4: \ revised by Anton Ertl 2007-08-12
1.1       anton       5: 
                      6: \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
                      7: \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
                      8: \ VERSION 1.1
                      9: HEX
                     10: 
                     11: \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
                     12: \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
                     13: VARIABLE VERBOSE
                     14:    FALSE VERBOSE !
                     15: 
                     16: : EMPTY-STACK  \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
                     17:    DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ;
                     18: 
                     19: : ERROR                \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
                     20:                \ THE LINE THAT HAD THE ERROR.
                     21:    TYPE SOURCE TYPE CR                 \ DISPLAY LINE CORRESPONDING TO ERROR
                     22:    EMPTY-STACK                         \ THROW AWAY EVERY THING ELSE
                     23: ;
                     24: 
                     25: VARIABLE ACTUAL-DEPTH                  \ STACK RECORD
                     26: CREATE ACTUAL-RESULTS 20 CELLS ALLOT
1.2     ! anton      27: VARIABLE START-DEPTH
1.1       anton      28: 
                     29: : {            \ ( -- ) SYNTACTIC SUGAR.
1.2     ! anton      30:    DEPTH START-DEPTH ! ;
1.1       anton      31: 
                     32: : ->           \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
                     33:    DEPTH DUP ACTUAL-DEPTH !            \ RECORD DEPTH
1.2     ! anton      34:    START-DEPTH @ > IF          \ IF THERE IS SOMETHING ON STACK
        !            35:        DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
1.1       anton      36:    THEN ;
                     37: 
                     38: : }            \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
                     39:                \ (ACTUAL) CONTENTS.
                     40:    DEPTH ACTUAL-DEPTH @ = IF           \ IF DEPTHS MATCH
1.2     ! anton      41:       DEPTH START-DEPTH @ > IF         \ IF THERE IS SOMETHING ON THE STACK
        !            42:          DEPTH START-DEPTH @ DO                \ FOR EACH STACK ITEM
1.1       anton      43:            ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED
                     44:            <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
                     45:         LOOP
                     46:       THEN
                     47:    ELSE                                        \ DEPTH MISMATCH
                     48:       S" WRONG NUMBER OF RESULTS: " ERROR
                     49:    THEN ;
                     50: 
                     51: : TESTING      \ ( -- ) TALKING COMMENT.
                     52:    SOURCE VERBOSE @
                     53:    IF DUP >R TYPE CR R> >IN !
                     54:    ELSE >IN ! DROP
                     55:    THEN ;
                     56: 

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