koopman@a.gp.cs.cmu.edu (Philip Koopman) (09/05/90)
I recently recieved email stating that there are some
apparent typos in my Forth Dimensions article on testing.
I don't know for sure what is going on, because I haven't
received my copy yet. But, in order to save wasted time
and energy, here is the code that I submitted with the
article back in October. When last I checked, it ran properly
(but, I don't have F-TZ readily available, so I haven't checked
it again today).
If you want to know more what it does, then you should subscribe
to Forth Dimensions! (or, like me, wait patiently for your
copy to arrive via Snail-Mail in a day or two).
Phil Koopman
--------------------cut here -----------------------------------
\ Forth testing support
\ By Philip Koopman Jr., for Harris Semiconductor
\ Derived from test code used for the RTX chip family
\ Developed on F-TZ (an F-PC and F-83 derivative) version 3.X11
VARIABLE #STACK -1 #STACK ! \ Saves number of stack elements for testing
CREATE R-SAVE 8 ALLOT \ Note: F-TZ uses 32-bit return addresses!
: GET-DEPTH ( ..stack.stuff.. - ..stack.stuff.. )
DEPTH #STACK @ - #STACK ! ;
: DS( ( - $BAD1 $BAD2 )
\ Init RS to -1 so that '--' will know it is a DS input
\ Uses hex 0BAD1 and hex 0BAD2 as sentinel values for DS
-1 #STACK ! $BAD1 $BAD2 ;
: RS( ( - $BAD3 $BAD4 )
\ Uses hex 0BAD3 and hex 0BAD4 as sentinel values for RS
DEPTH #STACK ! $BAD3 $BAD4 ;
: -- ( n1 n2 n3 .. n.n - n1 n2 n3 .. n.n sentinel )
#STACK @ 0< NOT IF ( if RS( ) GET-DEPTH THEN ;
: ?DATA ( n1 n2 -- )
= NOT ABORT" DATA STACK ERROR" ;
: ?RETURN ( n1 n2 -- )
= NOT ABORT" RETURN STACK ERROR" ;
: --- ( -)
DEPTH #STACK ! ;
: PERCOLATE ( r1 n.n .. n1 -- n.n .. n1 r1 )
#STACK @ ROLL -1 #STACK +! ;
: )RS ( r.n .. r3 r2 r.1 n1 n2 n3 .. n.n - )
GET-DEPTH #STACK @
IF BEGIN PERCOLATE ?RETURN #STACK @ 0= UNTIL THEN
$BAD4 ?RETURN $BAD3 ?RETURN -1 #STACK ! ;
: )DS ( r.n .. r3 r2 r.1 n1 n2 n3 .. n.n - )
GET-DEPTH #STACK @
IF BEGIN PERCOLATE ?DATA #STACK @ 0= UNTIL THEN
$BAD2 ?DATA $BAD1 ?DATA -1 #STACK ! ;
: REVERSE ( n.1 n.2 .. n.n n -- n.n .. n.2 n.1 )
DUP 0> IF 0 DO I ROLL LOOP ELSE DROP THEN ;
: INIT-TEST ( ..DS.stuff.. ..RS.stuff.. -- ..DS.stuff.. )
( RS: -- ..RS.stuff.. )
CR ." TEST-"
#STACK @ 0< ABORT" You must specify both DS( and RS(."
R> R-SAVE ! R> R-SAVE 2+ ! \ Save return address
#STACK @ REVERSE
BEGIN #STACK @ 0> WHILE >R -1 #STACK +! REPEAT
R-SAVE 2+ @ >R R-SAVE @ >R ; \ Restore return address
: FINISH-TEST ( ..DS.stuff.. -- ..DS.stuff.. ..reversed.RS.stuff.. )
( RS: ..RS.stuff.. -- )
R> R-SAVE ! R> R-SAVE 2+ ! \ Save return address
\ Transfer return stack contents onto data stack for later compare
0 >R
BEGIN R> R> SWAP 1+ >R DUP $BAD3 = UNTIL
R> REVERSE
R-SAVE 2+ @ >R R-SAVE @ >R \ Restore return address
." -DONE" -1 #STACK ! ;
\ TEST and DONE use F-TZ specific words to compile a short
\ definition containing the word to be tested, execute that
\ definition, then FORGET it from the dictionary.
\ This borrows a compilation idea from Rick vanNorman's RTX test code
CREATE MARKER 4 ALLOT
: TESTER ;
: TEST: ( -)
XHERE 2DUP MARKER 2! PARAGRAPH + DUP XDPSEG ! 0 XDP !
XSEG @ - ['] TESTER >BODY !
COMPILE INIT-TEST ] ;
: ;DONE
COMPILE FINISH-TEST COMPILE EXIT
STATE OFF TESTER MARKER 2@ XDP ! XDPSEG ! ;
IMMEDIATE
\ Test ROT for proper operation
DS( 1111 2222 3333 --
RS( --
TEST: ROT ;DONE
--- )RS
--- 2222 3333 1111 )DS
\ Test >R for proper operation
DS( 5555 --
RS( --
TEST: >R ;DONE
--- 5555 )RS
--- )DS
\ Any combination may go between TEST: and ;DONE
DS( 1111 2222 3333 --
RS( 7777 2222 9999 --
TEST: SWAP R> ROT >R ;DONE
--- 7777 2222 3333 )RS
--- 1111 2222 9999 )DS
\ Null test to be sure it works
DS( --
RS( --
TEST: ;DONE
--- )RS
--- )DS