swapforth

1
\ To test the ANS Forth Exception word set and extension words
2

3
\ This program was written by Gerry Jackson in 2006, with contributions from
4
\ others where indicated, and is in the public domain - it can be distributed
5
\ and/or modified in any way but please retain this notice.
6

7
\ This program is distributed in the hope that it will be useful,
8
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
9
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
10

11
\ The tests are not claimed to be comprehensive or correct 
12

13
\ ------------------------------------------------------------------------------
14
\ Version 0.4 1 April 2012  Tests placed in the public domain.
15
\         0.3 6 March 2009 { and } replaced with T{ and }T
16
\         0.2 20 April 2007 ANS Forth words changed to upper case
17
\         0.1 Oct 2006 First version released
18

19
\ ------------------------------------------------------------------------------
20
\ The tests are based on John Hayes test program for the core word set
21
\
22
\ Words tested in this file are:
23
\     CATCH THROW ABORT ABORT"
24
\
25
\ ------------------------------------------------------------------------------
26
\ Assumptions and dependencies:
27
\     - the forth system under test throws an exception with throw
28
\       code -13 for a word not found by the text interpreter. The
29
\       undefined word used is $$qweqweqwert$$,  if this happens to be
30
\       a valid word in your system change the definition of t7 below
31
\     - tester.fr or ttester.fs has been loaded prior to this file
32
\     - CASE, OF, ENDOF and ENDCASE from the core extension wordset
33
\       are present and work correctly
34
\ ------------------------------------------------------------------------------
35
TESTING CATCH THROW
36

37
DECIMAL
38

39
: T1 9 ;
40
: C1 1 2 3 ['] T1 CATCH ;
41
T{ C1 -> 1 2 3 9 0 }T			\ No THROW executed
42

43
: T2 8 0 THROW ;
44
: C2 1 2 ['] T2 CATCH ;
45
T{ C2 -> 1 2 8 0 }T				\ 0 THROW does nothing
46

47
: T3 7 8 9 99 THROW ;
48
: C3 1 2 ['] T3 CATCH ;
49
T{ C3 -> 1 2 99 }T				\ Restores stack to CATCH depth
50

51
: T4 1- DUP 0> IF RECURSE ELSE 999 THROW -222 THEN ;
52
: C4 3 4 5 10 ['] T4 CATCH -111 ;
53
T{ C4 -> 3 4 5 0 999 -111 }T	\ Test return stack unwinding
54

55
: T5 2DROP 2DROP 9999 THROW ;
56
: C5 1 2 3 4 ['] T5 CATCH				\ Test depth restored correctly
57
	DEPTH >R DROP 2DROP 2DROP R> ;	\ after stack has been emptied
58
T{ C5 -> 5 }T
59

60
\ ------------------------------------------------------------------------------
61
TESTING ABORT ABORT"
62

63
-1	CONSTANT EXC_ABORT
64
-2 CONSTANT EXC_ABORT"
65
-13 CONSTANT EXC_UNDEF
66
: T6 ABORT ;
67

68
\ The 77 in t10 is necessary for the second ABORT" test as the data stack
69
\ is restored to a depth of 2 when THROW is executed. The 77 ensures the top
70
\ of stack value is known for the results check
71

72
: T10 77 SWAP ABORT" This should not be displayed" ;
73
: C6 CATCH
74
	CASE EXC_ABORT  OF 11 ENDOF
75
	     EXC_ABORT" OF 12 ENDOF
76
       EXC_UNDEF  OF 13 ENDOF
77
	ENDCASE
78
;
79

80
T{ 1 2 ' T6 C6  -> 1 2 11 }T     \ Test that ABORT is caught
81
T{ 3 0 ' T10 C6 -> 3 77 }T	      \ ABORT" does nothing
82
T{ 4 5 ' T10 C6 -> 4 77 12 }T    \ ABORT" caught, no message
83

84
\ ------------------------------------------------------------------------------
85
TESTING a system generated exception
86

87
: T7 S" 333 $$QWEQWEQWERT$$ 334" EVALUATE 335 ;
88
: T8 S" 222 T7 223" EVALUATE 224 ;
89
: T9 S" 111 112 T8 113" EVALUATE 114 ;
90

91
T{ 6 7 ' T9 C6 3 -> 6 7 13 3 }T			\ Test unlinking of sources
92

93
\ ------------------------------------------------------------------------------
94

95
EXCEPTION-ERRORS SET-ERROR-COUNT
96

97
CR .( End of Exception word tests) CR
98

99