1*afc2ba1dSToomas Soome\ From: John Hayes S1I 2*afc2ba1dSToomas Soome\ Subject: tester.fr 3*afc2ba1dSToomas Soome\ Date: Mon, 27 Nov 95 13:10:09 PST 4*afc2ba1dSToomas Soome\ john.hayes@jhuapl.edu 5*afc2ba1dSToomas Soome\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY 6*afc2ba1dSToomas Soome\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. 7*afc2ba1dSToomas Soome\ VERSION 1.1 8*afc2ba1dSToomas Soome 9*afc2ba1dSToomas Soome\ jws notes: <> is a core ext word 10*afc2ba1dSToomas Soome 11*afc2ba1dSToomas SoomeHEX 12*afc2ba1dSToomas Soome 13*afc2ba1dSToomas Soome\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY 14*afc2ba1dSToomas Soome\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. 15*afc2ba1dSToomas SoomeVARIABLE VERBOSE 16*afc2ba1dSToomas Soome TRUE VERBOSE ! 17*afc2ba1dSToomas Soome 18*afc2ba1dSToomas Soome: EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. 19*afc2ba1dSToomas Soome DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ; 20*afc2ba1dSToomas Soome 21*afc2ba1dSToomas Soome: ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY 22*afc2ba1dSToomas Soome \ THE LINE THAT HAD THE ERROR. 23*afc2ba1dSToomas Soome TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR 24*afc2ba1dSToomas Soome EMPTY-STACK \ THROW AWAY EVERY THING ELSE 25*afc2ba1dSToomas Soome break \ jws 26*afc2ba1dSToomas Soome; 27*afc2ba1dSToomas Soome 28*afc2ba1dSToomas SoomeVARIABLE ACTUAL-DEPTH \ STACK RECORD 29*afc2ba1dSToomas Soome 30*afc2ba1dSToomas SoomeCREATE ACTUAL-RESULTS 20 CELLS ALLOT 31*afc2ba1dSToomas Soome 32*afc2ba1dSToomas Soome: { \ ( -- ) SYNTACTIC SUGAR. 33*afc2ba1dSToomas Soome ; 34*afc2ba1dSToomas Soome 35*afc2ba1dSToomas Soome: -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. 36*afc2ba1dSToomas Soome DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH 37*afc2ba1dSToomas Soome ?DUP IF \ IF THERE IS SOMETHING ON STACK 38*afc2ba1dSToomas Soome 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM 39*afc2ba1dSToomas Soome THEN ; 40*afc2ba1dSToomas Soome 41*afc2ba1dSToomas Soome: } \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED 42*afc2ba1dSToomas Soome \ (ACTUAL) CONTENTS. 43*afc2ba1dSToomas Soome DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH 44*afc2ba1dSToomas Soome DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK 45*afc2ba1dSToomas Soome 0 DO \ FOR EACH STACK ITEM 46*afc2ba1dSToomas Soome ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED 47*afc2ba1dSToomas Soome <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN 48*afc2ba1dSToomas Soome LOOP 49*afc2ba1dSToomas Soome THEN 50*afc2ba1dSToomas Soome ELSE \ DEPTH MISMATCH 51*afc2ba1dSToomas Soome S" WRONG NUMBER OF RESULTS: " ERROR 52*afc2ba1dSToomas Soome THEN ; 53*afc2ba1dSToomas Soome 54*afc2ba1dSToomas Soome: TESTING \ ( -- ) TALKING COMMENT. 55*afc2ba1dSToomas Soome SOURCE VERBOSE @ 56*afc2ba1dSToomas Soome IF DUP >R TYPE CR R> >IN ! 57*afc2ba1dSToomas Soome ELSE >IN ! DROP 58*afc2ba1dSToomas Soome THEN ; 59