usr/src/common/ficl/test/tester.fr

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