V25 with 64-bit support

[pforth] / fth / tester.fth

\ From: John Hayes S1I\r
\ Subject: tester.fr\r
\ Date: Mon, 27 Nov 95 13:10:09 PST  \r
\r
\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY\r
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.\r
\ VERSION 1.1\r
HEX\r
\r
\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY\r
\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.\r
VARIABLE VERBOSE\r
   FALSE VERBOSE !\r
\r
: EMPTY-STACK	\ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.\r
   DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ;\r
\r
: ERROR		\ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY\r
		\ THE LINE THAT HAD THE ERROR.\r
   TYPE SOURCE TYPE CR			\ DISPLAY LINE CORRESPONDING TO ERROR\r
   EMPTY-STACK				\ THROW AWAY EVERY THING ELSE\r
;\r
\r
VARIABLE ACTUAL-DEPTH			\ STACK RECORD\r
CREATE ACTUAL-RESULTS 20 CELLS ALLOT\r
\r
: {		\ ( -- ) SYNTACTIC SUGAR.\r
   ;\r
\r
: ->		\ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.\r
   DEPTH DUP ACTUAL-DEPTH !		\ RECORD DEPTH\r
   ?DUP IF				\ IF THERE IS SOMETHING ON STACK\r
      0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM\r
   THEN ;\r
\r
: }		\ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED\r
		\ (ACTUAL) CONTENTS.\r
   DEPTH ACTUAL-DEPTH @ = IF		\ IF DEPTHS MATCH\r
      DEPTH ?DUP IF			\ IF THERE IS SOMETHING ON THE STACK\r
         0 DO				\ FOR EACH STACK ITEM\r
	    ACTUAL-RESULTS I CELLS + @	\ COMPARE ACTUAL WITH EXPECTED\r
	    <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN\r
	 LOOP\r
      THEN\r
   ELSE					\ DEPTH MISMATCH\r
      S" WRONG NUMBER OF RESULTS: " ERROR\r
   THEN ;\r
\r
: TESTING	\ ( -- ) TALKING COMMENT.\r
   SOURCE VERBOSE @\r
   IF DUP >R TYPE CR R> >IN !\r
   ELSE >IN ! DROP\r
   THEN ;\r
\r