\ tester (John Hayes) \ Date: Mon, 27 Nov 95 13:10:09 PST \ with a few mods 97.8.26 NAB \ (C) 1995 Johns Hopkins \ University / Applied Physics \ Laboratory \ May be distributed freely as \ long as this copyright notice \ remains. \ Version 1.1 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 ! \ [NAB]: optionally display tests variable show-test false show-test ! \ true show-test ! \ [NAB]: count tests variable testcount 0 testcount ! : 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 ABORT ; VARIABLE ACTUAL-DEPTH \ Stack record CREATE ACTUAL-RESULTS 20 CELLS ALLOT : { \ show-test added [NAB] show-test @ if source type cr then ; : -> ( ... -- ) \ 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 ; : } 1 testcount +! \ added [NAB] \ ( ... -- ) 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 THEN ;