version 1.2, 2007/08/12 12:10:35
|
version 1.8, 2007/08/28 19:15:03
|
Line 1
|
Line 1
|
\ From: John Hayes S1I |
\ drop-in replacement for John Hayes' tester |
\ Subject: tester.fr |
|
\ Date: Mon, 27 Nov 95 13:10:09 PST |
|
\ revised by Anton Ertl 2007-08-12 |
|
|
|
\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY |
\ This file is in the public domain. NO WARRANTY. |
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. |
\ Note licensing for ttester.fs |
\ 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 ! |
|
|
|
: 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 |
|
; |
|
|
|
VARIABLE ACTUAL-DEPTH \ STACK RECORD |
S" ./ttester.fs" INCLUDED |
CREATE ACTUAL-RESULTS 20 CELLS ALLOT |
|
VARIABLE START-DEPTH |
|
|
|
: { \ ( -- ) SYNTACTIC SUGAR. |
: { T{ ; |
DEPTH START-DEPTH ! ; |
|
|
|
: -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. |
: } }T ; |
DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH |
|
START-DEPTH @ > IF \ IF THERE IS SOMETHING ON STACK |
|
DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM |
|
THEN ; |
|
|
|
: } \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED |
|
\ (ACTUAL) CONTENTS. |
|
DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH |
|
DEPTH START-DEPTH @ > IF \ IF THERE IS SOMETHING ON THE STACK |
|
DEPTH START-DEPTH @ 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 ; |
|
|
|
|
HEX |