tester.4th

\ (C) 1993 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
\ VERSION 1.0
HEX

\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
VARIABLE VERBOSE
    FALSE VERBOSE !

: EMPTY-STACK   \ ( ... -- ) EMPTY STACK.
   DEPTH ?DUP IF 0 DO DROP LOOP THEN ;

: ERROR         \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
                \ THE LINE THAT HAD THE ERROR.
   TYPE SOURCE TYPE CR                  \ DISPLAY LINE CORRESPONDING TO ERROR
   EMPTY-STACK                          \ THROW AWAY EVERY THING ELSE
;

VARIABLE ACTUAL-DEPTH                   \ STACK RECORD
CREATE ACTUAL-RESULTS 20 CELLS ALLOT

: {             \ ( -- ) SYNTACTIC SUGAR.
   ;

: ->            \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
   DEPTH DUP ACTUAL-DEPTH !             \ RECORD DEPTH
   ?DUP IF                              \ IF THERE IS SOMETHING ON STACK
      0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
   THEN ;

: }             \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
                \ (ACTUAL) CONTENTS.
   DEPTH ACTUAL-DEPTH @ = IF            \ IF DEPTHS MATCH
      DEPTH ?DUP IF                     \ IF THERE IS SOMETHING ON THE STACK
         0 DO                           \ FOR EACH STACK ITEM
            ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED
            <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
         LOOP
      THEN
   ELSE                                 \ DEPTH MISMATCH
      S" WRONG NUMBER OF RESULTS: " ERROR
   THEN ;

: TESTING       \ ( -- ) TALKING COMMENT.
   SOURCE VERBOSE @
   IF DUP >R TYPE CR R> >IN !
   ELSE >IN ! DROP
   THEN ;