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

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