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