\ A test framework in standard Forth
\ Joshua Grams <josh@qualdan.com>  March 2008
\ public domain

\ Syntax:
    \ T{ test code => expected results }T
    \ T{ test code => expected results }( types )T
    \ T{ test code }( types )T

\ That last syntax is for when you want to check some property rather
\ than comparing against an expected value.

\ Built-in types:
    \ X - unspecified cell
    \ R - real number (floating-point)

\ The tolerance of floating point checks is controlled by the (positive)
\ values in RELATIVE-TOLERANCE (1E-12) and ABSOLUTE-TOLERANCE (0E).

\ To add a new type FOO, define:
    \ TEST-FOO ( -- flag ) using
        \ TESTED ( u -- false | u*x true )
        \ COMPARED ( u -- false | u*x u*x true )
        \ FTESTED ( u -- false | u*r true )
        \ FCOMPARED ( u -- false | u*r u*r true )
        \ && ( flag -- )  EXIT (returning flag) if flag is false.
    \ PRINT-FOO ( -- )
        \ DISPLAYED ( u -- false | u*x true )
        \ FDISPLAYED ( u -- false | u*r true )
\ See built-in types for a simple example.

\ Forth200x structures
: +FIELD ( n "name" -- )  CREATE OVER , +
    DOES> ( addr -- addr' )  @ + ;
: FIELD: ( "name" -- )  ALIGNED 1 CELLS +FIELD ;

\ Short-circuit logic
: && ( flag -- )
    POSTPONE DUP POSTPONE 0= POSTPONE IF
        POSTPONE EXIT
    POSTPONE THEN POSTPONE DROP ; IMMEDIATE

\ Conditional compilation
: SKIP-LINE-UNLESS 0= IF SOURCE >IN ! DROP THEN ;
:NONAME S" FLOATING" ENVIRONMENT? DUP IF DROP THEN ;
    EXECUTE CONSTANT FLOATS?
: \F FLOATS? SKIP-LINE-UNLESS ; IMMEDIATE
FALSE \F  DROP  :NONAME DEPTH >R 0E DEPTH >R FDROP R> R> = ; EXECUTE
    CONSTANT FSTACK?
: \FS FSTACK? SKIP-LINE-UNLESS ; IMMEDIATE
: !FS FLOATS? FSTACK? 0= AND SKIP-LINE-UNLESS ; IMMEDIATE

\ Configuration
32 CONSTANT MAX-DEPTH
\F FVARIABLE ABSOLUTE-TOLERANCE  0E ABSOLUTE-TOLERANCE F!
\F FVARIABLE RELATIVE-TOLERANCE  1E-12 RELATIVE-TOLERANCE F!

\ Parsing
VARIABLE BEFORE-WORD
: GET-WORD ( -- c-addr u )  >IN @ BEFORE-WORD !  BL WORD COUNT ;
: PUT-WORD-BACK BEFORE-WORD @ >IN ! ;

\ String handling
: C+! ( char c-addr -- )  DUP >R C@ + R> C! ;
: PLACE ( c-addr u c-addr2 -- )
    2DUP C!  CHAR+ SWAP CHARS MOVE ;
: +PLACE ( c-addr u c-addr2 -- )
    2DUP 2>R  COUNT CHARS + SWAP CHARS MOVE  2R> C+! ;
CREATE TMP 32 CHARS ALLOT
: PREFIX ( c-addr1 u1 c-addr2 u2 -- c-addr )  TMP PLACE TMP +PLACE TMP ;

\ Ignore data which doesn't belong to a test
VARIABLE BASE-DEPTH
: OUR-DEPTH ( -- n )  DEPTH BASE-DEPTH @ - ;
\FS VARIABLE BASE-FDEPTH
\FS : OUR-FDEPTH ( -- n )  FDEPTH BASE-FDEPTH @ - ;
: RESULTS-START-HERE
    \FS FDEPTH BASE-FDEPTH !
    DEPTH BASE-DEPTH ! ;

\ Error flag
VARIABLE ERROR
VARIABLE WANT-ERROR
: ERROR? ( -- flag )  ERROR @ WANT-ERROR @ <> ;
: ?ERROR ( flag -- )  0= ERROR @ OR ERROR ! ;

\ Simple stacks ( pointer, items; grows up; no error checking )
0
    FIELD: SP
    FIELD: HEAD
    FIELD: SAVED-SP
    0 +FIELD BOTTOM
CONSTANT /STACK
: CLEAR ( stack -- )
    DUP BOTTOM OVER SP !
    DUP BOTTOM OVER SAVED-SP !
    DUP BOTTOM SWAP HEAD ! ;
: MARK ( stack -- )  DUP SP @ SWAP SAVED-SP ! ;
: RESTORE ( stack -- )  DUP SAVED-SP @ OVER SP !  DUP BOTTOM SWAP HEAD ! ;
: #ITEMS ( stack -- +n )  DUP SP @ SWAP HEAD @ -  1 CELLS / ;
: PUSH ( x stack -- )  DUP >R SP @ !  1 CELLS R> SP +! ;
: POP ( stack -- x )  -1 CELLS OVER SP +!  SP @ @ ;
: GET ( stack -- x )  DUP >R HEAD @ @  1 CELLS R> HEAD +! ;
: ALLOT-STACK ( u -- addr )  HERE >R  CELLS /STACK + ALLOT  R> ;
: STACK ( u "name" -- )  CREATE ALLOT-STACK CLEAR ;

\ Type handling (this is up here so it can use non-multiplexed stacks)
MAX-DEPTH STACK TESTERS
MAX-DEPTH STACK PRINTERS
: FIND-METHODS ( c-addr u -- test-xt print-xt flag )
    2DUP S" TEST-" PREFIX FIND >R
    -ROT S" PRINT-" PREFIX FIND R> AND ;
: PARSE-TYPES ( "types" -- )
    TESTERS CLEAR PRINTERS CLEAR
    BEGIN GET-WORD FIND-METHODS WHILE
        PRINTERS PUSH TESTERS PUSH
    REPEAT 2DROP PUT-WORD-BACK
    TESTERS MARK PRINTERS MARK ;
: DEFAULT-TYPES ( [#floats] #cells -- )
    TESTERS CLEAR PRINTERS CLEAR
    S" X" FIND-METHODS IF ROT BEGIN DUP WHILE 1 - >R
        2DUP PRINTERS PUSH TESTERS PUSH
    R> REPEAT THEN DROP 2DROP
\FS    S" R" FIND-METHODS IF ROT BEGIN DUP WHILE 1 - >R
\FS        2DUP PRINTERS PUSH TESTERS PUSH
\FS    R> REPEAT THEN DROP 2DROP
    TESTERS MARK PRINTERS MARK ;
: CHECK-TYPES
    BEGIN TESTERS #ITEMS WHILE
        TESTERS POP EXECUTE ?ERROR
    REPEAT ;
: .RESULTS
    BEGIN PRINTERS #ITEMS WHILE
        PRINTERS GET EXECUTE
    REPEAT PRINTERS RESTORE ;

\ These don't depend on where floats are stored
\F : #FLOATS ( stack -- +n )  DUP SP @ SWAP HEAD @ -  1 FLOATS / ;
\F : FGET ( stack -- r )  DUP >R HEAD @ F@  1 FLOATS R> HEAD +! ;

\ Floats on data stack
!FS :NONAME DEPTH >R 0E DEPTH >R FDROP R> R> - ;
!FS     EXECUTE CONSTANT CELLS/FLOAT
!FS : FPUSH ( r stack -- )  CELLS/FLOAT 0 DO DUP >R PUSH R> LOOP DROP ;
!FS : FPOP ( stack -- r )  CELLS/FLOAT 0 DO DUP >R POP R> LOOP DROP ;

\ Separate float stack
\FS : FPUSH ( r stack -- )  DUP >R SP @ F!  1 FLOATS R> +! ;
\FS : FPOP ( stack -- r )  -1 FLOATS OVER SP +!  SP @ F@ ;
\FS : ALLOT-FSTACK ( u -- addr )
\FS     /STACK ALLOT FALIGN HERE /STACK - >R  FLOATS ALLOT  R> ;

\ Combine integer and float stacks into one structure.
\FS : DSTACK ( addr -- stack )  @ ;
\FS : FSTACK ( addr -- fstack )  CELL+ @ ;
\FS : CLEAR ( stack -- )  DUP DSTACK CLEAR  FSTACK CLEAR ;
\FS : MARK ( stack -- )  DUP DSTACK MARK  FSTACK MARK ;
\FS : RESTORE ( stack -- )  DUP DSTACK RESTORE  FSTACK RESTORE ;
\FS : STACK ( u "name" -- )
\FS     DUP ALLOT-STACK >R ALLOT-FSTACK >R
\FS        CREATE HERE R> R> , , CLEAR ;
\FS : #ITEMS ( stack -- +n )  DSTACK #ITEMS ;
\FS : PUSH ( x stack -- )  DSTACK PUSH ;
\FS : POP ( stack -- x )  DSTACK POP ;
\FS : GET ( stack -- x )  DSTACK GET ;
\FS : #FLOATS ( stack -- +n )  FSTACK #FLOATS ;
\FS : FPUSH ( r stack -- )  FSTACK FPUSH ;
\FS : FPOP ( stack -- r )  FSTACK FPOP ;
\FS : FGET ( stack -- r )  FSTACK FGET ;

\ Saving results
MAX-DEPTH STACK ACTUAL
MAX-DEPTH STACK EXPECTED
VARIABLE WHICH
CREATE STACKS ACTUAL , EXPECTED ,
: CURRENT ( -- addr )  WHICH @ CELLS STACKS + @ ;
: FIRST-RESULTS 0 WHICH ! ;
: NEXT-RESULTS 1 WHICH +! ;
: CLEAR-RESULTS
    ACTUAL CLEAR EXPECTED CLEAR
    FIRST-RESULTS  FALSE ERROR ! ;
: SAVE-RESULTS ( i*x -- )
    \FS OUR-FDEPTH 0 ?DO CURRENT FPUSH LOOP
    OUR-DEPTH 0 ?DO CURRENT PUSH LOOP
    CURRENT MARK  NEXT-RESULTS ;
: RESTORE-RESULTS FIRST-RESULTS  ACTUAL RESTORE EXPECTED RESTORE ;

\ Fetching results
: TESTED ( u -- false | u*x true )
    DUP ACTUAL #ITEMS > IF DROP FALSE
    ELSE 0 DO ACTUAL POP LOOP TRUE THEN ;
: COMPARED ( u -- false | u*x u*x true )
    DUP ACTUAL #ITEMS >  OVER EXPECTED #ITEMS > OR IF
        DROP FALSE
    ELSE
        DUP >R 0 DO ACTUAL POP LOOP
        R> 0 DO EXPECTED POP LOOP TRUE
    THEN ;
: DISPLAYED ( u -- false | u*x true )
    DUP CURRENT #ITEMS > IF DROP FALSE
    ELSE 0 DO CURRENT POP LOOP TRUE THEN ;
\F : FTESTED ( u -- false | u*r true )
\F    DUP ACTUAL #FLOATS > IF DROP FALSE
\F    ELSE 0 DO ACTUAL FPOP LOOP TRUE THEN ;
\F : FCOMPARED ( u -- false | u*r u*r true )
\F    DUP ACTUAL #FLOATS >  OVER EXPECTED #FLOATS > OR IF
\F        DROP FALSE
\F    ELSE
\F        DUP >R 0 DO ACTUAL FPOP LOOP
\F        R> 0 DO EXPECTED FPOP LOOP TRUE
\F    THEN ;
\F : FDISPLAYED ( u -- false | u*r true )
\F     DUP CURRENT #FLOATS > IF DROP FALSE
\F     ELSE 0 DO CURRENT FPOP LOOP TRUE THEN ;
: CHECK-RESULTS-CLEAR ( -- flag )
\FS ACTUAL #FLOATS 0= ?ERROR  EXPECTED #FLOATS 0= ?ERROR
    ACTUAL #ITEMS 0= ?ERROR EXPECTED #ITEMS 0= ?ERROR ;

\ Built-in types
: TEST-X ( -- flag )  1 COMPARED && = ;
: PRINT-X 1 DISPLAYED IF . THEN ;
\F : TEST-R ( -- flag )
\F   1 FCOMPARED && FOVER FOVER
\F   RELATIVE-TOLERANCE F@ FNEGATE F~ >R
\F   ABSOLUTE-TOLERANCE F@ F~ R> OR ;
\F : PRINT-R 1 FDISPLAYED IF F. THEN ;

\ Error display
: .EXTRA \ display extra stack items
	S" X" FIND-METHODS IF
		CURRENT #ITEMS ?DUP IF 0 DO DUP EXECUTE LOOP THEN
	THEN 2DROP
\FS	S" R" FIND-METHODS IF
\FS		CURRENT #FLOATS ?DUP IF 0 DO DUP EXECUTE LOOP THEN
\FS	THEN 2DROP
	;
: .ERROR
    S" Test Failed: " TYPE SOURCE TYPE CR
    RESTORE-RESULTS S" Received: " TYPE .RESULTS .EXTRA CR
    WANT-ERROR @ 0= IF
        NEXT-RESULTS    S" Expected: " TYPE .RESULTS .EXTRA CR
    THEN ;

: FAIL: TRUE WANT-ERROR ! ;
: T{ CLEAR-RESULTS RESULTS-START-HERE ;
: => ( i*x -- ) SAVE-RESULTS ;
: }( ( i*x -- ) SAVE-RESULTS PARSE-TYPES ;
: )T
    CHECK-TYPES CHECK-RESULTS-CLEAR
    ERROR? IF .ERROR CR THEN  FALSE WANT-ERROR ! ;
: }T ( i*x -- )
    SAVE-RESULTS  \FS ACTUAL #FLOATS
    ACTUAL #ITEMS DEFAULT-TYPES  )T ;