swapforth

1
\ To test the ANS Forth Core Extension word set
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.11 25 April 2015
15
\              Added tests for PARSE-NAME HOLDS BUFFER:
16
\              S\" tests added
17
\              DEFER IS ACTION-OF DEFER! DEFER@ tests added
18
\              Empty CASE statement test added
19
\              [COMPILE] tests removed because it is obsolescent in Forth 2012
20
\         0.10 1 August 2014
21
\             Added tests contributed by James Bowman for:
22
\                <> U> 0<> 0> NIP TUCK ROLL PICK 2>R 2R@ 2R>
23
\                HEX WITHIN UNUSED AGAIN MARKER
24
\             Added tests for:
25
\                .R U.R ERASE PAD REFILL SOURCE-ID 
26
\             Removed ABORT from NeverExecuted to enable Win32
27
\             to continue after failure of RESTORE-INPUT.
28
\             Removed max-intx which is no longer used.
29
\         0.7 6 June 2012 Extra CASE test added
30
\         0.6 1 April 2012 Tests placed in the public domain.
31
\             SAVE-INPUT & RESTORE-INPUT tests, position
32
\             of T{ moved so that tests work with ttester.fs
33
\             CONVERT test deleted - obsolete word removed from Forth 200X
34
\             IMMEDIATE VALUEs tested
35
\             RECURSE with :NONAME tested
36
\             PARSE and .( tested
37
\             Parsing behaviour of C" added
38
\         0.5 14 September 2011 Removed the double [ELSE] from the
39
\             initial SAVE-INPUT & RESTORE-INPUT test
40
\         0.4 30 November 2009  max-int replaced with max-intx to
41
\             avoid redefinition warnings.
42
\         0.3  6 March 2009 { and } replaced with T{ and }T
43
\                           CONVERT test now independent of cell size
44
\         0.2  20 April 2007 ANS Forth words changed to upper case
45
\                            Tests qd3 to qd6 by Reinhold Straub
46
\         0.1  Oct 2006 First version released
47
\ -----------------------------------------------------------------------------
48
\ The tests are based on John Hayes test program for the core word set
49

50
\ Words tested in this file are:
51
\     .( .R 0<> 0> 2>R 2R> 2R@ :NONAME <> ?DO AGAIN C" CASE COMPILE, ENDCASE
52
\     ENDOF ERASE FALSE HEX MARKER NIP OF PAD PARSE PICK REFILL
53
\     RESTORE-INPUT ROLL SAVE-INPUT SOURCE-ID TO TRUE TUCK U.R U> UNUSED
54
\     VALUE WITHIN [COMPILE]
55

56
\ Words not tested or partially tested:
57
\     \ because it has been extensively used already and is, hence, unnecessary
58
\     REFILL and SOURCE-ID from the user input device which are not possible
59
\     when testing from a file such as this one
60
\     UNUSED as the value returned is system dependent
61
\     Obsolescent words #TIB CONVERT EXPECT QUERY SPAN TIB as they have been
62
\     removed from the Forth 200X standard
63

64
\ Results from words that output to the user output device have to visually
65
\ checked for correctness. These are .R U.R .(
66

67
\ -----------------------------------------------------------------------------
68
\ Assumptions:
69
\     - tester.fr (or ttester.fs) and core-fr have been included prior to this
70
\       file
71
\ -----------------------------------------------------------------------------
72
TESTING Core Extension words
73

74
DECIMAL
75

76
TESTING TRUE FALSE
77

78
T{ TRUE  -> 0 INVERT }T
79
T{ FALSE -> 0 }T
80

81
\ -----------------------------------------------------------------------------
82
TESTING <> U>   (contributed by James Bowman)
83

84
T{ 0 0 <> -> <FALSE> }T
85
T{ 1 1 <> -> <FALSE> }T
86
T{ -1 -1 <> -> <FALSE> }T
87
T{ 1 0 <> -> <TRUE> }T
88
T{ -1 0 <> -> <TRUE> }T
89
T{ 0 1 <> -> <TRUE> }T
90
T{ 0 -1 <> -> <TRUE> }T
91

92
T{ 0 1 U> -> <FALSE> }T
93
T{ 1 2 U> -> <FALSE> }T
94
T{ 0 MID-UINT U> -> <FALSE> }T
95
T{ 0 MAX-UINT U> -> <FALSE> }T
96
T{ MID-UINT MAX-UINT U> -> <FALSE> }T
97
T{ 0 0 U> -> <FALSE> }T
98
T{ 1 1 U> -> <FALSE> }T
99
T{ 1 0 U> -> <TRUE> }T
100
T{ 2 1 U> -> <TRUE> }T
101
T{ MID-UINT 0 U> -> <TRUE> }T
102
T{ MAX-UINT 0 U> -> <TRUE> }T
103
T{ MAX-UINT MID-UINT U> -> <TRUE> }T
104

105
\ -----------------------------------------------------------------------------
106
TESTING 0<> 0>   (contributed by James Bowman)
107

108
T{ 0 0<> -> <FALSE> }T
109
T{ 1 0<> -> <TRUE> }T
110
T{ 2 0<> -> <TRUE> }T
111
T{ -1 0<> -> <TRUE> }T
112
T{ MAX-UINT 0<> -> <TRUE> }T
113
T{ MIN-INT 0<> -> <TRUE> }T
114
T{ MAX-INT 0<> -> <TRUE> }T
115

116
T{ 0 0> -> <FALSE> }T
117
T{ -1 0> -> <FALSE> }T
118
T{ MIN-INT 0> -> <FALSE> }T
119
T{ 1 0> -> <TRUE> }T
120
T{ MAX-INT 0> -> <TRUE> }T
121

122
\ -----------------------------------------------------------------------------
123
TESTING NIP TUCK ROLL PICK   (contributed by James Bowman)
124

125
T{ 1 2 NIP -> 2 }T
126
T{ 1 2 3 NIP -> 1 3 }T
127

128
T{ 1 2 TUCK -> 2 1 2 }T
129
T{ 1 2 3 TUCK -> 1 3 2 3 }T
130

131
T{ : RO5 100 200 300 400 500 ; -> }T
132
T{ RO5 3 ROLL -> 100 300 400 500 200 }T
133
T{ RO5 2 ROLL -> RO5 ROT }T
134
T{ RO5 1 ROLL -> RO5 SWAP }T
135
T{ RO5 0 ROLL -> RO5 }T
136

137
T{ RO5 2 PICK -> 100 200 300 400 500 300 }T
138
T{ RO5 1 PICK -> RO5 OVER }T
139
T{ RO5 0 PICK -> RO5 DUP }T
140

141
\ -----------------------------------------------------------------------------
142
TESTING 2>R 2R@ 2R>   (contributed by James Bowman)
143

144
T{ : RR0 2>R 100 R> R> ; -> }T
145
T{ 300 400 RR0 -> 100 400 300 }T
146
T{ 200 300 400 RR0 -> 200 100 400 300 }T
147

148
T{ : RR1 2>R 100 2R@ R> R> ; -> }T
149
T{ 300 400 RR1 -> 100 300 400 400 300 }T
150
T{ 200 300 400 RR1 -> 200 100 300 400 400 300 }T
151

152
T{ : RR2 2>R 100 2R> ; -> }T
153
T{ 300 400 RR2 -> 100 300 400 }T
154
T{ 200 300 400 RR2 -> 200 100 300 400 }T
155

156
\ -----------------------------------------------------------------------------
157
TESTING HEX   (contributed by James Bowman)
158

159
T{ BASE @ HEX BASE @ DECIMAL BASE @ - SWAP BASE ! -> 6 }T
160

161
\ -----------------------------------------------------------------------------
162
TESTING WITHIN   (contributed by James Bowman)
163

164
T{ 0 0 0 WITHIN -> <FALSE> }T
165
T{ 0 0 MID-UINT WITHIN -> <TRUE> }T
166
T{ 0 0 MID-UINT+1 WITHIN -> <TRUE> }T
167
T{ 0 0 MAX-UINT WITHIN -> <TRUE> }T
168
T{ 0 MID-UINT 0 WITHIN -> <FALSE> }T
169
T{ 0 MID-UINT MID-UINT WITHIN -> <FALSE> }T
170
T{ 0 MID-UINT MID-UINT+1 WITHIN -> <FALSE> }T
171
T{ 0 MID-UINT MAX-UINT WITHIN -> <FALSE> }T
172
T{ 0 MID-UINT+1 0 WITHIN -> <FALSE> }T
173
T{ 0 MID-UINT+1 MID-UINT WITHIN -> <TRUE> }T
174
T{ 0 MID-UINT+1 MID-UINT+1 WITHIN -> <FALSE> }T
175
T{ 0 MID-UINT+1 MAX-UINT WITHIN -> <FALSE> }T
176
T{ 0 MAX-UINT 0 WITHIN -> <FALSE> }T
177
T{ 0 MAX-UINT MID-UINT WITHIN -> <TRUE> }T
178
T{ 0 MAX-UINT MID-UINT+1 WITHIN -> <TRUE> }T
179
T{ 0 MAX-UINT MAX-UINT WITHIN -> <FALSE> }T
180
T{ MID-UINT 0 0 WITHIN -> <FALSE> }T
181
T{ MID-UINT 0 MID-UINT WITHIN -> <FALSE> }T
182
T{ MID-UINT 0 MID-UINT+1 WITHIN -> <TRUE> }T
183
T{ MID-UINT 0 MAX-UINT WITHIN -> <TRUE> }T
184
T{ MID-UINT MID-UINT 0 WITHIN -> <TRUE> }T
185
T{ MID-UINT MID-UINT MID-UINT WITHIN -> <FALSE> }T
186
T{ MID-UINT MID-UINT MID-UINT+1 WITHIN -> <TRUE> }T
187
T{ MID-UINT MID-UINT MAX-UINT WITHIN -> <TRUE> }T
188
T{ MID-UINT MID-UINT+1 0 WITHIN -> <FALSE> }T
189
T{ MID-UINT MID-UINT+1 MID-UINT WITHIN -> <FALSE> }T
190
T{ MID-UINT MID-UINT+1 MID-UINT+1 WITHIN -> <FALSE> }T
191
T{ MID-UINT MID-UINT+1 MAX-UINT WITHIN -> <FALSE> }T
192
T{ MID-UINT MAX-UINT 0 WITHIN -> <FALSE> }T
193
T{ MID-UINT MAX-UINT MID-UINT WITHIN -> <FALSE> }T
194
T{ MID-UINT MAX-UINT MID-UINT+1 WITHIN -> <TRUE> }T
195
T{ MID-UINT MAX-UINT MAX-UINT WITHIN -> <FALSE> }T
196
T{ MID-UINT+1 0 0 WITHIN -> <FALSE> }T
197
T{ MID-UINT+1 0 MID-UINT WITHIN -> <FALSE> }T
198
T{ MID-UINT+1 0 MID-UINT+1 WITHIN -> <FALSE> }T
199
T{ MID-UINT+1 0 MAX-UINT WITHIN -> <TRUE> }T
200
T{ MID-UINT+1 MID-UINT 0 WITHIN -> <TRUE> }T
201
T{ MID-UINT+1 MID-UINT MID-UINT WITHIN -> <FALSE> }T
202
T{ MID-UINT+1 MID-UINT MID-UINT+1 WITHIN -> <FALSE> }T
203
T{ MID-UINT+1 MID-UINT MAX-UINT WITHIN -> <TRUE> }T
204
T{ MID-UINT+1 MID-UINT+1 0 WITHIN -> <TRUE> }T
205
T{ MID-UINT+1 MID-UINT+1 MID-UINT WITHIN -> <TRUE> }T
206
T{ MID-UINT+1 MID-UINT+1 MID-UINT+1 WITHIN -> <FALSE> }T
207
T{ MID-UINT+1 MID-UINT+1 MAX-UINT WITHIN -> <TRUE> }T
208
T{ MID-UINT+1 MAX-UINT 0 WITHIN -> <FALSE> }T
209
T{ MID-UINT+1 MAX-UINT MID-UINT WITHIN -> <FALSE> }T
210
T{ MID-UINT+1 MAX-UINT MID-UINT+1 WITHIN -> <FALSE> }T
211
T{ MID-UINT+1 MAX-UINT MAX-UINT WITHIN -> <FALSE> }T
212
T{ MAX-UINT 0 0 WITHIN -> <FALSE> }T
213
T{ MAX-UINT 0 MID-UINT WITHIN -> <FALSE> }T
214
T{ MAX-UINT 0 MID-UINT+1 WITHIN -> <FALSE> }T
215
T{ MAX-UINT 0 MAX-UINT WITHIN -> <FALSE> }T
216
T{ MAX-UINT MID-UINT 0 WITHIN -> <TRUE> }T
217
T{ MAX-UINT MID-UINT MID-UINT WITHIN -> <FALSE> }T
218
T{ MAX-UINT MID-UINT MID-UINT+1 WITHIN -> <FALSE> }T
219
T{ MAX-UINT MID-UINT MAX-UINT WITHIN -> <FALSE> }T
220
T{ MAX-UINT MID-UINT+1 0 WITHIN -> <TRUE> }T
221
T{ MAX-UINT MID-UINT+1 MID-UINT WITHIN -> <TRUE> }T
222
T{ MAX-UINT MID-UINT+1 MID-UINT+1 WITHIN -> <FALSE> }T
223
T{ MAX-UINT MID-UINT+1 MAX-UINT WITHIN -> <FALSE> }T
224
T{ MAX-UINT MAX-UINT 0 WITHIN -> <TRUE> }T
225
T{ MAX-UINT MAX-UINT MID-UINT WITHIN -> <TRUE> }T
226
T{ MAX-UINT MAX-UINT MID-UINT+1 WITHIN -> <TRUE> }T
227
T{ MAX-UINT MAX-UINT MAX-UINT WITHIN -> <FALSE> }T
228

229
T{ MIN-INT MIN-INT MIN-INT WITHIN -> <FALSE> }T
230
T{ MIN-INT MIN-INT 0 WITHIN -> <TRUE> }T
231
T{ MIN-INT MIN-INT 1 WITHIN -> <TRUE> }T
232
T{ MIN-INT MIN-INT MAX-INT WITHIN -> <TRUE> }T
233
T{ MIN-INT 0 MIN-INT WITHIN -> <FALSE> }T
234
T{ MIN-INT 0 0 WITHIN -> <FALSE> }T
235
T{ MIN-INT 0 1 WITHIN -> <FALSE> }T
236
T{ MIN-INT 0 MAX-INT WITHIN -> <FALSE> }T
237
T{ MIN-INT 1 MIN-INT WITHIN -> <FALSE> }T
238
T{ MIN-INT 1 0 WITHIN -> <TRUE> }T
239
T{ MIN-INT 1 1 WITHIN -> <FALSE> }T
240
T{ MIN-INT 1 MAX-INT WITHIN -> <FALSE> }T
241
T{ MIN-INT MAX-INT MIN-INT WITHIN -> <FALSE> }T
242
T{ MIN-INT MAX-INT 0 WITHIN -> <TRUE> }T
243
T{ MIN-INT MAX-INT 1 WITHIN -> <TRUE> }T
244
T{ MIN-INT MAX-INT MAX-INT WITHIN -> <FALSE> }T
245
T{ 0 MIN-INT MIN-INT WITHIN -> <FALSE> }T
246
T{ 0 MIN-INT 0 WITHIN -> <FALSE> }T
247
T{ 0 MIN-INT 1 WITHIN -> <TRUE> }T
248
T{ 0 MIN-INT MAX-INT WITHIN -> <TRUE> }T
249
T{ 0 0 MIN-INT WITHIN -> <TRUE> }T
250
T{ 0 0 0 WITHIN -> <FALSE> }T
251
T{ 0 0 1 WITHIN -> <TRUE> }T
252
T{ 0 0 MAX-INT WITHIN -> <TRUE> }T
253
T{ 0 1 MIN-INT WITHIN -> <FALSE> }T
254
T{ 0 1 0 WITHIN -> <FALSE> }T
255
T{ 0 1 1 WITHIN -> <FALSE> }T
256
T{ 0 1 MAX-INT WITHIN -> <FALSE> }T
257
T{ 0 MAX-INT MIN-INT WITHIN -> <FALSE> }T
258
T{ 0 MAX-INT 0 WITHIN -> <FALSE> }T
259
T{ 0 MAX-INT 1 WITHIN -> <TRUE> }T
260
T{ 0 MAX-INT MAX-INT WITHIN -> <FALSE> }T
261
T{ 1 MIN-INT MIN-INT WITHIN -> <FALSE> }T
262
T{ 1 MIN-INT 0 WITHIN -> <FALSE> }T
263
T{ 1 MIN-INT 1 WITHIN -> <FALSE> }T
264
T{ 1 MIN-INT MAX-INT WITHIN -> <TRUE> }T
265
T{ 1 0 MIN-INT WITHIN -> <TRUE> }T
266
T{ 1 0 0 WITHIN -> <FALSE> }T
267
T{ 1 0 1 WITHIN -> <FALSE> }T
268
T{ 1 0 MAX-INT WITHIN -> <TRUE> }T
269
T{ 1 1 MIN-INT WITHIN -> <TRUE> }T
270
T{ 1 1 0 WITHIN -> <TRUE> }T
271
T{ 1 1 1 WITHIN -> <FALSE> }T
272
T{ 1 1 MAX-INT WITHIN -> <TRUE> }T
273
T{ 1 MAX-INT MIN-INT WITHIN -> <FALSE> }T
274
T{ 1 MAX-INT 0 WITHIN -> <FALSE> }T
275
T{ 1 MAX-INT 1 WITHIN -> <FALSE> }T
276
T{ 1 MAX-INT MAX-INT WITHIN -> <FALSE> }T
277
T{ MAX-INT MIN-INT MIN-INT WITHIN -> <FALSE> }T
278
T{ MAX-INT MIN-INT 0 WITHIN -> <FALSE> }T
279
T{ MAX-INT MIN-INT 1 WITHIN -> <FALSE> }T
280
T{ MAX-INT MIN-INT MAX-INT WITHIN -> <FALSE> }T
281
T{ MAX-INT 0 MIN-INT WITHIN -> <TRUE> }T
282
T{ MAX-INT 0 0 WITHIN -> <FALSE> }T
283
T{ MAX-INT 0 1 WITHIN -> <FALSE> }T
284
T{ MAX-INT 0 MAX-INT WITHIN -> <FALSE> }T
285
T{ MAX-INT 1 MIN-INT WITHIN -> <TRUE> }T
286
T{ MAX-INT 1 0 WITHIN -> <TRUE> }T
287
T{ MAX-INT 1 1 WITHIN -> <FALSE> }T
288
T{ MAX-INT 1 MAX-INT WITHIN -> <FALSE> }T
289
T{ MAX-INT MAX-INT MIN-INT WITHIN -> <TRUE> }T
290
T{ MAX-INT MAX-INT 0 WITHIN -> <TRUE> }T
291
T{ MAX-INT MAX-INT 1 WITHIN -> <TRUE> }T
292
T{ MAX-INT MAX-INT MAX-INT WITHIN -> <FALSE> }T
293

294
\ -----------------------------------------------------------------------------
295
TESTING UNUSED  (contributed by James Bowman & Peter Knaggs)
296

297
T{ UNUSED DROP -> }T                  
298
T{ ALIGN UNUSED 0 , UNUSED CELL+ = -> TRUE }T
299
T{ UNUSED 0 C, UNUSED CHAR+ = -> TRUE }T  \ aligned -> unaligned
300
T{ UNUSED 0 C, UNUSED CHAR+ = -> TRUE }T  \ unaligned -> ?
301

302
\ -----------------------------------------------------------------------------
303
TESTING AGAIN   (contributed by James Bowman)
304

305
T{ : AG0 701 BEGIN DUP 7 MOD 0= IF EXIT THEN 1+ AGAIN ; -> }T
306
T{ AG0 -> 707 }T
307

308
\ -----------------------------------------------------------------------------
309
TESTING MARKER   (contributed by James Bowman)
310

311
T{ : MA? BL WORD FIND NIP 0<> ; -> }T
312
T{ MARKER MA0 -> }T
313
T{ : MA1 111 ; -> }T
314
T{ MARKER MA2 -> }T
315
T{ : MA1 222 ; -> }T
316
T{ MA? MA0 MA? MA1 MA? MA2 -> <TRUE> <TRUE> <TRUE> }T
317
T{ MA1 MA2 MA1 -> 222 111 }T
318
T{ MA? MA0 MA? MA1 MA? MA2 -> <TRUE> <TRUE> <FALSE> }T
319
T{ MA0 -> }T
320
T{ MA? MA0 MA? MA1 MA? MA2 -> <FALSE> <FALSE> <FALSE> }T
321

322
\ -----------------------------------------------------------------------------
323
TESTING ?DO
324

325
: QD ?DO I LOOP ;
326
T{ 789 789 QD -> }T
327
T{ -9876 -9876 QD -> }T
328
T{ 5 0 QD -> 0 1 2 3 4 }T
329

330
: QD1 ?DO I 10 +LOOP ;
331
T{ 50 1 QD1 -> 1 11 21 31 41 }T
332
T{ 50 0 QD1 -> 0 10 20 30 40 }T
333

334
: QD2 ?DO I 3 > IF LEAVE ELSE I THEN LOOP ;
335
T{ 5 -1 QD2 -> -1 0 1 2 3 }T
336

337
: QD3 ?DO I 1 +LOOP ;
338
T{ 4  4 QD3 -> }T
339
T{ 4  1 QD3 -> 1 2 3 }T
340
T{ 2 -1 QD3 -> -1 0 1 }T
341

342
: QD4 ?DO I -1 +LOOP ;
343
T{  4 4 QD4 -> }T
344
T{  1 4 QD4 -> 4 3 2 1 }T
345
T{ -1 2 QD4 -> 2 1 0 -1 }T
346

347
: QD5 ?DO I -10 +LOOP ;
348
T{   1 50 QD5 -> 50 40 30 20 10 }T
349
T{   0 50 QD5 -> 50 40 30 20 10 0 }T
350
T{ -25 10 QD5 -> 10 0 -10 -20 }T
351

352
VARIABLE ITERS
353
VARIABLE INCRMNT
354

355
: QD6 ( limit start increment -- )
356
   INCRMNT !
357
   0 ITERS !
358
   ?DO
359
      1 ITERS +!
360
      I
361
      ITERS @  6 = IF LEAVE THEN
362
      INCRMNT @
363
   +LOOP ITERS @
364
;
365

366
T{  4  4 -1 QD6 -> 0 }T
367
T{  1  4 -1 QD6 -> 4 3 2 1 4 }T
368
T{  4  1 -1 QD6 -> 1 0 -1 -2 -3 -4 6 }T
369
T{  4  1  0 QD6 -> 1 1 1 1 1 1 6 }T
370
T{  0  0  0 QD6 -> 0 }T
371
T{  1  4  0 QD6 -> 4 4 4 4 4 4 6 }T
372
T{  1  4  1 QD6 -> 4 5 6 7 8 9 6 }T
373
T{  4  1  1 QD6 -> 1 2 3 3 }T
374
T{  4  4  1 QD6 -> 0 }T
375
T{  2 -1 -1 QD6 -> -1 -2 -3 -4 -5 -6 6 }T
376
T{ -1  2 -1 QD6 -> 2 1 0 -1 4 }T
377
T{  2 -1  0 QD6 -> -1 -1 -1 -1 -1 -1 6 }T
378
T{ -1  2  0 QD6 -> 2 2 2 2 2 2 6 }T
379
T{ -1  2  1 QD6 -> 2 3 4 5 6 7 6 }T
380
T{  2 -1  1 QD6 -> -1 0 1 3 }T
381

382
\ -----------------------------------------------------------------------------
383
TESTING BUFFER:
384

385
T{ 8 BUFFER: BUF:TEST -> }T
386
T{ BUF:TEST DUP ALIGNED = -> TRUE }T
387
T{ 111 BUF:TEST ! 222 BUF:TEST CELL+ ! -> }T
388
T{ BUF:TEST @ BUF:TEST CELL+ @ -> 111 222 }T
389

390
\ -----------------------------------------------------------------------------
391
TESTING VALUE TO
392

393
T{ 111 VALUE VAL1 -999 VALUE VAL2 -> }T
394
T{ VAL1 -> 111 }T
395
T{ VAL2 -> -999 }T
396
T{ 222 TO VAL1 -> }T
397
T{ VAL1 -> 222 }T
398
T{ : VD1 VAL1 ; -> }T
399
T{ VD1 -> 222 }T
400
T{ : VD2 TO VAL2 ; -> }T
401
T{ VAL2 -> -999 }T
402
T{ -333 VD2 -> }T
403
T{ VAL2 -> -333 }T
404
T{ VAL1 -> 222 }T
405
T{ 123 VALUE VAL3 IMMEDIATE VAL3 -> 123 }T
406
T{ : VD3 VAL3 LITERAL ; VD3 -> 123 }T
407

408
\ -----------------------------------------------------------------------------
409
TESTING CASE OF ENDOF ENDCASE
410

411
: CS1 CASE 1 OF 111 ENDOF
412
           2 OF 222 ENDOF
413
           3 OF 333 ENDOF
414
           >R 999 R>
415
      ENDCASE
416
;
417

418
T{ 1 CS1 -> 111 }T
419
T{ 2 CS1 -> 222 }T
420
T{ 3 CS1 -> 333 }T
421
T{ 4 CS1 -> 999 }T
422

423
\ Nested CASE's
424

425
: CS2 >R CASE -1 OF CASE R@ 1 OF 100 ENDOF
426
                            2 OF 200 ENDOF
427
                           >R -300 R>
428
                    ENDCASE
429
                 ENDOF
430
              -2 OF CASE R@ 1 OF -99  ENDOF
431
                            >R -199 R>
432
                    ENDCASE
433
                 ENDOF
434
                 >R 299 R>
435
         ENDCASE R> DROP
436
;
437

438
T{ -1 1 CS2 ->  100 }T
439
T{ -1 2 CS2 ->  200 }T
440
T{ -1 3 CS2 -> -300 }T
441
T{ -2 1 CS2 -> -99  }T
442
T{ -2 2 CS2 -> -199 }T
443
T{  0 2 CS2 ->  299 }T
444

445
\ Boolean short circuiting using CASE
446

447
: CS3  ( N1 -- N2 )
448
   CASE 1- FALSE OF 11 ENDOF
449
        1- FALSE OF 22 ENDOF
450
        1- FALSE OF 33 ENDOF
451
        44 SWAP
452
   ENDCASE
453
;
454

455
T{ 1 CS3 -> 11 }T
456
T{ 2 CS3 -> 22 }T
457
T{ 3 CS3 -> 33 }T
458
T{ 9 CS3 -> 44 }T
459

460
\ Empty CASE statements with/without default
461

462
T{ : CS4 CASE ENDCASE ; 1 CS4 -> }T
463
T{ : CS5 CASE 2 SWAP ENDCASE ; 1 CS5 -> 2 }T
464
T{ : CS6 CASE 1 OF ENDOF 2 ENDCASE ; 1 CS6 -> }T
465
T{ : CS7 CASE 3 OF ENDOF 2 ENDCASE ; 1 CS7 -> 1 }T
466

467
\ -----------------------------------------------------------------------------
468
TESTING :NONAME RECURSE
469

470
VARIABLE NN1
471
VARIABLE NN2
472
:NONAME 1234 ; NN1 !
473
:NONAME 9876 ; NN2 !
474
T{ NN1 @ EXECUTE -> 1234 }T
475
T{ NN2 @ EXECUTE -> 9876 }T
476

477
T{ :NONAME ( n -- 0,1,..n ) DUP IF DUP >R 1- RECURSE R> THEN ;
478
   CONSTANT RN1 -> }T
479
T{ 0 RN1 EXECUTE -> 0 }T
480
T{ 4 RN1 EXECUTE -> 0 1 2 3 4 }T
481

482
:NONAME  ( n -- n1 )    \ Multiple RECURSEs in one definition
483
   1- DUP
484
   CASE 0 OF EXIT ENDOF
485
        1 OF 11 SWAP RECURSE ENDOF
486
        2 OF 22 SWAP RECURSE ENDOF
487
        3 OF 33 SWAP RECURSE ENDOF
488
        DROP ABS RECURSE EXIT
489
   ENDCASE
490
; CONSTANT RN2
491

492
T{  1 RN2 EXECUTE -> 0 }T
493
T{  2 RN2 EXECUTE -> 11 0 }T
494
T{  4 RN2 EXECUTE -> 33 22 11 0 }T
495
T{ 25 RN2 EXECUTE -> 33 22 11 0 }T
496

497
\ -----------------------------------------------------------------------------
498
TESTING C"
499

500
T{ : CQ1 C" 123" ; -> }T
501
T{ CQ1 COUNT EVALUATE -> 123 }T
502
T{ : CQ2 C" " ; -> }T
503
T{ CQ2 COUNT EVALUATE -> }T
504
T{ : CQ3 C" 2345"COUNT EVALUATE ; CQ3 -> 2345 }T
505

506
\ -----------------------------------------------------------------------------
507
TESTING COMPILE,
508

509
:NONAME DUP + ; CONSTANT DUP+
510
T{ : Q DUP+ COMPILE, ; -> }T
511
T{ : AS1 [ Q ] ; -> }T
512
T{ 123 AS1 -> 246 }T
513

514
\ -----------------------------------------------------------------------------
515
\ Cannot automatically test SAVE-INPUT and RESTORE-INPUT from a console source
516

517
TESTING SAVE-INPUT and RESTORE-INPUT with a file source
518

519
0 [IF]
520
VARIABLE SIV -1 SIV !
521

522
: NEVEREXECUTED
523
	CR ." This should never be executed" CR
524
;
525

526
T{ 11111 SAVE-INPUT
527

528
SIV @
529

530
[IF]
531
	0 SIV !
532
	RESTORE-INPUT
533
	NEVEREXECUTED
534
	33333
535
[ELSE]
536

537
TESTING the -[ELSE]- part is executed
538
22222
539

540
[THEN]
541

542
   -> 11111 0 22222 }T	\ 0 comes from RESTORE-INPUT
543

544
TESTING SAVE-INPUT and RESTORE-INPUT with a string source
545

546
VARIABLE SI_INC 0 SI_INC !
547

548
: SI1
549
	SI_INC @ >IN +!
550
	15 SI_INC !
551
;
552

553
: S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ;
554

555
T{ S$ EVALUATE SI_INC @ -> 0 2345 15 }T
556

557
TESTING nested SAVE-INPUT, RESTORE-INPUT and REFILL from a file
558

559
: READ_A_LINE
560
	REFILL 0=
561
	ABORT" REFILL FAILED"
562
;
563

564
0 SI_INC !
565

566
2VARIABLE 2RES -1. 2RES 2!
567

568
: SI2
569
	READ_A_LINE
570
	READ_A_LINE
571
	SAVE-INPUT
572
	READ_A_LINE
573
	READ_A_LINE
574
	S$ EVALUATE 2RES 2!
575
	RESTORE-INPUT
576
;
577

578
\ WARNING: do not delete or insert lines of text after si2 is called
579
\ otherwise the next test will fail
580

581
T{ SI2
582
33333					\ This line should be ignored
583
2RES 2@ 44444		\ RESTORE-INPUT should return to this line
584

585
55555
586
TESTING the nested results
587
 -> 0 0 2345 44444 55555 }T
588

589
\ End of warning
590
[THEN]
591

592
\ -----------------------------------------------------------------------------
593
TESTING .(
594

595
CR CR .( Output from .() 
596
T{ CR .( You should see -9876: ) -9876 . -> }T
597
T{ CR .( and again: ).( -9876)CR -> }T
598

599
CR CR .( On the next 2 lines you should see First then Second messages:)
600
T{ : DOTP  CR ." Second message via ." [CHAR] " EMIT    \ Check .( is immediate
601
     [ CR ] .( First message via .( ) ; dotp -> }T
602
CR CR
603
T{ : IMM? BL WORD FIND NIP ; IMM? .( -> 1 }T
604

605
\ -----------------------------------------------------------------------------
606
TESTING .R and U.R - has to handle different cell sizes
607

608
\ Create some large integers
609
MAX-INT 73 79 */ CONSTANT LI1
610
MIN-INT 71 73 */ CONSTANT LI2
611

612
LI1 0 <# #S #> NIP CONSTANT LENLI1
613

614
: (.R&U.R)  ( u1 u2 -- )  \ u1 <= string length, u2 is required indentation
615
   TUCK + >R
616
   LI1 OVER SPACES  . CR R@    LI1 SWAP  .R CR
617
   LI2 OVER SPACES  . CR R@ 1+ LI2 SWAP  .R CR
618
   LI1 OVER SPACES U. CR R@    LI1 SWAP U.R CR
619
   LI2 SWAP SPACES U. CR R>    LI2 SWAP U.R CR
620
;
621

622
: .R&U.R  ( -- )
623
   CR ." You should see lines duplicated:" CR
624
   ." indented by 0 spaces" CR 0      0 (.R&U.R) CR
625
   ." indented by 0 spaces" CR LENLI1 0 (.R&U.R) CR \ Just fits required width
626
   ." indented by 5 spaces" CR LENLI1 5 (.R&U.R) CR
627
;
628

629
CR CR .( Output from .R and U.R)
630
T{ .R&U.R -> }T
631

632
\ -----------------------------------------------------------------------------
633
TESTING PAD ERASE
634
\ Must handle different size characters i.e. 1 CHARS >= 1 
635

636
84 CONSTANT CHARS/PAD      \ Minimum size of PAD in chars
637
CHARS/PAD CHARS CONSTANT AUS/PAD
638
: CHECKPAD  ( caddr u ch -- f )  \ f = TRUE if u chars = ch
639
   SWAP 0
640
   ?DO
641
      OVER I CHARS + C@ OVER <>
642
      IF 2DROP UNLOOP FALSE EXIT THEN
643
   LOOP  
644
   2DROP TRUE
645
;
646

647
T{ PAD DROP -> }T
648
T{ 0 INVERT PAD C! -> }T
649
T{ PAD C@ CONSTANT MAXCHAR -> }T
650
T{ PAD CHARS/PAD 2DUP MAXCHAR FILL MAXCHAR CHECKPAD -> TRUE }T
651
T{ PAD CHARS/PAD 2DUP CHARS ERASE 0 CHECKPAD -> TRUE }T
652
T{ PAD CHARS/PAD 2DUP MAXCHAR FILL PAD 0 ERASE MAXCHAR CHECKPAD -> TRUE }T
653
T{ PAD 43 CHARS + 9 CHARS ERASE -> }T
654
T{ PAD 43 MAXCHAR CHECKPAD -> TRUE }T
655
T{ PAD 43 CHARS + 9 0 CHECKPAD -> TRUE }T
656
T{ PAD 52 CHARS + CHARS/PAD 52 - MAXCHAR CHECKPAD -> TRUE }T
657

658
\ Check that use of WORD and pictured numeric output do not corrupt PAD
659
\ Minimum size of buffers for these are 33 chars and (2*n)+2 chars respectively
660
\ where n is number of bits per cell
661

662
PAD CHARS/PAD ERASE
663
2 BASE !
664
MAX-UINT MAX-UINT <# #S CHAR 1 DUP HOLD HOLD #> 2DROP
665
DECIMAL
666
BL WORD 12345678123456781234567812345678 DROP
667
T{ PAD CHARS/PAD 0 CHECKPAD -> TRUE }T
668

669
\ -----------------------------------------------------------------------------
670
TESTING PARSE
671

672
T{ CHAR | PARSE 1234| DUP ROT ROT EVALUATE -> 4 1234 }T
673
T{ CHAR ^ PARSE  23 45 ^ DUP ROT ROT EVALUATE -> 7 23 45 }T
674
: PA1 [CHAR] $ PARSE DUP >R PAD SWAP CHARS MOVE PAD R> ;
675
T{ PA1 3456
676
   DUP ROT ROT EVALUATE -> 4 3456 }T
677
T{ CHAR A PARSE A SWAP DROP -> 0 }T
678
T{ CHAR Z PARSE
679
   SWAP DROP -> 0 }T
680
T{ CHAR " PARSE 4567 "DUP ROT ROT EVALUATE -> 5 4567 }T
681
 
682
\ -----------------------------------------------------------------------------
683
TESTING PARSE-NAME  (Forth 2012)
684
\ Adapted from the PARSE-NAME RfD tests
685

686
T{ PARSE-NAME abcd  s" abcd"  COMPARE -> 0 }T        \ No leading spaces
687
T{ PARSE-NAME      abcde s" abcde" COMPARE -> 0 }T   \ Leading spaces
688

689
\ Test empty parse area, new lines are necessary
690
T{ PARSE-NAME
691
  NIP -> 0 }T
692
\ Empty parse area with spaces after PARSE-NAME
693
T{ PARSE-NAME         
694
  NIP -> 0 }T
695

696
T{ : PARSE-NAME-TEST ( "name1" "name2" -- n )
697
    PARSE-NAME PARSE-NAME COMPARE ; -> }T
698
T{ PARSE-NAME-TEST abcd  abcd  -> 0 }T
699
T{ PARSE-NAME-TEST abcd  abcd  -> 0 }T
700
T{ PARSE-NAME-TEST abcde abcdf -> -1 }T
701
T{ PARSE-NAME-TEST abcdf abcde -> 1 }T
702
T{ PARSE-NAME-TEST abcde abcde
703
  -> 0 }T
704
T{ PARSE-NAME-TEST abcde abcde
705
  -> 0 }T
706

707
\ -----------------------------------------------------------------------------
708
TESTING DEFER DEFER@ DEFER! IS ACTION-OF (Forth 2012)
709
\ Adapted from the Forth 200X RfD tests
710

711
T{ DEFER DEFER1 -> }T
712
T{ : MY-DEFER DEFER ; -> }T
713
T{ : IS-DEFER1 IS DEFER1 ; -> }T
714
T{ : ACTION-DEFER1 ACTION-OF DEFER1 ; -> }T
715
T{ : DEF! DEFER! ; -> }T
716
T{ : DEF@ DEFER@ ; -> }T
717

718
T{ ' * ' DEFER1 DEFER! -> }T
719
T{ 2 3 DEFER1 -> 6 }T
720
T{ ' DEFER1 DEFER@ -> ' * }T
721
T{ ' DEFER1 DEF@ -> ' * }T
722
T{ ACTION-OF DEFER1 -> ' * }T
723
T{ ACTION-DEFER1 -> ' * }T
724
T{ ' + IS DEFER1 -> }T
725
T{ 1 2 DEFER1 -> 3 }T
726
T{ ' DEFER1 DEFER@ -> ' + }T
727
T{ ' DEFER1 DEF@ -> ' + }T
728
T{ ACTION-OF DEFER1 -> ' + }T
729
T{ ACTION-DEFER1 -> ' + }T
730
T{ ' - IS-DEFER1 -> }T
731
T{ 1 2 DEFER1 -> -1 }T
732
T{ ' DEFER1 DEFER@ -> ' - }T
733
T{ ' DEFER1 DEF@ -> ' - }T
734
T{ ACTION-OF DEFER1 -> ' - }T
735
T{ ACTION-DEFER1 -> ' - }T
736

737
T{ MY-DEFER DEFER2 -> }T
738
T{ ' DUP IS DEFER2 -> }T
739
T{ 1 DEFER2 -> 1 1 }T
740

741
\ -----------------------------------------------------------------------------
742
TESTING HOLDS  (Forth 2012)
743

744
: HTEST S" Testing HOLDS" ;
745
: HTEST2 S" works" ;
746
: HTEST3 S" Testing HOLDS works 123" ;
747
T{ 0. <#  HTEST HOLDS #> HTEST COMPARE -> 0 }T
748
T{ 123. <# #S BL HOLD HTEST2 HOLDS BL HOLD htest HOLDS #>  HTEST3 COMPARE -> 0 }T
749
T{ : HLD HOLDS ; -> }T
750
T{ 0. <#  HTEST HLD #> HTEST COMPARE -> 0 }T
751

752
\ -----------------------------------------------------------------------------
753
TESTING REFILL SOURCE-ID
754
\ REFILL and SOURCE-ID from the user input device can't be tested from a file,
755
\ can only be tested from a string via EVALUATE
756

757
T{ : RF1  S" REFILL" EVALUATE ; RF1 -> FALSE }T
758
T{ : SID1  S" SOURCE-ID" EVALUATE ; SID1 -> -1 }T
759

760
\ ------------------------------------------------------------------------------
761
TESTING S\"  (Forth 2012 compilation mode)
762
\ Extended the Forth 200X RfD tests
763
\ Note this tests the Core Ext definition of S\" which has unedfined
764
\ interpretation semantics. S\" in interpretation mode is tested in the tests on
765
\ the File-Access word set
766

767
T{ : SSQ1 S\" abc" s" abc" COMPARE ; -> }T  \ No escapes
768
T{ SSQ1 -> 0 }T
769
T{ : SSQ2 S\" " ; SSQ2 SWAP DROP -> 0 }T    \ Empty string
770

771
T{ : SSQ3 S\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" ; -> }T
772
T{ SSQ3 SWAP DROP          ->  20 }T    \ String length
773
T{ SSQ3 DROP            C@ ->   7 }T    \ \a   BEL  Bell
774
T{ SSQ3 DROP  1 CHARS + C@ ->   8 }T    \ \b   BS   Backspace
775
T{ SSQ3 DROP  2 CHARS + C@ ->  27 }T    \ \e   ESC  Escape
776
T{ SSQ3 DROP  3 CHARS + C@ ->  12 }T    \ \f   FF   Form feed
777
T{ SSQ3 DROP  4 CHARS + C@ ->  10 }T    \ \l   LF   Line feed
778
T{ SSQ3 DROP  5 CHARS + C@ ->  13 }T    \ \m        CR of CR/LF pair
779
T{ SSQ3 DROP  6 CHARS + C@ ->  10 }T    \           LF of CR/LF pair
780
T{ SSQ3 DROP  7 CHARS + C@ ->  34 }T    \ \q   "    Double Quote
781
T{ SSQ3 DROP  8 CHARS + C@ ->  13 }T    \ \r   CR   Carriage Return
782
T{ SSQ3 DROP  9 CHARS + C@ ->   9 }T    \ \t   TAB  Horizontal Tab
783
T{ SSQ3 DROP 10 CHARS + C@ ->  11 }T    \ \v   VT   Vertical Tab
784
T{ SSQ3 DROP 11 CHARS + C@ ->  15 }T    \ \x0F      Given Char
785
T{ SSQ3 DROP 12 CHARS + C@ ->  48 }T    \ 0    0    Digit follow on
786
T{ SSQ3 DROP 13 CHARS + C@ ->  31 }T    \ \x1F      Given Char
787
T{ SSQ3 DROP 14 CHARS + C@ ->  97 }T    \ a    a    Hex follow on
788
T{ SSQ3 DROP 15 CHARS + C@ -> 171 }T    \ \xaB      Insensitive Given Char
789
T{ SSQ3 DROP 16 CHARS + C@ -> 120 }T    \ x    x    Non hex follow on
790
T{ SSQ3 DROP 17 CHARS + C@ ->   0 }T    \ \z   NUL  No Character
791
T{ SSQ3 DROP 18 CHARS + C@ ->  34 }T    \ \"   "    Double Quote
792
T{ SSQ3 DROP 19 CHARS + C@ ->  92 }T    \ \\   \    Back Slash
793

794
\ The above does not test \n as this is a system dependent value.
795
\ Check it displays a new line
796
CR .( The next test should display:)
797
CR .( One line...)
798
CR .( another line)
799
T{ : SSQ4 S\" \nOne line...\nanotherLine\n" type ; SSQ4 -> }T
800

801
\ Test bare escapable characters appear as themselves
802
t{ : SSQ5 s\" abeflmnqrtvxz" ; SSQ5 s" abeflmnqrtvxz" COMPARE -> 0 }t
803

804
t{ : SSQ6 s\" a\""2DROP 1111 ; SSQ6 -> 1111 }t \ Parsing behaviour
805

806
T{ : SSQ7  S\" 111 : SSQ8 s\\\" 222\" EVALUATE ; SSQ8 333" EVALUATE ; -> }T
807
T{ SSQ7 -> 111 222 333 }T
808
T{ : SSQ9  S\" 11 : SSQ10 s\\\" \\x32\\x32\" EVALUATE ; SSQ10 33" EVALUATE ; -> }T
809
T{ SSQ9 -> 11 22 33 }T
810

811
\ -----------------------------------------------------------------------------
812
CORE-EXT-ERRORS SET-ERROR-COUNT
813

814
CR .( End of Core Extension word tests) CR
815

816

817