/fth/t_tools.fth
https://github.com/philburk/pforth · Forth · 83 lines · 68 code · 15 blank · 0 comment · 4 complexity · 07b696e1631cf50bea5a92aad5cdc8a9 MD5 · raw file
- \ @(#) t_tools.fth 97/12/10 1.1
- \ Test Tools for pForth
- \
- \ Based on testing tools from John Hayes
- \ (c) 1993 Johns Hopkins University / Applied Physics Laboratory
- \
- \ Syntax was changed to avoid conflict with { -> and } for local variables.
- \ Also added tracking of #successes and #errors.
- anew task-t_tools.fth
- decimal
- variable TEST-DEPTH
- variable TEST-PASSED
- variable TEST-FAILED
- : TEST{
- depth test-depth !
- 0 test-passed !
- 0 test-failed !
- ;
- : }TEST
- test-passed @ 4 .r ." passed, "
- test-failed @ 4 .r ." failed." cr
- ;
- VARIABLE actual-depth \ stack record
- CREATE actual-results 20 CELLS ALLOT
- : empty-stack \ ( ... -- ) Empty stack.
- DEPTH dup 0>
- IF 0 DO DROP LOOP
- ELSE drop
- THEN ;
- CREATE the-test 128 CHARS ALLOT
- : ERROR \ ( c-addr u -- ) Display an error message followed by
- \ the line that had the error.
- TYPE the-test COUNT TYPE CR \ display line corresponding to error
- empty-stack \ throw away every thing else
- ;
- : T{
- source the-test place
- empty-stack
- ;
- : }T{ \ ( ... -- ) Record depth and content of stack.
- DEPTH actual-depth ! \ record depth
- DEPTH 0
- ?DO
- actual-results I CELLS + !
- LOOP \ save them
- ;
- : }T \ ( ... -- ) Compare stack (expected) contents with saved
- \ (actual) contents.
- DEPTH
- actual-depth @ =
- IF \ if depths match
- 1 test-passed +! \ assume will pass
- DEPTH 0
- ?DO \ for each stack item
- actual-results I CELLS + @ \ compare actual with expected
- <>
- IF
- -1 test-passed +!
- 1 test-failed +!
- S" INCORRECT RESULT: " error
- LEAVE
- THEN
- LOOP
- ELSE \ depth mismatch
- 1 test-failed +!
- S" WRONG NUMBER OF RESULTS: " error
- THEN
- ;