Annotation of gforth/test/tester.fs, revision 1.2
1.1 anton 1: \ From: John Hayes S1I
2: \ Subject: tester.fr
3: \ Date: Mon, 27 Nov 95 13:10:09 PST
1.2 ! anton 4: \ revised by Anton Ertl 2007-08-12
1.1 anton 5:
6: \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
7: \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
8: \ VERSION 1.1
9: HEX
10:
11: \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
12: \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
13: VARIABLE VERBOSE
14: FALSE VERBOSE !
15:
16: : EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
17: DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ;
18:
19: : ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
20: \ THE LINE THAT HAD THE ERROR.
21: TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR
22: EMPTY-STACK \ THROW AWAY EVERY THING ELSE
23: ;
24:
25: VARIABLE ACTUAL-DEPTH \ STACK RECORD
26: CREATE ACTUAL-RESULTS 20 CELLS ALLOT
1.2 ! anton 27: VARIABLE START-DEPTH
1.1 anton 28:
29: : { \ ( -- ) SYNTACTIC SUGAR.
1.2 ! anton 30: DEPTH START-DEPTH ! ;
1.1 anton 31:
32: : -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
33: DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH
1.2 ! anton 34: START-DEPTH @ > IF \ IF THERE IS SOMETHING ON STACK
! 35: DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
1.1 anton 36: THEN ;
37:
38: : } \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
39: \ (ACTUAL) CONTENTS.
40: DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH
1.2 ! anton 41: DEPTH START-DEPTH @ > IF \ IF THERE IS SOMETHING ON THE STACK
! 42: DEPTH START-DEPTH @ DO \ FOR EACH STACK ITEM
1.1 anton 43: ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED
44: <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
45: LOOP
46: THEN
47: ELSE \ DEPTH MISMATCH
48: S" WRONG NUMBER OF RESULTS: " ERROR
49: THEN ;
50:
51: : TESTING \ ( -- ) TALKING COMMENT.
52: SOURCE VERBOSE @
53: IF DUP >R TYPE CR R> >IN !
54: ELSE >IN ! DROP
55: THEN ;
56:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>