I finally got around to doing more work on my new tester. It took
me a couple of major refactorings, but I have the whole thing
working properly now. I have tested all the corner cases I can
think of, both under gforth (separate floating point stack) and
PFE (no floats, floats on data stack). I can think of more
functionality which might be worth adding, but the basics are
solid and I'm pretty happy with it as it is. So I'll probably
leave it alone unless (until?) I need something more.
My goal was to keep the simplicity of the Hayes' syntax, while
allowing easy extension for testing user-defined data types (which
I think may be the FFL's reason for using a different system).
It may not fit everywhere the Hayes' tester does: I think I kept
it reasonably small, but it's not designed to be a minimal tester.
It uses most of the looping constructs, including ?DO, and also
FIND and EXECUTE, among others.
So for anyone who is interested, here it is.
--Josh
-----------------------------------------------------------------------
\ A test framework in standard Forth
\ Joshua Grams <josh@[EMAIL PROTECTED]
> 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
\ && ( flag -- ) EXIT (returning flag) if flag is false.
\ 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 )
\ 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' ) @[EMAIL PROTECTED]
+ ;
: 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 @[EMAIL PROTECTED]
BEFORE-WORD ! BL WORD COUNT ;
: PUT-WORD-BACK BEFORE-WORD @[EMAIL PROTECTED]
>IN ! ;
\ String handling
: C+! ( char c-addr -- ) DUP >R C@[EMAIL PROTECTED]
+ 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 @[EMAIL PROTECTED]
- ;
\FS VARIABLE BASE-FDEPTH
\FS : OUR-FDEPTH ( -- n ) FDEPTH BASE-FDEPTH @[EMAIL PROTECTED]
- ;
: RESULTS-START-HERE
\FS FDEPTH BASE-FDEPTH !
DEPTH BASE-DEPTH ! ;
\ Error flag
VARIABLE ERROR
VARIABLE WANT-ERROR
: ERROR? ( -- flag ) ERROR @[EMAIL PROTECTED]
WANT-ERROR @[EMAIL PROTECTED]
<> ;
: ?ERROR ( flag -- ) 0= ERROR @[EMAIL PROTECTED]
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 @[EMAIL PROTECTED]
SWAP SAVED-SP ! ;
: RESTORE ( stack -- ) DUP SAVED-SP @[EMAIL PROTECTED]
OVER SP ! DUP BOTTOM SWAP HEAD ! ;
: #ITEMS ( stack -- +n ) DUP SP @[EMAIL PROTECTED]
SWAP HEAD @[EMAIL PROTECTED]
- 1 CELLS / ;
: PUSH ( x stack -- ) DUP >R SP @[EMAIL PROTECTED]
! 1 CELLS R> SP +! ;
: POP ( stack -- x ) -1 CELLS OVER SP +! SP @[EMAIL PROTECTED]
@[EMAIL PROTECTED]
;
: GET ( stack -- x ) DUP >R HEAD @[EMAIL PROTECTED]
@[EMAIL PROTECTED]
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 @[EMAIL PROTECTED]
SWAP HEAD @[EMAIL PROTECTED]
- 1 FLOATS / ;
\F : FGET ( stack -- r ) DUP >R HEAD @[EMAIL PROTECTED]
F@[EMAIL PROTECTED]
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 @[EMAIL PROTECTED]
F! 1 FLOATS R> +! ;
\FS : FPOP ( stack -- r ) -1 FLOATS OVER SP +! SP @[EMAIL PROTECTED]
F@[EMAIL PROTECTED]
;
\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 ) @[EMAIL PROTECTED]
;
\FS : FSTACK ( addr -- fstack ) CELL+ @[EMAIL PROTECTED]
;
\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 @[EMAIL PROTECTED]
CELLS STACKS + @[EMAIL PROTECTED]
;
: 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@[EMAIL PROTECTED]
FNEGATE F~ >R
\F ABSOLUTE-TOLERANCE F@[EMAIL PROTECTED]
F~ R> OR ;
\F : PRINT-R 1 FDISPLAYED IF F. ELSE ." no float " THEN ;
\ Error display
: .ERROR
S" Test Failed: " TYPE SOURCE TYPE CR
RESTORE-RESULTS S" Received: " TYPE .RESULTS CR
WANT-ERROR @[EMAIL PROTECTED]
0= IF
NEXT-RESULTS S" Expected: " TYPE .RESULTS 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 ;
|
