\ tester 05.8.9 NAB
\ (John Hayes)
\ Date: Mon, 27 Nov 95 13:10:09 PST  
\ with a few mods 05.8.9 by NAB
\ (C) 1995 Johns Hopkins
\ University / Applied Physics
\ Laboratory
\ May be distributed freely as
\ long as this copyright notice
\ remains.
\ Version 1.1

module tester

public:
\ 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 !
true VERBOSE !

\ [NAB]: optionally display tests
variable show-test
false show-test !
\ true show-test !

\ [NAB]: count tests
variable testcount
0 testcount !
private:
: EMPTY-STACK ( ... -- ) \ empty
\ stack: handles underflowed
\ stack too.
   DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN
;

: ERROR ( 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
  ABORT ;

variable start-depth
VARIABLE ACTUAL-DEPTH            \ Stack record
CREATE ACTUAL-RESULTS
20 CELLS  ALLOT
public:
: {  depth start-depth !
\ start-depth added [NAB]
\ show-test added [NAB]
  show-test @ if  source type cr then ;

: -> ( ... -- )
\ Record depth and content of stack.
  DEPTH start-depth @ - DUP ACTUAL-DEPTH ! 
\ Record depth
  ?DUP IF
\ If there is something on stack
    0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ Save them
  THEN ;

: }  1 testcount +!  \ added [NAB]
\ ( ... -- ) Compare stack (expected)
\ contents with saved (actual)
\ contents.
  DEPTH start-depth @ ACTUAL-DEPTH @ + = IF  \ If depths match
    DEPTH start-depth @ - ?DUP IF
\ If there is something on the stack
     0 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 ;

: TESTING ( -- ) \ Talking comment.
   SOURCE VERBOSE @
   IF DUP >R TYPE CR R> >IN !
   ELSE >IN ! DROP
   THEN ;
end-module