xref: /illumos-gate/usr/src/common/ficl/test/tester.fr (revision afc2ba1deb75b323afde536f2dd18bcafdaa308d)
1\ From: John Hayes S1I
2\ Subject: tester.fr
3\ Date: Mon, 27 Nov 95 13:10:09 PST
4\ john.hayes@jhuapl.edu
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
9\ jws notes: <> is a core ext word
10
11HEX
12
13\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
14\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
15VARIABLE VERBOSE
16   TRUE VERBOSE !
17
18: EMPTY-STACK	\ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
19   DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ;
20
21: ERROR		\ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
22		\ THE LINE THAT HAD THE ERROR.
23   TYPE SOURCE TYPE CR			\ DISPLAY LINE CORRESPONDING TO ERROR
24   EMPTY-STACK				\ THROW AWAY EVERY THING ELSE
25   break	\ jws
26;
27
28VARIABLE ACTUAL-DEPTH			\ STACK RECORD
29
30CREATE ACTUAL-RESULTS 20 CELLS ALLOT
31
32: {		\ ( -- ) SYNTACTIC SUGAR.
33   ;
34
35: ->		\ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
36   DEPTH DUP ACTUAL-DEPTH !		\ RECORD DEPTH
37   ?DUP IF				\ IF THERE IS SOMETHING ON STACK
38      0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
39   THEN ;
40
41: }		\ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
42		\ (ACTUAL) CONTENTS.
43   DEPTH ACTUAL-DEPTH @ = IF		\ IF DEPTHS MATCH
44      DEPTH ?DUP IF			\ IF THERE IS SOMETHING ON THE STACK
45         0 DO				\ FOR EACH STACK ITEM
46	    ACTUAL-RESULTS I CELLS + @	\ COMPARE ACTUAL WITH EXPECTED
47	    <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
48	 LOOP
49      THEN
50   ELSE					\ DEPTH MISMATCH
51      S" WRONG NUMBER OF RESULTS: " ERROR
52   THEN ;
53
54: TESTING	\ ( -- ) TALKING COMMENT.
55   SOURCE VERBOSE @
56   IF DUP >R TYPE CR R> >IN !
57   ELSE >IN ! DROP
58   THEN ;
59