git.gag.com Git - debian/pforth/blob - 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 ;