aboutsummaryrefslogtreecommitdiff
path: root/amforth-6.5/common/lib/forth2012/tester/tester-amforth.frt
diff options
context:
space:
mode:
Diffstat (limited to 'amforth-6.5/common/lib/forth2012/tester/tester-amforth.frt')
-rw-r--r--amforth-6.5/common/lib/forth2012/tester/tester-amforth.frt66
1 files changed, 66 insertions, 0 deletions
diff --git a/amforth-6.5/common/lib/forth2012/tester/tester-amforth.frt b/amforth-6.5/common/lib/forth2012/tester/tester-amforth.frt
new file mode 100644
index 0000000..01d3ca5
--- /dev/null
+++ b/amforth-6.5/common/lib/forth2012/tester/tester-amforth.frt
@@ -0,0 +1,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 ;
+