--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/examples_forth/tester.4	Mon Jul 23 16:07:12 2018 +0900
@@ -0,0 +1,49 @@
+\ (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 ;