From 67d25d837ac55f28a366c0a3b262e439a6e75fc3 Mon Sep 17 00:00:00 2001 From: Dimitri Sokolyuk Date: Sat, 19 Aug 2017 12:15:28 +0200 Subject: Add AmForth --- .../common/lib/forth2012/tester/tester-amforth.frt | 66 ++++++++++++++++++++++ 1 file changed, 66 insertions(+) create mode 100644 amforth-6.5/common/lib/forth2012/tester/tester-amforth.frt (limited to 'amforth-6.5/common/lib/forth2012/tester/tester-amforth.frt') 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 ; + -- cgit v1.2.3