Anton,
Although the comp.lang.forth discussion has taken a different path,
here is the changes I mentioned.
DaR
diff -u ttester-HEAD.fs ttester.fs
--- ttester-HEAD.fs 2008-02-25 15:59:54.000000000 -0700
+++ ttester.fs 2008-02-25 15:55:25.000000000 -0700
@@ -67,8 +67,8 @@
VARIABLE VERBOSE
FALSE VERBOSE !
-VARIABLE ACTUAL-DEPTH \ STACK RECORD
-CREATE ACTUAL-RESULTS 20 CELLS ALLOT
+CREATE ACTUAL-RESULTS 21 CELLS ALLOT
+CREATE EXPECT-RESULTS 21 CELLS ALLOT
VARIABLE START-DEPTH
VARIABLE XCURSOR \ FOR ...}T
VARIABLE ERROR-XT
@@ -155,8 +155,8 @@
[THEN]
HAS-FLOATING-STACK [IF]
- VARIABLE ACTUAL-FDEPTH
- CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT
+ CREATE ACTUAL-FRESULTS 21 FLOATS ALLOT
+ CREATE EXPECT-FRESULTS 21 FLOATS ALLOT
VARIABLE START-FDEPTH
VARIABLE FCURSOR
@@ -168,30 +168,42 @@
FDEPTH START-FDEPTH @ DO FDROP LOOP
THEN ;
+ : SAVE-FSTACK ( ... addr -- ) \ Save stack contents (up to 20
items) at addr.
+ DUP >R FDEPTH DUP S>D D>F R> F! \ Record depth
+ DUP 0 20 WITHIN 0= ABORT" Invalid DEPTH"
+ ?DUP IF \ If something is on stack
+ 0 DO \ For each stack item
+ FLOAT+ DUP >R F! R> \ Save them
+ LOOP THEN DROP ;
+
+ : SHOW-FSTACK ( addr -- ... ) \ Display saved stack contents.
+ ." -> " DUP @ \ Get depth
+ DUP 0 20 WITHIN 0= ABORT" Invalid DEPTH"
+ ?DUP IF \ If something was on
stack
+ SWAP OVER FLOATS +
+ SWAP 0 DO \ For each stack item
+ DUP F@ F. 1 FLOATS - \ Display them
+ LOOP THEN DROP ." <- Top " CR ;
+
: F{ ( -- )
FDEPTH START-FDEPTH ! 0 FCURSOR ! ;
- : F-> ( ... -- ... )
- FDEPTH DUP ACTUAL-FDEPTH !
- START-FDEPTH @ > IF
- FDEPTH START-FDEPTH @ - 0 DO ACTUAL-FRESULTS I FLOATS +
F! LOOP
- THEN ;
+ : F-> ( ... -- ... ) ACTUAL-FRESULTS SAVE-FSTACK ;
: F} ( ... -- ... )
- FDEPTH ACTUAL-FDEPTH @ = IF
- FDEPTH START-FDEPTH @ > IF
- FDEPTH START-FDEPTH @ - 0 DO
- ACTUAL-FRESULTS I FLOATS + F@ FCONF= INVERT IF
- S" INCORRECT FP RESULT: " ERROR LEAVE
- THEN
- LOOP
- THEN
- ELSE
- S" WRONG NUMBER OF FP RESULTS: " ERROR
- THEN ;
+ EXPECT-FRESULTS FDEPTH >R SAVE-FSTACK
+ EXPECT-FRESULTS ACTUAL-FRESULTS
+ R> 0 ?DO
+ OVER I FLOATS + F@
+ OVER I FLOATS + F@ FCONF= INVERT IF \ If not the same
+ S" INCORRECT FP RESULT: " ERROR
+ ." ACTUAL: " ACTUAL-FRESULTS SHOW-FSTACK
+ ." EXPECT: " EXPECT-FRESULTS SHOW-FSTACK
+ 0 0 LEAVE
+ THEN LOOP 2DROP ;
: F...}T ( -- )
- FCURSOR @ START-FDEPTH @ + ACTUAL-FDEPTH @ <> IF
+ FCURSOR @ START-FDEPTH @ + ACTUAL-FRESULTS @ <> IF
S" NUMBER OF FLOAT RESULTS BEFORE '->' DOES NOT
MATCH ...}T SPRECIFICATION: " ERROR
ELSE FDEPTH START-FDEPTH @ = 0= IF
S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '->' DOES
NOT MATCH: " ERROR
@@ -199,9 +211,9 @@
: FTESTER ( R -- )
- FDEPTH 0= ACTUAL-FDEPTH @ FCURSOR @ START-FDEPTH @ + 1+ < OR IF
+ FDEPTH 0= ACTUAL-FRESULTS @ FCURSOR @ START-FDEPTH @ + 1+ <
OR IF
S" NUMBER OF FLOAT RESULTS AFTER '->' BELOW ...}T
SPECIFICATION: " ERROR
- ELSE ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF
+ ELSE ACTUAL-FRESULTS FCURSOR @ 1+ FLOATS + F@ FCONF= 0= IF
S" INCORRECT FP RESULT: " ERROR
THEN THEN
1 FCURSOR +! ;
@@ -221,9 +233,9 @@
COMPUTE-CELLS-PER-FP CONSTANT CELLS-PER-FP
: FTESTER ( R -- )
- DEPTH CELLS-PER-FP < ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @
+ CELLS-PER-FP + < OR IF
+ DEPTH CELLS-PER-FP < ACTUAL-RESULTS @ XCURSOR @ START-DEPTH
@ + CELLS-PER-FP + < OR IF
S" NUMBER OF RESULTS AFTER '->' BELOW ...}T
SPECIFICATION: " ERROR EXIT
- ELSE ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF
+ ELSE ACTUAL-RESULTS XCURSOR @ 1+ CELLS + F@ FCONF= 0= IF
S" INCORRECT FP RESULT: " ERROR
THEN THEN
CELLS-PER-FP XCURSOR +! ;
@@ -238,6 +250,23 @@
THEN
EMPTY-FSTACK ;
+: SAVE-STACK ( ... addr -- ) \ Save stack contents (up to 64 items)
at addr.
+ DEPTH 1- 2DUP SWAP ! \ Record depth
+ DUP 0 20 WITHIN 0= ABORT" Invalid DEPTH"
+ ?DUP IF \ If something is on stack
+ 0 DO \ For each stack item
+ CELL+ TUCK ! \ Save them
+ LOOP THEN DROP ;
+
+: SHOW-STACK ( addr -- ... ) \ Display saved stack contents.
+ ." -> " DUP @ \ Get depth
+ DUP 0 20 WITHIN 0= ABORT" Invalid DEPTH"
+ ?DUP IF \ If something was on stack
+ SWAP OVER CELLS +
+ SWAP 0 DO \ For each stack item
+ DUP ? 1 CELLS - \ Display them
+ LOOP THEN DROP ." <- Top " CR ;
+
: ERROR1 \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
\ THE LINE THAT HAD THE ERROR.
TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING
TO ERROR
@@ -250,28 +279,24 @@
DEPTH START-DEPTH ! 0 XCURSOR ! F{ ;
: -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
- DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH
- START-DEPTH @ > IF \ IF THERE IS SOMETHING ON STACK
- DEPTH START-DEPTH @ - 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \
SAVE THEM
- THEN
+ ACTUAL-RESULTS SAVE-STACK
F-> ;
: }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH
SAVED
- \ (ACTUAL) CONTENTS.
- DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH
- DEPTH START-DEPTH @ > IF \ IF THERE IS SOMETHING ON
THE STACK
- DEPTH START-DEPTH @ - 0 DO \ FOR EACH STACK ITEM
- ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED
- <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
- LOOP
- THEN
- ELSE \ DEPTH MISMATCH
- S" WRONG NUMBER OF RESULTS: " ERROR
- THEN
+ EXPECT-RESULTS DEPTH >R SAVE-STACK
+ EXPECT-RESULTS ACTUAL-RESULTS
+ R> 0 DO
+ OVER I CELLS + @
+ OVER I CELLS + @ - IF \ If not the same
+ S" INCORRECT RESULT: " ERROR
+ ." ACTUAL: " ACTUAL-RESULTS SHOW-STACK
+ ." EXPECT: " EXPECT-RESULTS SHOW-STACK
+ 0 0 LEAVE
+ THEN LOOP 2DROP
F} ;
: ...}T ( -- )
- XCURSOR @ START-DEPTH @ + ACTUAL-DEPTH @ <> IF
+ XCURSOR @ START-DEPTH @ + ACTUAL-RESULTS @ <> IF
S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T
SPECIFICATION: " ERROR
ELSE DEPTH START-DEPTH @ = 0= IF
S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT
MATCH: " ERROR
@@ -279,9 +304,9 @@
F...}T ;
: XTESTER ( X -- )
- DEPTH 0= ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + 1+ < OR IF
+ DEPTH 0= ACTUAL-RESULTS @ XCURSOR @ START-DEPTH @ + 1+ < OR IF
S" NUMBER OF CELL RESULTS AFTER '->' BELOW ...}T
SPECIFICATION: " ERROR EXIT
- ELSE ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF
+ ELSE ACTUAL-RESULTS XCURSOR @ 1+ CELLS + @ <> IF
S" INCORRECT CELL RESULT: " ERROR
THEN THEN
1 XCURSOR +! ;
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
