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

   1 \ From: John Hayes S1I\r
   2 \ Subject: tester.fr\r
   3 \ Date: Mon, 27 Nov 95 13:10:09 PST  \r
   4 \r
   5 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY\r
   6 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.\r
   7 \ VERSION 1.1\r
   8 HEX\r
   9 \r
  10 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY\r
  11 \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.\r
  12 VARIABLE VERBOSE\r
  13    FALSE VERBOSE !\r
  14 \r
  15 : EMPTY-STACK   \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.\r
  16    DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ;\r
  17 \r
  18 : ERROR         \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY\r
  19                 \ THE LINE THAT HAD THE ERROR.\r
  20    TYPE SOURCE TYPE CR                  \ DISPLAY LINE CORRESPONDING TO ERROR\r
  21    EMPTY-STACK                          \ THROW AWAY EVERY THING ELSE\r
  22 ;\r
  23 \r
  24 VARIABLE ACTUAL-DEPTH                   \ STACK RECORD\r
  25 CREATE ACTUAL-RESULTS 20 CELLS ALLOT\r
  26 \r
  27 : {             \ ( -- ) SYNTACTIC SUGAR.\r
  28    ;\r
  29 \r
  30 : ->            \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.\r
  31    DEPTH DUP ACTUAL-DEPTH !             \ RECORD DEPTH\r
  32    ?DUP IF                              \ IF THERE IS SOMETHING ON STACK\r
  33       0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM\r
  34    THEN ;\r
  35 \r
  36 : }             \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED\r
  37                 \ (ACTUAL) CONTENTS.\r
  38    DEPTH ACTUAL-DEPTH @ = IF            \ IF DEPTHS MATCH\r
  39       DEPTH ?DUP IF                     \ IF THERE IS SOMETHING ON THE STACK\r
  40          0 DO                           \ FOR EACH STACK ITEM\r
  41             ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED\r
  42             <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN\r
  43          LOOP\r
  44       THEN\r
  45    ELSE                                 \ DEPTH MISMATCH\r
  46       S" WRONG NUMBER OF RESULTS: " ERROR\r
  47    THEN ;\r
  48 \r
  49 : TESTING       \ ( -- ) TALKING COMMENT.\r
  50    SOURCE VERBOSE @\r
  51    IF DUP >R TYPE CR R> >IN !\r
  52    ELSE >IN ! DROP\r
  53    THEN ;\r
  54 \r