aboutsummaryrefslogtreecommitdiff
path: root/amforth-6.5/common/lib/forth2012/tester/tester-amforth.frt
blob: 01d3ca5d7f5effb4fadae838266aa8c0357e2805 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
\ From: John Hayes S1I
\ Subject: tester.fr
\ Date: Mon, 27 Nov 95 13:10:09 PST  

\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
\ VERSION 1.1

\ modified for amforth by Matthias Trute 2007

\ 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
   0 VERBOSE !

variable ACTUAL-DEPTH  \ STACK RECORD
variable START-DEPTH

: EMPTY-STACK	\ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
    depth START-DEPTH @ < if
        depth START-DEPTH @ swap do 0 loop
    then
    depth START-DEPTH @ > if
        depth START-DEPTH @ do drop loop
    then
;

: ERROR		\ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
		\ THE LINE THAT HAD THE ERROR.
   itype source type cr			\ DISPLAY LINE CORRESPONDING TO ERROR
   EMPTY-STACK				\ THROW AWAY EVERY THING ELSE
;

variable ACTUAL-DEPTH			\ STACK RECORD
variable ACTUAL-RESULTS 20 cells allot  \ reserve space in RAM

: t{ \ ( -- ) SYNTACTIC SUGAR.
    depth START-DEPTH !
;

: -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
   depth dup ACTUAL-DEPTH !		\ RECORD DEPTH
   START-DEPTH @ > if		\ IF THERE IS SOMETHING ON STACK
       depth START-DEPTH @ - 0 do ACTUAL-RESULTS i cells + ! loop \ SAVE THEM
   then
;

: }t		\ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
   depth ACTUAL-DEPTH @ = if		\ IF DEPTHS MATCH
      depth START-DEPTH @ > if		\ IF THERE IS SOMETHING ON THE STACK
         depth START-DEPTH @ - 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 ;