Diff for /gforth/test/tester.fs between versions 1.5 and 1.6

version 1.5, 2007/08/12 13:48:53 version 1.6, 2007/08/19 21:33:50
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    
   
 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY  S" ./ttester.fs" INCLUDED
 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.  
 \ VERSION 1.1  
   
 \ revised by Anton Ertl 2007-08-12  : { T{ ;
 \ The original has two shortcomings:  
   
 \ - It does not work as expected if the stack is non-empty before the {.  : } }T ;
   
 \ - It does not check FP results if the system has a separate FP stack.  
   
 \ I have revised it to address both shortcomings.  You can find the  
 \ result at  
   
 \ http://www.forth200x.org/tests/tester.fs  
   
 \ It is intended to be a drop-in replacement of the original.  
   
 \ In spirit of the original, I have strived to avoid any potential  
 \ non-portabilities and stayed as much within the CORE words as  
 \ possible; e.g., FLOATING words are used only if the FLOATING wordset  
 \ is present and the FP stack is separate.  
   
 \ There are a few things to be noted:  
   
 \ - Following the despicable practice of the original, this version sets  
 \   the base to HEX for everything that gets loaded later.  
 \   Floating-point input is ambiguous when the base is not decimal, so  
 \   you have to set it to decimal yourself when you want to deal with  
 \   decimal numbers.  
   
 \ - The separate-FP-stack code has an fvariable FSENSITIVITY that allows  
 \   approximate matching of FP results (it's used as the r3 parameter of  
 \   F~).  However, that's used only in the separate-fp-stack case.  With  
 \   a shared-fp-stack you get exact matching in any case (actually  
 \   FSENSITIVITY variable is not even defined in that case).  So if you  
 \   define an FP test case and want to support shared-FP-stack systems,  
 \   better do the approximate matching yourself.  E.g., instead of  
   
 \   -1e-12 fsensitivity f!  
 \   { ... computation ... -> 2.345678901e }  
   
 \   write  
   
 \   { ... computation ... 2.345678901e -1e-12 f~ -> true }  
 HEX  
   
 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY  
 \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.  
 VARIABLE VERBOSE  
    FALSE VERBOSE !  
   
 VARIABLE ACTUAL-DEPTH                   \ STACK RECORD  
 CREATE ACTUAL-RESULTS 20 CELLS ALLOT  
 VARIABLE START-DEPTH  
 VARIABLE ERROR-XT  
   
 : ERROR ERROR-XT @ EXECUTE ;  
   
 : "FLOATING" S" FLOATING" ; \ ONLY COMPILED S" IN CORE  
 : "FLOATING-STACK" S" FLOATING-STACK" ;  
 "FLOATING" ENVIRONMENT? [IF]  
     [IF]  
         "FLOATING-STACK" ENVIRONMENT? [IF]  
             [IF]  
                 TRUE  
             [ELSE]  
                 FALSE  
             [THEN]  
         [ELSE] \ WE DON'T KNOW WHETHER THE FP STACK IS SEPARATE  
             TRUE \ SAFER CHOICE TO ASSUME IT IS  
         [THEN]    
     [ELSE]  
         FALSE  
     [THEN]  
 [ELSE]  
     FALSE  
 [THEN]  
 [IF] \ WE HAVE FP WORDS AND A SEPARATE FP STACK  
     FVARIABLE FSENSITIVITY DECIMAL 0E HEX FSENSITIVITY F!  
     VARIABLE ACTUAL-FDEPTH  
     CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT  
     VARIABLE START-FDEPTH  
   
     : EMPTY-FSTACK ( ... -- ... )  
         FDEPTH START-FDEPTH @ < IF  
             FDEPTH START-FDEPTH @ SWAP DO 0E LOOP  
         THEN  
         FDEPTH START-FDEPTH @ > IF  
             FDEPTH START-FDEPTH @ DO FDROP LOOP  
         THEN ;  
   
     : F{ ( -- )  
         FDEPTH START-FDEPTH ! ;  
   
     : F-> ( ... -- ... )  
         FDEPTH DUP ACTUAL-FDEPTH !  
         START-FDEPTH @ > IF  
             FDEPTH START-FDEPTH @ DO ACTUAL-FRESULTS I FLOATS + F! LOOP  
         THEN ;  
   
     : F} ( ... -- ... )  
         FDEPTH ACTUAL-FDEPTH @ = IF  
             FDEPTH START-FDEPTH @ > IF  
                 FDEPTH START-FDEPTH @ DO  
                     ACTUAL-FRESULTS I FLOATS + F@  
                     FSENSITIVITY F@ F~ INVERT IF  
                         S" INCORRECT RESULT: " ERROR LEAVE  
                     THEN  
                 LOOP  
             THEN  
         ELSE  
             S" WRONG NUMBER OF RESULTS: " ERROR  
         THEN ;  
 [ELSE]  
     : EMPTY-FSTACK ;  
     : F{ ;  
     : F-> ;  
     : F} ;  
 [THEN]      
   
 : EMPTY-STACK   \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.  
     DEPTH START-DEPTH @ < IF  
         DEPTH START-DEPTH @ SWAP DO 0 LOOP  
     THEN  
     DEPTH START-DEPTH @ > IF  
         DEPTH START-DEPTH @ DO DROP LOOP  
     THEN  
     EMPTY-FSTACK ;  
   
 : ERROR1        \ ( 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  
 ;  
   
 ' ERROR1 ERROR-XT !  
   
 : {             \ ( -- ) SYNTACTIC SUGAR.  
    DEPTH START-DEPTH ! F{ ;  
   
 : ->            \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.  
    DEPTH DUP ACTUAL-DEPTH !             \ RECORD DEPTH  
    START-DEPTH @ > IF           \ IF THERE IS SOMETHING ON STACK  
        DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM  
    THEN  
    F-> ;  
   
 : }             \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED  
                 \ (ACTUAL) CONTENTS.  
    DEPTH ACTUAL-DEPTH @ = IF            \ IF DEPTHS MATCH  
       DEPTH START-DEPTH @ > IF          \ IF THERE IS SOMETHING ON THE STACK  
          DEPTH START-DEPTH @ 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  
    F} ;  
   
 : TESTING       \ ( -- ) TALKING COMMENT.  
    SOURCE VERBOSE @  
    IF DUP >R TYPE CR R> >IN !  
    ELSE >IN ! DROP  
    THEN ;  
   

Removed from v.1.5  
changed lines
  Added in v.1.6


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