[BACK]Return to tester.fs CVS log [TXT] [DIR] Up to [gforth] / gforth / test

Diff for /gforth/test/tester.fs between versions 1.1 and 1.7

version 1.1, 1997/05/21 20:40:20 version 1.7, 2007/08/21 09:26:03
Line 1 Line 1
 \ From: John Hayes S1I  \ drop-in replacement for John Hayes' tester
 \ Subject: tester.fr  
 \ Date: Mon, 27 Nov 95 13:10:09 PST    \ This file is in the public domain. NO WARRANTY.
   \ Note licensing for ttester.fs
 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY  
 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.  S" ./ttester.fs" INCLUDED
 \ VERSION 1.1  
 HEX  : { T{ ;
   
 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY  : } }T ;
 \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.  
 VARIABLE VERBOSE  
    FALSE VERBOSE !  
   
 : EMPTY-STACK   \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.  
    DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ;  
   
 : ERROR         \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY  
                 \ THE LINE THAT HAD THE ERROR.  
    TYPE SOURCE TYPE CR                  \ DISPLAY LINE CORRESPONDING TO ERROR  
    EMPTY-STACK                          \ THROW AWAY EVERY THING ELSE  
 ;  
   
 VARIABLE ACTUAL-DEPTH                   \ STACK RECORD  
 CREATE ACTUAL-RESULTS 20 CELLS ALLOT  
   
 : {             \ ( -- ) SYNTACTIC SUGAR.  
    ;  
   
 : ->            \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.  
    DEPTH DUP ACTUAL-DEPTH !             \ RECORD DEPTH  
    ?DUP IF                              \ IF THERE IS SOMETHING ON STACK  
       0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM  
    THEN ;  
   
 : }             \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED  
                 \ (ACTUAL) CONTENTS.  
    DEPTH ACTUAL-DEPTH @ = IF            \ IF DEPTHS MATCH  
       DEPTH ?DUP IF                     \ IF THERE IS SOMETHING ON THE STACK  
          0 DO                           \ FOR EACH STACK ITEM  
             ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED  
             <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN  
          LOOP  
       THEN  
    ELSE                                 \ DEPTH MISMATCH  
       S" WRONG NUMBER OF RESULTS: " ERROR  
    THEN ;  
   
 : TESTING       \ ( -- ) TALKING COMMENT.  
    SOURCE VERBOSE @  
    IF DUP >R TYPE CR R> >IN !  
    ELSE >IN ! DROP  
    THEN ;  
   
Removed from v.1.1  
changed lines
  Added in v.1.7

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>