ref: 7d02e382d314d5bdde7978ccb7a64ea9201d03db
dir: 9ficl/test/tester.fr
\ 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 ;