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