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