Return to tester.fs CVS log

Up to [gforth] / gforth / test

added fp stuff to 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: \   added fp comparisons (note: BASE is HEX after loading this file)
   11: \         environmental dependency on separate fp stack
   12: \         the sensitivity of the fp comparison is determined by FSENSITIVITY
   13: \   added support for non-empty stack at the start
   14: HEX
   15: 
   16: \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
   17: \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
   18: VARIABLE VERBOSE
   19:    FALSE VERBOSE !
   20: 
   21: VARIABLE ACTUAL-DEPTH			\ STACK RECORD
   22: CREATE ACTUAL-RESULTS 20 CELLS ALLOT
   23: VARIABLE START-DEPTH
   24: VARIABLE ERROR-XT
   25: 
   26: : ERROR ERROR-XT @ EXECUTE ;
   27: 
   28: : "FLOATING" S" FLOATING" ; \ ONLY COMPILED S" IN CORE
   29: : "FLOATING-STACK" S" FLOATING-STACK" ;
   30: "FLOATING" ENVIRONMENT? [IF]
   31:     [IF]
   32:         "FLOATING-STACK" ENVIRONMENT? [IF]
   33:             [IF]
   34:                 TRUE
   35:             [ELSE]
   36:                 FALSE
   37:             [THEN]
   38:         [ELSE] \ WE DON'T KNOW WHETHER THE FP STACK IS SEPARATE
   39:             TRUE \ SAFER CHOICE TO ASSUME IT IS
   40:         [THEN]  
   41:     [ELSE]
   42:         FALSE
   43:     [THEN]
   44: [ELSE]
   45:     FALSE
   46: [THEN]
   47: [IF] \ WE HAVE FP WORDS AND A SEPARATE FP STACK
   48:     FVARIABLE FSENSITIVITY -1E-12 FSENSITIVITY F!
   49:     VARIABLE ACTUAL-FDEPTH
   50:     CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT
   51:     VARIABLE START-FDEPTH
   52: 
   53:     : EMPTY-FSTACK ( ... -- ... )
   54:         FDEPTH START-FDEPTH @ < IF
   55:             FDEPTH START-FDEPTH @ SWAP DO 0E LOOP
   56:         THEN
   57:         FDEPTH START-FDEPTH @ > IF
   58:             FDEPTH START-FDEPTH @ DO FDROP LOOP
   59:         THEN ;
   60: 
   61:     : F{ ( -- )
   62:         FDEPTH START-FDEPTH ! ;
   63: 
   64:     : F-> ( ... -- ... )
   65:         FDEPTH DUP ACTUAL-FDEPTH !
   66:         START-FDEPTH @ > IF
   67:             FDEPTH START-FDEPTH @ DO ACTUAL-FRESULTS I FLOATS + F! LOOP
   68:         THEN ;
   69: 
   70:     : F} ( ... -- ... )
   71:         FDEPTH ACTUAL-FDEPTH @ = IF
   72:             FDEPTH START-FDEPTH @ > IF
   73:                 FDEPTH START-FDEPTH @ DO
   74:                     ACTUAL-FRESULTS I FLOATS + F@
   75:                     FSENSITIVITY F@ F~ INVERT IF
   76:                         S" INCORRECT RESULT: " ERROR LEAVE
   77:                     THEN
   78:                 LOOP
   79:             THEN
   80:         ELSE
   81:             S" WRONG NUMBER OF RESULTS: " ERROR
   82:         THEN ;
   83: [ELSE]
   84:     : EMPTY-FSTACK ;
   85:     : F{ ;
   86:     : F-> ;
   87:     : F} ;
   88: [THEN]    
   89: 
   90: : EMPTY-STACK	\ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
   91:     DEPTH START-DEPTH @ < IF
   92:         DEPTH START-DEPTH @ SWAP DO 0 LOOP
   93:     THEN
   94:     DEPTH START-DEPTH @ > IF
   95:         DEPTH START-DEPTH @ DO DROP LOOP
   96:     THEN
   97:     EMPTY-FSTACK ;
   98: 
   99: : ERROR1	\ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
  100: 		\ THE LINE THAT HAD THE ERROR.
  101:    TYPE SOURCE TYPE CR			\ DISPLAY LINE CORRESPONDING TO ERROR
  102:    EMPTY-STACK				\ THROW AWAY EVERY THING ELSE
  103: ;
  104: 
  105: ' ERROR1 ERROR-XT !
  106: 
  107: : {		\ ( -- ) SYNTACTIC SUGAR.
  108:    DEPTH START-DEPTH ! F{ ;
  109: 
  110: : ->		\ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
  111:    DEPTH DUP ACTUAL-DEPTH !		\ RECORD DEPTH
  112:    START-DEPTH @ > IF		\ IF THERE IS SOMETHING ON STACK
  113:        DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
  114:    THEN
  115:    F-> ;
  116: 
  117: : }		\ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
  118: 		\ (ACTUAL) CONTENTS.
  119:    DEPTH ACTUAL-DEPTH @ = IF		\ IF DEPTHS MATCH
  120:       DEPTH START-DEPTH @ > IF		\ IF THERE IS SOMETHING ON THE STACK
  121:          DEPTH START-DEPTH @ DO		\ FOR EACH STACK ITEM
  122: 	    ACTUAL-RESULTS I CELLS + @	\ COMPARE ACTUAL WITH EXPECTED
  123: 	    <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
  124: 	 LOOP
  125:       THEN
  126:    ELSE					\ DEPTH MISMATCH
  127:       S" WRONG NUMBER OF RESULTS: " ERROR
  128:    THEN
  129:    F} ;
  130: 
  131: : TESTING	\ ( -- ) TALKING COMMENT.
  132:    SOURCE VERBOSE @
  133:    IF DUP >R TYPE CR R> >IN !
  134:    ELSE >IN ! DROP
  135:    THEN ;
  136: