swapforth

1
\ Additional tests on the the ANS Forth Core word set
2

3
\ This program was written by Gerry Jackson in 2007, 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.11 25 April 2015 Number prefixes # $ % and 'c' character input tested
15
\         0.10 3 August 2014 Test IMMEDIATE doesn't toggle an immediate flag
16
\         0.3  1 April 2012 Tests placed in the public domain.
17
\              Testing multiple ELSE's.
18
\              Further tests on DO +LOOPs.
19
\              Ackermann function added to test RECURSE.
20
\              >IN manipulation in interpreter mode
21
\              Immediate CONSTANTs, VARIABLEs and CREATEd words tests.
22
\              :NONAME with RECURSE moved to core extension tests.
23
\              Parsing behaviour of S" ." and ( tested
24
\         0.2  6 March 2009 { and } replaced with T{ and }T
25
\              Added extra RECURSE tests
26
\         0.1  20 April 2007 Created
27
\ ------------------------------------------------------------------------------
28
\ The tests are based on John Hayes test program for the core word set
29
\
30
\ This file provides some more tests on Core words where the original Hayes
31
\ tests are thought to be incomplete
32
\
33
\ Words tested in this file are:
34
\     DO +LOOP RECURSE ELSE >IN IMMEDIATE
35
\ ------------------------------------------------------------------------------
36
\ Assumptions and dependencies:
37
\     - tester.fr or ttester.fs has been loaded prior to this file
38
\     - core.fr has been loaded so that constants MAX-INT, MIN-INT and
39
\       MAX-UINT are defined
40
\ ------------------------------------------------------------------------------
41

42
DECIMAL
43

44
TESTING DO +LOOP with run-time increment, negative increment, infinite loop
45
\ Contributed by Reinhold Straub
46

47
VARIABLE ITERATIONS
48
VARIABLE INCREMENT
49
: GD7 ( LIMIT START INCREMENT -- )
50
   INCREMENT !
51
   0 ITERATIONS !
52
   DO
53
      1 ITERATIONS +!
54
      I
55
      ITERATIONS @  6 = IF LEAVE THEN
56
      INCREMENT @
57
   +LOOP ITERATIONS @
58
;
59

60
T{  4  4 -1 GD7 -> 4 1 }T
61
T{  1  4 -1 GD7 -> 4 3 2 1 4 }T
62
T{  4  1 -1 GD7 -> 1 0 -1 -2 -3 -4 6 }T
63
T{  4  1  0 GD7 -> 1 1 1 1 1 1 6 }T
64
T{  0  0  0 GD7 -> 0 0 0 0 0 0 6 }T
65
T{  1  4  0 GD7 -> 4 4 4 4 4 4 6 }T
66
T{  1  4  1 GD7 -> 4 5 6 7 8 9 6 }T
67
T{  4  1  1 GD7 -> 1 2 3 3 }T
68
T{  4  4  1 GD7 -> 4 5 6 7 8 9 6 }T
69
T{  2 -1 -1 GD7 -> -1 -2 -3 -4 -5 -6 6 }T
70
T{ -1  2 -1 GD7 -> 2 1 0 -1 4 }T
71
T{  2 -1  0 GD7 -> -1 -1 -1 -1 -1 -1 6 }T
72
T{ -1  2  0 GD7 -> 2 2 2 2 2 2 6 }T
73
T{ -1  2  1 GD7 -> 2 3 4 5 6 7 6 }T
74
T{  2 -1  1 GD7 -> -1 0 1 3 }T
75
T{ -20 30 -10 GD7 -> 30 20 10 0 -10 -20 6 }T
76
T{ -20 31 -10 GD7 -> 31 21 11 1 -9 -19 6 }T
77
T{ -20 29 -10 GD7 -> 29 19 9 -1 -11 5 }T
78

79
\ ------------------------------------------------------------------------------
80
TESTING DO +LOOP with large and small increments
81

82
\ Contributed by Andrew Haley
83

84
MAX-UINT 8 RSHIFT 1+ CONSTANT USTEP
85
USTEP NEGATE CONSTANT -USTEP
86
MAX-INT 7 RSHIFT 1+ CONSTANT STEP
87
STEP NEGATE CONSTANT -STEP
88

89
VARIABLE BUMP
90

91
T{ : GD8 BUMP ! DO 1+ BUMP @ +LOOP ; -> }T
92

93
T{ 0 MAX-UINT 0 USTEP GD8 -> 256 }T
94
T{ 0 0 MAX-UINT -USTEP GD8 -> 256 }T
95

96
T{ 0 MAX-INT MIN-INT STEP GD8 -> 256 }T
97
T{ 0 MIN-INT MAX-INT -STEP GD8 -> 256 }T
98

99
\ Two's complement arithmetic, wraps around modulo wordsize
100
\ Only tested if the Forth system does wrap around, use of conditional
101
\ compilation deliberately avoided
102

103
MAX-INT 1+ MIN-INT = CONSTANT +WRAP?
104
MIN-INT 1- MAX-INT = CONSTANT -WRAP?
105
MAX-UINT 1+ 0=       CONSTANT +UWRAP?
106
0 1- MAX-UINT =      CONSTANT -UWRAP?
107

108
: GD9  ( n limit start step f result -- )
109
   >R IF GD8 ELSE 2DROP 2DROP R@ THEN -> R> }T
110
;
111

112
T{ 0 0 0  USTEP +UWRAP? 256 GD9
113
T{ 0 0 0 -USTEP -UWRAP?   1 GD9
114
T{ 0 MIN-INT MAX-INT  STEP +WRAP? 1 GD9
115
T{ 0 MAX-INT MIN-INT -STEP -WRAP? 1 GD9
116

117
\ ------------------------------------------------------------------------------
118
TESTING DO +LOOP with maximum and minimum increments
119

120
: (-MI) MAX-INT DUP NEGATE + 0= IF MAX-INT NEGATE ELSE -32767 THEN ;
121
(-MI) CONSTANT -MAX-INT
122

123
T{ 0 1 0 MAX-INT GD8  -> 1 }T
124
T{ 0 -MAX-INT NEGATE -MAX-INT OVER GD8  -> 2 }T
125

126
T{ 0 MAX-INT  0 MAX-INT GD8  -> 1 }T
127
T{ 0 MAX-INT  1 MAX-INT GD8  -> 1 }T
128
T{ 0 MAX-INT -1 MAX-INT GD8  -> 2 }T
129
T{ 0 MAX-INT DUP 1- MAX-INT GD8  -> 1 }T
130

131
T{ 0 MIN-INT 1+   0 MIN-INT GD8  -> 1 }T
132
T{ 0 MIN-INT 1+  -1 MIN-INT GD8  -> 1 }T
133
T{ 0 MIN-INT 1+   1 MIN-INT GD8  -> 2 }T
134
T{ 0 MIN-INT 1+ DUP MIN-INT GD8  -> 1 }T
135

136
\ ------------------------------------------------------------------------------
137
TESTING multiple RECURSEs in one colon definition
138

139
: ACK ( m n -- u )    \ Ackermann function, from Rosetta Code
140
   OVER 0= IF  NIP 1+ EXIT  THEN       \ ack(0, n) = n+1
141
   SWAP 1- SWAP                        ( -- m-1 n )
142
   DUP  0= IF  1+  RECURSE EXIT  THEN  \ ack(m, 0) = ack(m-1, 1)
143
   1- OVER 1+ SWAP RECURSE RECURSE     \ ack(m, n) = ack(m-1, ack(m,n-1))
144
;
145

146
T{ 0 0 ACK ->  1 }T
147
T{ 3 0 ACK ->  5 }T
148
T{ 2 4 ACK -> 11 }T
149

150
\ ------------------------------------------------------------------------------
151
TESTING multiple ELSE's in an IF statement
152
\ Discussed on comp.lang.forth and accepted as valid ANS Forth
153

154
: MELSE IF 1 ELSE 2 ELSE 3 ELSE 4 ELSE 5 THEN ;
155
T{ 0 MELSE -> 2 4 }T
156
T{ -1 MELSE -> 1 3 5 }T
157

158
\ ------------------------------------------------------------------------------
159
TESTING manipulation of >IN in interpreter mode
160

161
.( Start ) cr
162
T{ 12345 DEPTH OVER 9 < 34 AND + 3 + >IN ! -> 12345 2345 345 45 5 }T
163
T{ 14145 8115 ?DUP 0= 34 AND >IN +! TUCK MOD 14 >IN ! GCD CALCULATION -> 15 }T
164

165
\ ------------------------------------------------------------------------------
166
TESTING IMMEDIATE with CONSTANT  VARIABLE and CREATE [ ... DOES> ]
167

168
T{ 123 CONSTANT IW1 IMMEDIATE IW1 -> 123 }T
169
T{ : IW2 IW1 LITERAL ; IW2 -> 123 }T
170
T{ VARIABLE IW3 IMMEDIATE 234 IW3 ! IW3 @ -> 234 }T
171
T{ : IW4 IW3 [ @ ] LITERAL ; IW4 -> 234 }T
172
T{ :NONAME [ 345 ] IW3 [ ! ] ; DROP IW3 @ -> 345 }T
173
T{ CREATE IW5 456 , IMMEDIATE -> }T
174
T{ :NONAME IW5 [ @ IW3 ! ] ; DROP IW3 @ -> 456 }T
175
T{ : IW6 CREATE , IMMEDIATE DOES> @ 1+ ; -> }T
176
T{ 111 IW6 IW7 IW7 -> 112 }T
177
T{ : IW8 IW7 LITERAL 1+ ; IW8 -> 113 }T
178
T{ : IW9 CREATE , DOES> @ 2 + IMMEDIATE ; -> }T
179
: FIND-IW BL WORD FIND NIP ;  ( -- 0 | 1 | -1 )
180
T{ 222 IW9 IW10 FIND-IW IW10 -> -1 }T   \ IW10 is not immediate
181
T{ IW10 FIND-IW IW10 -> 224 1 }T        \ IW10 becomes immediate
182

183
\ ------------------------------------------------------------------------------
184
TESTING that IMMEDIATE doesn't toggle a flag
185

186
VARIABLE IT1 0 IT1 !
187
: IT2 1234 IT1 ! ; IMMEDIATE IMMEDIATE
188
T{ : IT3 IT2 ; IT1 @ -> 1234 }T
189

190
\ ------------------------------------------------------------------------------
191
TESTING parsing behaviour of S" ." and (
192
\ which should parse to just beyond the terminating character no space needed
193

194
T{ : GC5 S" A string"2DROP ; GC5 -> }T
195
T{ ( A comment)1234 -> 1234 }T
196
T{ : PB1 CR ." You should see 2345: "." 2345"( A comment) CR ; PB1 -> }T
197
 
198
\ ------------------------------------------------------------------------------
199
TESTING number prefixes # $ % and 'c' character input
200
\ Adapted from the Forth 200X Draft 14.5 document
201

202
VARIABLE OLD-BASE
203
DECIMAL BASE @ OLD-BASE !
204
T{ #1289 -> 1289 }T
205
T{ #12346789. -> 12346789. }T
206
T{ #-1289 -> -1289 }T
207
T{ #-12346789. -> -12346789. }T
208
T{ $12eF -> 4847 }T
209
T{ $12aBcDeF. -> 313249263. }T
210
T{ $-12eF -> -4847 }T
211
T{ $-12AbCdEf. -> -313249263. }T
212
T{ %10010110 -> 150 }T
213
T{ %10010110. -> 150. }T
214
T{ %-10010110 -> -150 }T
215
T{ %-10010110. -> -150. }T
216
T{ 'z' -> 122 }T
217
\ Check BASE is unchanged
218
T{ BASE @ OLD-BASE @ = -> TRUE }T
219

220
\ Repeat in Hex mode
221
16 OLD-BASE ! 16 BASE !
222
T{ #1289 -> 509 }T                  \ 2
223
T{ #12346789. -> BC65A5. }T         \ 2
224
T{ #-1289 -> -509 }T                \ 2
225
T{ #-12346789. -> -BC65A5. }T       \ 2
226
T{ $12eF -> 12EF }T                 \ 2
227
T{ $12aBcDeF. -> 12AbCdeF. }T       \ 2
228
T{ $-12eF -> -12EF }T               \ 2
229
T{ $-12AbCdEf. -> -12ABCDef. }T     \ 2
230
T{ %10010110 -> 96 }T               \ 2
231
T{ %10010110. -> 96. }T             \ 2
232
T{ %-10010110 -> -96 }T             \ 2
233
T{ %-10010110. -> -96. }T           \ 2
234
T{ 'z' -> 7a }T                     \ 2
235
\ Check BASE is unchanged
236
T{ BASE @ OLD-BASE @ = -> TRUE }T   \ 2
237

238
DECIMAL
239
\ Check number prefixes in compile mode
240
T{ : nmp  #8327. $-2cbe %011010111 ''' ; nmp -> 8327. -11454 215 39 }T
241

242

243
\ ------------------------------------------------------------------------------
244

245
CR .( End of additional Core tests) CR
246