File:  [gforth] / gforth / test / tester.fs
Revision 1.5: download - view: text, annotated - select for diffs
Sun Aug 12 13:48:53 2007 UTC (13 years, 10 months ago) by anton
Branches: MAIN
CVS tags: HEAD
changed comments in test/tester.fs

    1: \ From: John Hayes S1I
    2: \ Subject: tester.fr
    3: \ Date: Mon, 27 Nov 95 13:10:09 PST  
    4: 
    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: \ revised by Anton Ertl 2007-08-12
   10: \ The original has two shortcomings:
   11: 
   12: \ - It does not work as expected if the stack is non-empty before the {.
   13: 
   14: \ - It does not check FP results if the system has a separate FP stack.
   15: 
   16: \ I have revised it to address both shortcomings.  You can find the
   17: \ result at
   18: 
   19: \ http://www.forth200x.org/tests/tester.fs
   20: 
   21: \ It is intended to be a drop-in replacement of the original.
   22: 
   23: \ In spirit of the original, I have strived to avoid any potential
   24: \ non-portabilities and stayed as much within the CORE words as
   25: \ possible; e.g., FLOATING words are used only if the FLOATING wordset
   26: \ is present and the FP stack is separate.
   27: 
   28: \ There are a few things to be noted:
   29: 
   30: \ - Following the despicable practice of the original, this version sets
   31: \   the base to HEX for everything that gets loaded later.
   32: \   Floating-point input is ambiguous when the base is not decimal, so
   33: \   you have to set it to decimal yourself when you want to deal with
   34: \   decimal numbers.
   35: 
   36: \ - The separate-FP-stack code has an fvariable FSENSITIVITY that allows
   37: \   approximate matching of FP results (it's used as the r3 parameter of
   38: \   F~).  However, that's used only in the separate-fp-stack case.  With
   39: \   a shared-fp-stack you get exact matching in any case (actually
   40: \   FSENSITIVITY variable is not even defined in that case).  So if you
   41: \   define an FP test case and want to support shared-FP-stack systems,
   42: \   better do the approximate matching yourself.  E.g., instead of
   43: 
   44: \   -1e-12 fsensitivity f!
   45: \   { ... computation ... -> 2.345678901e }
   46: 
   47: \   write
   48: 
   49: \   { ... computation ... 2.345678901e -1e-12 f~ -> true }
   50: HEX
   51: 
   52: \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
   53: \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
   54: VARIABLE VERBOSE
   55:    FALSE VERBOSE !
   56: 
   57: VARIABLE ACTUAL-DEPTH			\ STACK RECORD
   58: CREATE ACTUAL-RESULTS 20 CELLS ALLOT
   59: VARIABLE START-DEPTH
   60: VARIABLE ERROR-XT
   61: 
   62: : ERROR ERROR-XT @ EXECUTE ;
   63: 
   64: : "FLOATING" S" FLOATING" ; \ ONLY COMPILED S" IN CORE
   65: : "FLOATING-STACK" S" FLOATING-STACK" ;
   66: "FLOATING" ENVIRONMENT? [IF]
   67:     [IF]
   68:         "FLOATING-STACK" ENVIRONMENT? [IF]
   69:             [IF]
   70:                 TRUE
   71:             [ELSE]
   72:                 FALSE
   73:             [THEN]
   74:         [ELSE] \ WE DON'T KNOW WHETHER THE FP STACK IS SEPARATE
   75:             TRUE \ SAFER CHOICE TO ASSUME IT IS
   76:         [THEN]  
   77:     [ELSE]
   78:         FALSE
   79:     [THEN]
   80: [ELSE]
   81:     FALSE
   82: [THEN]
   83: [IF] \ WE HAVE FP WORDS AND A SEPARATE FP STACK
   84:     FVARIABLE FSENSITIVITY DECIMAL 0E HEX FSENSITIVITY F!
   85:     VARIABLE ACTUAL-FDEPTH
   86:     CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT
   87:     VARIABLE START-FDEPTH
   88: 
   89:     : EMPTY-FSTACK ( ... -- ... )
   90:         FDEPTH START-FDEPTH @ < IF
   91:             FDEPTH START-FDEPTH @ SWAP DO 0E LOOP
   92:         THEN
   93:         FDEPTH START-FDEPTH @ > IF
   94:             FDEPTH START-FDEPTH @ DO FDROP LOOP
   95:         THEN ;
   96: 
   97:     : F{ ( -- )
   98:         FDEPTH START-FDEPTH ! ;
   99: 
  100:     : F-> ( ... -- ... )
  101:         FDEPTH DUP ACTUAL-FDEPTH !
  102:         START-FDEPTH @ > IF
  103:             FDEPTH START-FDEPTH @ DO ACTUAL-FRESULTS I FLOATS + F! LOOP
  104:         THEN ;
  105: 
  106:     : F} ( ... -- ... )
  107:         FDEPTH ACTUAL-FDEPTH @ = IF
  108:             FDEPTH START-FDEPTH @ > IF
  109:                 FDEPTH START-FDEPTH @ DO
  110:                     ACTUAL-FRESULTS I FLOATS + F@
  111:                     FSENSITIVITY F@ F~ INVERT IF
  112:                         S" INCORRECT RESULT: " ERROR LEAVE
  113:                     THEN
  114:                 LOOP
  115:             THEN
  116:         ELSE
  117:             S" WRONG NUMBER OF RESULTS: " ERROR
  118:         THEN ;
  119: [ELSE]
  120:     : EMPTY-FSTACK ;
  121:     : F{ ;
  122:     : F-> ;
  123:     : F} ;
  124: [THEN]    
  125: 
  126: : EMPTY-STACK	\ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
  127:     DEPTH START-DEPTH @ < IF
  128:         DEPTH START-DEPTH @ SWAP DO 0 LOOP
  129:     THEN
  130:     DEPTH START-DEPTH @ > IF
  131:         DEPTH START-DEPTH @ DO DROP LOOP
  132:     THEN
  133:     EMPTY-FSTACK ;
  134: 
  135: : ERROR1	\ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
  136: 		\ THE LINE THAT HAD THE ERROR.
  137:    TYPE SOURCE TYPE CR			\ DISPLAY LINE CORRESPONDING TO ERROR
  138:    EMPTY-STACK				\ THROW AWAY EVERY THING ELSE
  139: ;
  140: 
  141: ' ERROR1 ERROR-XT !
  142: 
  143: : {		\ ( -- ) SYNTACTIC SUGAR.
  144:    DEPTH START-DEPTH ! F{ ;
  145: 
  146: : ->		\ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
  147:    DEPTH DUP ACTUAL-DEPTH !		\ RECORD DEPTH
  148:    START-DEPTH @ > IF		\ IF THERE IS SOMETHING ON STACK
  149:        DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
  150:    THEN
  151:    F-> ;
  152: 
  153: : }		\ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
  154: 		\ (ACTUAL) CONTENTS.
  155:    DEPTH ACTUAL-DEPTH @ = IF		\ IF DEPTHS MATCH
  156:       DEPTH START-DEPTH @ > IF		\ IF THERE IS SOMETHING ON THE STACK
  157:          DEPTH START-DEPTH @ DO		\ FOR EACH STACK ITEM
  158: 	    ACTUAL-RESULTS I CELLS + @	\ COMPARE ACTUAL WITH EXPECTED
  159: 	    <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
  160: 	 LOOP
  161:       THEN
  162:    ELSE					\ DEPTH MISMATCH
  163:       S" WRONG NUMBER OF RESULTS: " ERROR
  164:    THEN
  165:    F} ;
  166: 
  167: : TESTING	\ ( -- ) TALKING COMMENT.
  168:    SOURCE VERBOSE @
  169:    IF DUP >R TYPE CR R> >IN !
  170:    ELSE >IN ! DROP
  171:    THEN ;
  172: 

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