git.gag.com Git - debian/pforth/blob - fth/t_tools.fth

   1 \ @(#) t_tools.fth 97/12/10 1.1
   2 \ Test Tools for pForth
   3 \
   4 \ Based on testing tools from John Hayes
   5 \ (c) 1993 Johns Hopkins University / Applied Physics Laboratory
   6 \
   7 \ Syntax was changed to avoid conflict with { -> and } for local variables.
   8 \ Also added tracking of #successes and #errors.
   9
  10 anew task-t_tools.fth
  11
  12 decimal
  13
  14 variable TEST-DEPTH
  15 variable TEST-PASSED
  16 variable TEST-FAILED
  17 40 constant TEST_EXIT_FAILURE \ returned form pForth to shell
  18
  19 : TEST{
  20     depth test-depth !
  21     0 test-passed !
  22     0 test-failed !
  23 ;
  24
  25
  26 : }TEST
  27     test-passed @ 4 .r ."  passed, "
  28     test-failed @ 4 .r ."  failed." cr
  29     test-failed @ 0> IF
  30         TEST_EXIT_FAILURE bye-code !
  31     THEN
  32 ;
  33
  34
  35 VARIABLE actual-depth       \ stack record
  36 CREATE actual-results 20 CELLS ALLOT
  37
  38 : empty-stack \ ( ... -- ) Empty stack.
  39    DEPTH dup 0>
  40    IF 0 DO DROP LOOP
  41    ELSE drop
  42    THEN ;
  43
  44 CREATE the-test 128 CHARS ALLOT
  45
  46 : ERROR     \ ( c-addr u -- ) Display an error message followed by
  47         \ the line that had the error.
  48    TYPE the-test COUNT TYPE CR \ display line corresponding to error
  49    empty-stack          \ throw away every thing else
  50 ;
  51
  52
  53 : T{
  54     source the-test place
  55     empty-stack
  56 ;
  57
  58 : }T{   \ ( ... -- ) Record depth and content of stack.
  59     DEPTH actual-depth !    \ record depth
  60     DEPTH 0
  61     ?DO
  62         actual-results I CELLS + !
  63     LOOP \ save them
  64 ;
  65
  66 : }T    \ ( ... -- ) Compare stack (expected) contents with saved
  67         \ (actual) contents.
  68     DEPTH
  69     actual-depth @ =
  70     IF  \ if depths match
  71         1 test-passed +!  \ assume will pass
  72         DEPTH 0
  73         ?DO             \ for each stack item
  74             actual-results I CELLS + @ \ compare actual with expected
  75             <>
  76             IF
  77                 -1 test-passed +!
  78                 1 test-failed +!
  79                 S" INCORRECT RESULT: " error
  80                 LEAVE
  81             THEN
  82         LOOP
  83     ELSE                \ depth mismatch
  84         1 test-failed +!
  85         S" WRONG NUMBER OF RESULTS: " error
  86     THEN
  87 ;