Annotation of gforth/test/tester.fs, revision 1.4
1.1 anton 1: \ From: John Hayes S1I
2: \ Subject: tester.fr
3: \ Date: Mon, 27 Nov 95 13:10:09 PST
4:
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
1.3 anton 8:
9: \ revised by Anton Ertl 2007-08-12
1.4 ! anton 10: \ Added support for separate fp stack.
! 11: \ Note: BASE is HEX after loading this file)
! 12: \ The sensitivity of the fp comparison is determined by FSENSITIVITY;
! 13: \ Note that this fvariable is present and works only if the FP
! 14: \ stack is separate (default sensitivity: 0e, i.e., exact equality).
! 15: \ added support for non-empty stack at {.
1.1 anton 16: HEX
17:
18: \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
19: \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
20: VARIABLE VERBOSE
21: FALSE VERBOSE !
22:
1.3 anton 23: VARIABLE ACTUAL-DEPTH \ STACK RECORD
24: CREATE ACTUAL-RESULTS 20 CELLS ALLOT
25: VARIABLE START-DEPTH
26: VARIABLE ERROR-XT
27:
28: : ERROR ERROR-XT @ EXECUTE ;
29:
30: : "FLOATING" S" FLOATING" ; \ ONLY COMPILED S" IN CORE
31: : "FLOATING-STACK" S" FLOATING-STACK" ;
32: "FLOATING" ENVIRONMENT? [IF]
33: [IF]
34: "FLOATING-STACK" ENVIRONMENT? [IF]
35: [IF]
36: TRUE
37: [ELSE]
38: FALSE
39: [THEN]
40: [ELSE] \ WE DON'T KNOW WHETHER THE FP STACK IS SEPARATE
41: TRUE \ SAFER CHOICE TO ASSUME IT IS
42: [THEN]
43: [ELSE]
44: FALSE
45: [THEN]
46: [ELSE]
47: FALSE
48: [THEN]
49: [IF] \ WE HAVE FP WORDS AND A SEPARATE FP STACK
1.4 ! anton 50: FVARIABLE FSENSITIVITY DECIMAL 0E HEX FSENSITIVITY F!
1.3 anton 51: VARIABLE ACTUAL-FDEPTH
52: CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT
53: VARIABLE START-FDEPTH
54:
55: : EMPTY-FSTACK ( ... -- ... )
56: FDEPTH START-FDEPTH @ < IF
57: FDEPTH START-FDEPTH @ SWAP DO 0E LOOP
58: THEN
59: FDEPTH START-FDEPTH @ > IF
60: FDEPTH START-FDEPTH @ DO FDROP LOOP
61: THEN ;
62:
63: : F{ ( -- )
64: FDEPTH START-FDEPTH ! ;
65:
66: : F-> ( ... -- ... )
67: FDEPTH DUP ACTUAL-FDEPTH !
68: START-FDEPTH @ > IF
69: FDEPTH START-FDEPTH @ DO ACTUAL-FRESULTS I FLOATS + F! LOOP
70: THEN ;
71:
72: : F} ( ... -- ... )
73: FDEPTH ACTUAL-FDEPTH @ = IF
74: FDEPTH START-FDEPTH @ > IF
75: FDEPTH START-FDEPTH @ DO
76: ACTUAL-FRESULTS I FLOATS + F@
77: FSENSITIVITY F@ F~ INVERT IF
78: S" INCORRECT RESULT: " ERROR LEAVE
79: THEN
80: LOOP
81: THEN
82: ELSE
83: S" WRONG NUMBER OF RESULTS: " ERROR
84: THEN ;
85: [ELSE]
86: : EMPTY-FSTACK ;
87: : F{ ;
88: : F-> ;
89: : F} ;
90: [THEN]
91:
1.1 anton 92: : EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
1.3 anton 93: DEPTH START-DEPTH @ < IF
94: DEPTH START-DEPTH @ SWAP DO 0 LOOP
95: THEN
96: DEPTH START-DEPTH @ > IF
97: DEPTH START-DEPTH @ DO DROP LOOP
98: THEN
99: EMPTY-FSTACK ;
1.1 anton 100:
1.3 anton 101: : ERROR1 \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
1.1 anton 102: \ THE LINE THAT HAD THE ERROR.
103: TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR
104: EMPTY-STACK \ THROW AWAY EVERY THING ELSE
105: ;
106:
1.3 anton 107: ' ERROR1 ERROR-XT !
1.1 anton 108:
109: : { \ ( -- ) SYNTACTIC SUGAR.
1.3 anton 110: DEPTH START-DEPTH ! F{ ;
1.1 anton 111:
112: : -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
113: DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH
1.2 anton 114: START-DEPTH @ > IF \ IF THERE IS SOMETHING ON STACK
115: DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
1.3 anton 116: THEN
117: F-> ;
1.1 anton 118:
119: : } \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
120: \ (ACTUAL) CONTENTS.
121: DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH
1.2 anton 122: DEPTH START-DEPTH @ > IF \ IF THERE IS SOMETHING ON THE STACK
123: DEPTH START-DEPTH @ DO \ FOR EACH STACK ITEM
1.1 anton 124: ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED
125: <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
126: LOOP
127: THEN
128: ELSE \ DEPTH MISMATCH
129: S" WRONG NUMBER OF RESULTS: " ERROR
1.3 anton 130: THEN
131: F} ;
1.1 anton 132:
133: : TESTING \ ( -- ) TALKING COMMENT.
134: SOURCE VERBOSE @
135: IF DUP >R TYPE CR R> >IN !
136: ELSE >IN ! DROP
137: THEN ;
138:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>