/tests/tester.fr
Forth | 61 lines | 49 code | 12 blank | 0 comment | 0 complexity | 4a526f82a135850359e2629a485823c7 MD5 | raw file
Possible License(s): GPL-3.0
- \ From: John Hayes S1I
- \ Subject: tester.fr
- \ Date: Mon, 27 Nov 95 13:10:09 PST
- \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
- \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
- \ VERSION 1.1
- \ 22/1/09 The words { and } have been changed to T{ and }T respectively to
- \ agree with the Forth 200X file ttester.fs. This avoids clashes with
- \ locals using { ... } and the FSL use of }
- HEX
- \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
- \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
- VARIABLE VERBOSE
- false VERBOSE !
- \ true VERBOSE !
- : EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
- DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ;
- : ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
- \ THE LINE THAT HAD THE ERROR.
- TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR
- EMPTY-STACK \ THROW AWAY EVERY THING ELSE
- \ quit \ *** Uncomment this line to QUIT on an error
- ;
- VARIABLE ACTUAL-DEPTH \ STACK RECORD
- CREATE ACTUAL-RESULTS 20 CELLS ALLOT
- : T{ \ ( -- ) SYNTACTIC SUGAR.
- ;
- : -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
- DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH
- ?DUP IF \ IF THERE IS SOMETHING ON STACK
- 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
- THEN ;
- : }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
- \ (ACTUAL) CONTENTS.
- DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH
- DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK
- 0 DO \ FOR EACH STACK ITEM
- ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED
- <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
- LOOP
- THEN
- ELSE \ DEPTH MISMATCH
- S" WRONG NUMBER OF RESULTS: " ERROR
- THEN ;
- : TESTING \ ( -- ) TALKING COMMENT.
- SOURCE VERBOSE @
- IF DUP >R TYPE CR R> >IN !
- ELSE >IN ! DROP [char] * emit
- THEN ;