\ A simple test utility.
\ Syntax: T{ test code => correct results }T
\ Gives better failure messages than the Hayes tester.
\ Requires only positive numbers (0, 1, and 32) and these 25 words:
\ DUP DROP SWAP DEPTH
\ + - <
\ CELLS ALLOT @ !
\ IF THEN BEGIN UNTIL
\ : ; CREATE
\ SOURCE >IN \
\ S" TYPE . CR
\ Tests don't display anything when they succeed, so we provide a word
\ which skips and displays the source line to give an optional progress
\ indicator.
CREATE verbose 1 CELLS ALLOT 0 verbose !
: TESTING \ "..." --
SOURCE >IN ! DROP
verbose @ IF SOURCE TYPE CR THEN ;
\ Results are stored as a cell array, with the first cell holding the
\ number of values.
CREATE results 1 CELLS ALLOT
: #results results @ @ ;
: result CELLS results @ + ;
: .results \ --
DUP results ! @
DUP 0 < IF . S" results." TYPE 0 THEN
IF
S" ( " TYPE 1 BEGIN
DUP result @ .
1 + DUP #results SWAP < UNTIL DROP S" )" TYPE
THEN ;
CREATE depth0 1 CELLS ALLOT
: tdepth DEPTH depth0 @ - ;
: fix-underflow BEGIN 0 depth0 @ DEPTH < UNTIL ;
: save-results \ i*x addr --
results ! tdepth results @ !
tdepth 0 < IF fix-underflow THEN
tdepth IF BEGIN tdepth result ! tdepth 1 < UNTIL THEN ;
\ We store two sets of results: the ones we actually received, and the
\ ones we were expecting.
CREATE received 32 1 + CELLS ALLOT
CREATE expected 32 1 + CELLS ALLOT
\ When an error occurs, we show the most current line of source code and
\ the actual and expected stack results.
: test-failed \ --
S" Test Failed: " TYPE SOURCE TYPE CR
S" Received: " TYPE received .results CR
S" Expected: " TYPE expected .results CR ;
\ Given an offset, check the received value against the expected value.
\ Return a -1 offset on failure.
: check-result \ n -- n'
DUP CELLS DUP received + @ SWAP expected + @
- IF DROP 0 1 - THEN ;
\ Loop over all values (including the stack depths), making sure they
\ match the expected results.
CREATE should-fail 1 CELLS ALLOT 0 should-fail !
: FAIL 1 should-fail ! ;
: check-results \ --
expected @ 1 + \ including depths
BEGIN 1 - check-result DUP 1 < UNTIL
should-fail @ + IF test-failed THEN 0 should-fail ! ;
\ Finally we define the actual test syntax.
: T{ DEPTH depth0 ! ;
: => received save-results ;
: }T expected save-results check-results ;
\ Make sure it works:
1 2
T{ 3 4 => 3 4 }T
T{ DEPTH => 2 }T
FAIL T{ 5 6 => 5 7 }T
FAIL T{ 7 8 => 9 8 }T
FAIL T{ 10 11 => 10 11 12 }T
FAIL T{ 13 14 15 => 13 14 }T
FAIL T{ DROP => }T
FAIL T{ => DROP }T
T{ DUP => 0 }T DROP
T{ DUP => 1 }T DROP
T{ DEPTH => 0 }T