Return to tester.fs CVS log

Up to [gforth] / gforth / test

Now signs after the number prefix are accepted.
Tester can now work with non-empty stacks at the start

    1: \ From: John Hayes S1I
    2: \ Subject: tester.fr
    3: \ Date: Mon, 27 Nov 95 13:10:09 PST  
    4: \ revised by Anton Ertl 2007-08-12
    5: 
    6: \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
    7: \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
    8: \ VERSION 1.1
    9: HEX
   10: 
   11: \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
   12: \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
   13: VARIABLE VERBOSE
   14:    FALSE VERBOSE !
   15: 
   16: : EMPTY-STACK	\ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
   17:    DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ;
   18: 
   19: : ERROR		\ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
   20: 		\ THE LINE THAT HAD THE ERROR.
   21:    TYPE SOURCE TYPE CR			\ DISPLAY LINE CORRESPONDING TO ERROR
   22:    EMPTY-STACK				\ THROW AWAY EVERY THING ELSE
   23: ;
   24: 
   25: VARIABLE ACTUAL-DEPTH			\ STACK RECORD
   26: CREATE ACTUAL-RESULTS 20 CELLS ALLOT
   27: VARIABLE START-DEPTH
   28: 
   29: : {		\ ( -- ) SYNTACTIC SUGAR.
   30:    DEPTH START-DEPTH ! ;
   31: 
   32: : ->		\ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
   33:    DEPTH DUP ACTUAL-DEPTH !		\ RECORD DEPTH
   34:    START-DEPTH @ > IF		\ IF THERE IS SOMETHING ON STACK
   35:        DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
   36:    THEN ;
   37: 
   38: : }		\ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
   39: 		\ (ACTUAL) CONTENTS.
   40:    DEPTH ACTUAL-DEPTH @ = IF		\ IF DEPTHS MATCH
   41:       DEPTH START-DEPTH @ > IF		\ IF THERE IS SOMETHING ON THE STACK
   42:          DEPTH START-DEPTH @ DO		\ FOR EACH STACK ITEM
   43: 	    ACTUAL-RESULTS I CELLS + @	\ COMPARE ACTUAL WITH EXPECTED
   44: 	    <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
   45: 	 LOOP
   46:       THEN
   47:    ELSE					\ DEPTH MISMATCH
   48:       S" WRONG NUMBER OF RESULTS: " ERROR
   49:    THEN ;
   50: 
   51: : TESTING	\ ( -- ) TALKING COMMENT.
   52:    SOURCE VERBOSE @
   53:    IF DUP >R TYPE CR R> >IN !
   54:    ELSE >IN ! DROP
   55:    THEN ;
   56: