[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.5

version 1.1, 1997/05/21 20:40:20 version 1.5, 2007/08/12 13:48:53
Line 5 Line 5
 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY  \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.  \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
 \ VERSION 1.1  \ VERSION 1.1
   
   \ revised by Anton Ertl 2007-08-12
   \ The original has two shortcomings:
   
   \ - It does not work as expected if the stack is non-empty before the {.
   
   \ - 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  HEX
   
 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY  \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
Line 12  HEX Line 54  HEX
 VARIABLE VERBOSE  VARIABLE VERBOSE
    FALSE 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.  : 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 ;      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 ;
   
 : ERROR         \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY  : ERROR1        \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
                 \ THE LINE THAT HAD THE ERROR.                  \ THE LINE THAT HAD THE ERROR.
    TYPE SOURCE TYPE CR                  \ DISPLAY LINE CORRESPONDING TO ERROR     TYPE SOURCE TYPE CR                  \ DISPLAY LINE CORRESPONDING TO ERROR
    EMPTY-STACK                          \ THROW AWAY EVERY THING ELSE     EMPTY-STACK                          \ THROW AWAY EVERY THING ELSE
 ;  ;
   
 VARIABLE ACTUAL-DEPTH                   \ STACK RECORD  ' ERROR1 ERROR-XT !
 CREATE ACTUAL-RESULTS 20 CELLS ALLOT  
   
 : {             \ ( -- ) SYNTACTIC SUGAR.  : {             \ ( -- ) SYNTACTIC SUGAR.
    ;     DEPTH START-DEPTH ! F{ ;
   
 : ->            \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.  : ->            \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
    DEPTH DUP ACTUAL-DEPTH !             \ RECORD DEPTH     DEPTH DUP ACTUAL-DEPTH !             \ RECORD DEPTH
    ?DUP IF                              \ IF THERE IS SOMETHING ON STACK     START-DEPTH @ > IF           \ IF THERE IS SOMETHING ON STACK
       0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM         DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
    THEN ;     THEN
      F-> ;
   
 : }             \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED  : }             \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
                 \ (ACTUAL) CONTENTS.                  \ (ACTUAL) CONTENTS.
    DEPTH ACTUAL-DEPTH @ = IF            \ IF DEPTHS MATCH     DEPTH ACTUAL-DEPTH @ = IF            \ IF DEPTHS MATCH
       DEPTH ?DUP IF                     \ IF THERE IS SOMETHING ON THE STACK        DEPTH START-DEPTH @ > IF          \ IF THERE IS SOMETHING ON THE STACK
          0 DO                           \ FOR EACH STACK ITEM           DEPTH START-DEPTH @ DO         \ FOR EACH STACK ITEM
             ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED              ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED
             <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN              <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
          LOOP           LOOP
       THEN        THEN
    ELSE                                 \ DEPTH MISMATCH     ELSE                                 \ DEPTH MISMATCH
       S" WRONG NUMBER OF RESULTS: " ERROR        S" WRONG NUMBER OF RESULTS: " ERROR
    THEN ;     THEN
      F} ;
   
 : TESTING       \ ( -- ) TALKING COMMENT.  : TESTING       \ ( -- ) TALKING COMMENT.
    SOURCE VERBOSE @     SOURCE VERBOSE @
Removed from v.1.1  
changed lines
  Added in v.1.5

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