\ From: John Hayes S1I

\ Subject: tester.fr

\ Date: Mon, 27 Nov 95 13:10:09 PST

\ john.hayes@jhuapl.edu

\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY

\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.

\ VERSION 1.1

\ jws notes: <> is a core ext word

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

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

break \ jws

;

VARIABLE ACTUAL-DEPTH \ STACK RECORD

CREATE ACTUAL-RESULTS 20 CELLS ALLOT

: { \ ( -- ) 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 ;

: } \ ( ... -- ) 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 ;