File:  [gforth] / gforth / test / ttester.fs
Revision 1.6: download - view: text, annotated - select for diffs
Fri Oct 26 12:47:41 2007 UTC (10 years ago) by anton
Branches: MAIN
CVS tags: HEAD
ttester bugfix: ...}T now handles non-empty start-depths

\ FOR THE ORIGINAL TESTER
\ FROM: JOHN HAYES S1I
\ SUBJECT: TESTER.FR
\ DATE: MON, 27 NOV 95 13:10:09 PST  
\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
\ VERSION 1.1

\ FOR THE FNEARLY= STUFF:
\ FROM FTESTER.FS WRITTEN BY DAVID N. WILLIAMS, BASED ON THE IDEA OF
\ APPROXIMATE EQUALITY IN DIRK ZOLLER'S FLOAT.4TH
\ PUBLIC DOMAIN

\ FOR THE REST:
\ REVISED BY ANTON ERTL 2007-08-12, 2007-08-19, 2007-08-28
\ PUBLIC DOMAIN

\ THE ORIGINAL HAS THE FOLLOWING 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.

\ - THERE IS A CONFLICT WITH THE USE OF } FOR FSL ARRAYS AND { FOR LOCALS.

\ I HAVE REVISED IT TO ADDRESS THESE SHORTCOMINGS.  YOU CAN FIND THE
\ RESULT AT

\ HTTP://WWW.FORTH200X.ORG/TESTS/TESTER.FS
\ HTTP://WWW.FORTH200X.ORG/TESTS/TTESTER.FS

\ TESTER.FS IS INTENDED TO BE A DROP-IN REPLACEMENT OF THE ORIGINAL.

\ TTESTER.FS IS A VERSION THAT USES T{ AND }T INSTEAD OF { AND } AND
\ KEEPS THE BASE AS IT WAS BEFORE LOADING TTESTER.FS

\ 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

\ THERE ARE A FEW THINGS TO BE NOTED:

\ - LOADING TTESTER.FS DOES NOT CHANGE BASE.  LOADING TESTER.FS
\ CHANGES BASE TO HEX (LIKE THE ORIGINAL TESTER).  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.

\ - FOR FP IT IS OFTEN USEFUL TO USE APPROXIMATE EQUALITY FOR CHECKING
\ THE RESULTS.  YOU CAN TURN ON APPROXIMATE MATCHING WITH SET-NEAR
\ (AND TURN IT OFF (DEFAULT) WITH SET-EXACT, AND YOU CAN TUNE IT BY
\ SETTING THE VARIABLES REL-NEAR AND ABS-NEAR.  IF YOU WANT YOUR TESTS
\ TO WORK WITH A SHARED STACK, YOU HAVE TO SPECIFY THE TYPES OF THE
\ ELEMENTS ON THE STACK BY USING ONE OF THE CLOSING WORDS THAT SPECIFY
\ TYPES, E.G. RRRX}T FOR CHECKING THE STACK PICTURE ( R R R X ).
\ THERE ARE SUCH WORDS FOR ALL COMBINATION OF R AND X WITH UP TO 4
\ STACK ITEMS, AND DEFINING MORE IF YOU NEED THEM IS STRAIGHTFORWARD
\ (SEE SOURCE).  IF YOUR TESTS ARE ONLY INTENDED FOR A SEPARATE-STACK
\ SYSTEM OR IF YOU NEED ONLY EXACT MATCHING, YOU CAN USE THE PLAIN }T
\ INSTEAD.

BASE @
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 XCURSOR \ FOR ...}T
VARIABLE ERROR-XT

: ERROR ERROR-XT @ EXECUTE ;

: "FLOATING" S" FLOATING" ; \ ONLY COMPILED S" IN CORE
: "FLOATING-STACK" S" FLOATING-STACK" ;
"FLOATING" ENVIRONMENT? [IF]
    [IF]
        TRUE
    [ELSE]
        FALSE
    [THEN]
[ELSE]
    FALSE
[THEN] CONSTANT HAS-FLOATING
"FLOATING-STACK" ENVIRONMENT? [IF]
    [IF]
        TRUE
    [ELSE]
        FALSE
    [THEN]
[ELSE] \ WE DON'T KNOW WHETHER THE FP STACK IS SEPARATE
    HAS-FLOATING \ IF WE HAVE FLOATING, WE ASSUME IT IS
[THEN] CONSTANT HAS-FLOATING-STACK

HAS-FLOATING [IF]
    \ SET THE FOLLOWING TO THE RELATIVE AND ABSOLUTE TOLERANCES YOU
    \ WANT FOR APPROXIMATE FLOAT EQUALITY, TO BE USED WITH F~ IN
    \ FNEARLY=.  KEEP THE SIGNS, BECAUSE F~ NEEDS THEM.
    FVARIABLE REL-NEAR DECIMAL 1E-12 HEX REL-NEAR F!
    FVARIABLE ABS-NEAR    DECIMAL 0E HEX ABS-NEAR F!

    \ WHEN EXACT? IS TRUE, }F USES FEXACTLY=, OTHERWISE FNEARLY=.
    
    TRUE VALUE EXACT?
    : SET-EXACT  ( -- )   TRUE TO EXACT? ;
    : SET-NEAR   ( -- )  FALSE TO EXACT? ;

    DECIMAL
    : FEXACTLY=  ( F: X Y -- S: FLAG )
        (
        LEAVE TRUE IF THE TWO FLOATS ARE IDENTICAL.
        )
        0E F~ ;
    HEX
    
    : FABS=  ( F: X Y -- S: FLAG )
        (
        LEAVE TRUE IF THE TWO FLOATS ARE EQUAL WITHIN THE TOLERANCE
        STORED IN ABS-NEAR.
        )
        ABS-NEAR F@ F~ ;
    
    : FREL=  ( F: X Y -- S: FLAG )
        (
        LEAVE TRUE IF THE TWO FLOATS ARE RELATIVELY EQUAL BASED ON THE
        TOLERANCE STORED IN ABS-NEAR.
        )
        REL-NEAR F@ FNEGATE F~ ;

    : F2DUP  FOVER FOVER ;
    : F2DROP FDROP FDROP ;
    
    : FNEARLY=  ( F: X Y -- S: FLAG )
        (
        LEAVE TRUE IF THE TWO FLOATS ARE NEARLY EQUAL.  THIS IS A
        REFINEMENT OF DIRK ZOLLER'S FEQ TO ALSO ALLOW X = Y, INCLUDING
        BOTH ZERO, OR TO ALLOW APPROXIMATE EQUALITY WHEN X AND Y ARE TOO
        SMALL TO SATISFY THE RELATIVE APPROXIMATION MODE IN THE F~
        SPECIFICATION.
        )
        F2DUP FEXACTLY= IF F2DROP TRUE EXIT THEN
        F2DUP FREL=     IF F2DROP TRUE EXIT THEN
        FABS= ;

    : FCONF= ( R1 R2 -- F )
        EXACT? IF
            FEXACTLY=
        ELSE
            FNEARLY=
        THEN ;
[THEN]

HAS-FLOATING-STACK [IF]
    VARIABLE ACTUAL-FDEPTH
    CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT
    VARIABLE START-FDEPTH
    VARIABLE FCURSOR

    : 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 ! 0 FCURSOR ! ;

    : 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@ FCONF= INVERT IF
                        S" INCORRECT FP RESULT: " ERROR LEAVE
                    THEN
                LOOP
            THEN
        ELSE
            S" WRONG NUMBER OF FP RESULTS: " ERROR
        THEN ;

    : F...}T ( -- )
        FDEPTH START-FDEPTH @ = 0= IF
            S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR
        THEN
        FCURSOR @ START-FDEPTH @ + ACTUAL-FDEPTH @ <> IF
            S" NUMBER OF FLOAT RESULTS BEFORE '->' DOES NOT MATCH ...}T SPRECIFICATION: " ERROR
        THEN ;
    
    : FTESTER ( R -- )
        FDEPTH 0= ACTUAL-FDEPTH @ FCURSOR @ START-FDEPTH @ + 1+ < OR IF
            S" NUMBER OF FLOAT RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
        THEN
        ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF
            S" INCORRECT FP RESULT: " ERROR
        THEN
        1 FCURSOR +! ;
        
[ELSE]
    : EMPTY-FSTACK ;
    : F{ ;
    : F-> ;
    : F} ;
    : F...}T ;

    DECIMAL
    : COMPUTE-CELLS-PER-FP ( -- U )
        DEPTH 0E DEPTH 1- >R FDROP R> SWAP - ;
    HEX

    COMPUTE-CELLS-PER-FP CONSTANT CELLS-PER-FP
    
    : FTESTER ( R -- )
        DEPTH CELLS-PER-FP < ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + CELLS-PER-FP + < OR IF
            S" NUMBER OF RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
        THEN
        ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF
            S" INCORRECT FP RESULT: " ERROR
        THEN
        CELLS-PER-FP XCURSOR +! ;
 [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 !

: T{		\ ( -- ) SYNTACTIC SUGAR.
   DEPTH START-DEPTH ! 0 XCURSOR ! 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-> ;

: }T		\ ( ... -- ) 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} ;

: ...}T ( -- )
    DEPTH START-DEPTH @ = 0= IF
        S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR
    THEN
    XCURSOR @ START-DEPTH @ + ACTUAL-DEPTH @ <> IF
        S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T SPRECIFICATION: " ERROR
    THEN
    F...}T ;

: XTESTER ( X -- )
    DEPTH 0= ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + 1+ < OR IF
        S" NUMBER OF CELL RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT
    THEN
    ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF
        S" INCORRECT CELL RESULT: " ERROR
    THEN
    1 XCURSOR +! ;

: X}T XTESTER ...}T ;
: R}T FTESTER ...}T ;
: XX}T XTESTER XTESTER ...}T ;
: XR}T FTESTER XTESTER ...}T ;
: RX}T XTESTER FTESTER ...}T ;
: RR}T FTESTER FTESTER ...}T ;
: XXX}T XTESTER XTESTER XTESTER ...}T ;
: XXR}T FTESTER XTESTER XTESTER ...}T ;
: XRX}T XTESTER FTESTER XTESTER ...}T ;
: XRR}T FTESTER FTESTER XTESTER ...}T ;
: RXX}T XTESTER XTESTER FTESTER ...}T ;
: RXR}T FTESTER XTESTER FTESTER ...}T ;
: RRX}T XTESTER FTESTER FTESTER ...}T ;
: RRR}T FTESTER FTESTER FTESTER ...}T ;
: XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ;
: XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ;
: XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ;
: XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ;
: XRXX}T XTESTER XTESTER FTESTER XTESTER ...}T ;
: XRXR}T FTESTER XTESTER FTESTER XTESTER ...}T ;
: XRRX}T XTESTER FTESTER FTESTER XTESTER ...}T ;
: XRRR}T FTESTER FTESTER FTESTER XTESTER ...}T ;
: RXXX}T XTESTER XTESTER XTESTER FTESTER ...}T ;
: RXXR}T FTESTER XTESTER XTESTER FTESTER ...}T ;
: RXRX}T XTESTER FTESTER XTESTER FTESTER ...}T ;
: RXRR}T FTESTER FTESTER XTESTER FTESTER ...}T ;
: RRXX}T XTESTER XTESTER FTESTER FTESTER ...}T ;
: RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ;
: RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ;
: RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ;

: TESTING	\ ( -- ) TALKING COMMENT.
   SOURCE VERBOSE @
   IF DUP >R TYPE CR R> >IN !
   ELSE >IN ! DROP
   THEN ;

BASE !

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