Return to tester.fs CVS log | Up to [gforth] / gforth / test |
jwilke's changes: Moved many files to other directories renamed many files other changes unknown to me.
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: