mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-11-24 19:31:40 +00:00
137 lines
8.4 KiB
Forth
137 lines
8.4 KiB
Forth
|
\ *** Block No. 0 Hexblock 0
|
||
|
|
\ ANS Forth Compatibility Tester cas 25jun20
|
||
|
|
|
||
|
|
\ From: John Hayes S1I
|
||
|
|
\ Subject: tester.fr
|
||
|
|
\ Date: Mon, 27 Nov 95 13:10:09 PST
|
||
|
|
|
||
|
|
\ (C)1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
|
||
|
|
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE
|
||
|
|
\ REMAINS.
|
||
|
|
\ VERSION 1.2
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 1 Hexblock 1
|
||
|
|
\ ANS Forth Compatibility Tester cas 25jun20
|
||
|
|
|
||
|
|
: \vf [compile] \ ; immediate
|
||
|
|
|
||
|
|
1 5 +thru .( ANS Forth Tester Loaded ... )
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 2 Hexblock 2
|
||
|
|
\ Test Unit Tools cas 25jun20
|
||
|
|
|
||
|
|
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: HANDLES UNDERFLOWED STACK TOO.
|
||
|
|
: EMPTY-STACK
|
||
|
|
DEPTH ?DUP IF DUP 0< IF
|
||
|
|
NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN
|
||
|
|
THEN ;
|
||
|
|
|
||
|
|
\ *** Block No. 3 Hexblock 3
|
||
|
|
\ Unit Test Tools cas 25jun20
|
||
|
|
|
||
|
|
VARIABLE #ERRORS 0 #ERRORS !
|
||
|
|
|
||
|
|
\ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
|
||
|
|
\ THE LINE THAT HAD THE ERROR.
|
||
|
|
|
||
|
|
: ERROR
|
||
|
|
CR TYPE SOURCE TYPE \ DISPLAY LINE CORRESPONDING TO ERROR
|
||
|
|
EMPTY-STACK \ THROW AWAY EVERY THING ELSE
|
||
|
|
#ERRORS @ 1 + #ERRORS !
|
||
|
|
\ QUIT \ *** Uncomment this line to QUIT on an error
|
||
|
|
;
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 4 Hexblock 4
|
||
|
|
\ Unit Test Tools cas 25jun20
|
||
|
|
|
||
|
|
VARIABLE ACTUAL-DEPTH \ STACK RECORD
|
||
|
|
CREATE ACTUAL-RESULTS 20 CELLS ALLOT
|
||
|
|
|
||
|
|
: T{ \ ( -- ) 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 ;
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 5 Hexblock 5
|
||
|
|
\ Unit Test Tools cas 25jun20
|
||
|
|
|
||
|
|
\ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
|
||
|
|
\ (ACTUAL) CONTENTS.
|
||
|
|
: }T
|
||
|
|
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
|
||
|
|
= 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN
|
||
|
|
LOOP
|
||
|
|
THEN
|
||
|
|
ELSE \ DEPTH MISMATCH
|
||
|
|
S" WRONG NUMBER OF RESULTS: " ERROR
|
||
|
|
THEN ;
|
||
|
|
\ *** Block No. 6 Hexblock 6
|
||
|
|
\ Unit Test Tools cas 25jun20
|
||
|
|
|
||
|
|
: TESTING \ ( -- ) TALKING COMMENT.
|
||
|
|
SOURCE VERBOSE @
|
||
|
|
IF DUP >R TYPE CR R> >IN !
|
||
|
|
ELSE >IN ! DROP [CHAR] * EMIT
|
||
|
|
THEN ;
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 7 Hexblock 7
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|