\ From: John Hayes S1I
\ Subject: tester.fr
\ Date: Mon, 27 Nov 95 13:10:09 PST  

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

\ Revisions:
\ 26Apr04 * Added color-coded comments for ANSI terminals. km
\ 19Aug06 * Added #ERRORS. dnw
\ 04Sep06 * Made COMMENT ANS Forth compatible and conditional on
\           VERBOSE. dnw
\         * Changed the file name to testerplus.fs, in order not
\           to confuse any expectations about the ANS Forth
\           environment associated with the original. dnw

DECIMAL

: NORMAL-TEXT ( -- ) 27 EMIT [CHAR] [ EMIT [CHAR] 0 EMIT [CHAR] m EMIT ; 
: RED-TEXT    ( -- ) 27 EMIT [CHAR] [ EMIT ." 31m" ;
: GREEN-TEXT  ( -- ) 27 EMIT [CHAR] [ EMIT ." 32m" ;
: BLUE-TEXT   ( -- ) 27 EMIT [CHAR] [ EMIT ." 34m" ;  

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: HANDLES UNDERFLOWED STACK TOO.
   DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ;

variable #errors   0 #errors !

: ERROR		\ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
		\ THE LINE THAT HAD THE ERROR, and count the errors
   RED-TEXT
   1 #errors +!
   TYPE SOURCE TYPE CR			\ DISPLAY LINE CORRESPONDING TO ERROR
   EMPTY-STACK				\ THROW AWAY EVERY THING ELSE
   NORMAL-TEXT
;

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 ;

: COMMENT ( -- )
   BLUE-TEXT
   SOURCE >IN @ /STRING
   VERBOSE @ IF TYPE CR ELSE 2DROP THEN
   SOURCE >IN ! DROP
   NORMAL-TEXT ;