1 files changed, 59 insertions, 0 deletions
diff --git a/test/tester.fr b/test/tester.fr
new file mode 100644
index 0000000000000..6e239fb049dc6
--- /dev/null
+++ b/test/tester.fr
@@ -0,0 +1,59 @@
+\ From: John Hayes S1I
+\ Subject: tester.fr
+\ Date: Mon, 27 Nov 95 13:10:09 PST  
+\ john.hayes@jhuapl.edu
+\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
+\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
+\ VERSION 1.1
+
+\ jws notes: <> is a core ext word
+
+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
+   TRUE 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 ;
+
+: 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
+   break	\ jws
+;
+
+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 ;
+