Mercurial > hg > Members > kono > os9 > sbc09

comparison examples_forth/tester.4 @ 57:2088fd998865

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
sbc09 directry clean up
author Shinji KONO <kono@ie.u-ryukyu.ac.jp>
date Mon, 23 Jul 2018 16:07:12 +0900
parents
children
comparison
equal deleted inserted replaced
56:4fa2bdb0c457 57:2088fd998865
1 \ (C) 1993 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
2 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
3 \ VERSION 1.0
4 HEX
5
6 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
7 \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
8 VARIABLE VERBOSE
9 FALSE VERBOSE !
10
11 : EMPTY-STACK \ ( ... -- ) EMPTY STACK.
12 DEPTH ?DUP IF 0 DO DROP LOOP THEN ;
13
14 : ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
15 \ THE LINE THAT HAD THE ERROR.
16 TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR
17 EMPTY-STACK \ THROW AWAY EVERY THING ELSE
18 ;
19
20 VARIABLE ACTUAL-DEPTH \ STACK RECORD
21 CREATE ACTUAL-RESULTS 20 CELLS ALLOT
22
23 : { \ ( -- ) SYNTACTIC SUGAR.
24 ;
25
26 : -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
27 DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH
28 ?DUP IF \ IF THERE IS SOMETHING ON STACK
29 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
30 THEN ;
31
32 : } \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
33 \ (ACTUAL) CONTENTS.
34 DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH
35 DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK
36 0 DO \ FOR EACH STACK ITEM
37 ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED
38 <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
39 LOOP
40 THEN
41 ELSE \ DEPTH MISMATCH
42 S" WRONG NUMBER OF RESULTS: " ERROR
43 THEN ;
44
45 : TESTING \ ( -- ) TALKING COMMENT.
46 SOURCE VERBOSE @
47 IF DUP >R TYPE CR R> >IN !
48 ELSE >IN ! DROP
49 THEN ;