Return to tester.fs CVS log

Up to [gforth] / gforth / test

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