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
  18 : TEST{
  19         depth test-depth !
  20         0 test-passed !
  21         0 test-failed !
  22 ;
  23
  24
  25 : }TEST
  26         test-passed @ 4 .r ."  passed, "
  27         test-failed @ 4 .r ."  failed." cr
  28 ;
  29
  30
  31 VARIABLE actual-depth       \ stack record
  32 CREATE actual-results 20 CELLS ALLOT
  33
  34 : empty-stack \ ( ... -- ) Empty stack.
  35    DEPTH dup 0>
  36    IF 0 DO DROP LOOP
  37    ELSE drop
  38    THEN ;
  39
  40 CREATE the-test 128 CHARS ALLOT
  41
  42 : ERROR     \ ( c-addr u -- ) Display an error message followed by
  43         \ the line that had the error.
  44    TYPE the-test COUNT TYPE CR \ display line corresponding to error
  45    empty-stack          \ throw away every thing else
  46 ;
  47
  48
  49 : T{
  50     source the-test place
  51     empty-stack
  52 ;
  53
  54 : }T{   \ ( ... -- ) Record depth and content of stack.
  55     DEPTH actual-depth !    \ record depth
  56     DEPTH 0
  57     ?DO
  58         actual-results I CELLS + !
  59     LOOP \ save them
  60 ;
  61
  62 : }T    \ ( ... -- ) Compare stack (expected) contents with saved
  63         \ (actual) contents.
  64     DEPTH
  65     actual-depth @ =
  66     IF  \ if depths match
  67         1 test-passed +!  \ assume will pass
  68         DEPTH 0
  69         ?DO             \ for each stack item
  70             actual-results I CELLS + @ \ compare actual with expected
  71             <>
  72             IF
  73                 -1 test-passed +!
  74                 1 test-failed +!
  75                 S" INCORRECT RESULT: " error
  76                 LEAVE
  77             THEN
  78         LOOP
  79     ELSE                \ depth mismatch
  80         1 test-failed +!
  81         S" WRONG NUMBER OF RESULTS: " error
  82     THEN
  83 ;