swapforth

1
\ To test the ANS File Access 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.11 25 April 2015 S\" in interpretation mode test added
15
\              REQUIRED REQUIRE INCLUDE tests added
16
\              Two S" and/or S\" buffers availability tested
17
\         0.5  1 April 2012  Tests placed in the public domain.
18
\         0.4  22 March 2009 { and } replaced with T{ and }T
19
\         0.3  20 April 2007  ANS Forth words changed to upper case.
20
\              Removed directory test from the filenames.
21
\         0.2  30 Oct 2006 updated following GForth tests to remove
22
\              system dependency on file size, to allow for file
23
\              buffering and to allow for PAD moving around.
24
\         0.1  Oct 2006 First version released.
25

26
\ ------------------------------------------------------------------------------
27
\ The tests are based on John Hayes test program for the core word set
28
\ and requires those files to have been loaded
29

30
\ Words tested in this file are:
31
\     ( BIN CLOSE-FILE CREATE-FILE DELETE-FILE FILE-POSITION FILE-SIZE
32
\     OPEN-FILE R/O R/W READ-FILE READ-LINE REPOSITION-FILE RESIZE-FILE 
33
\     S" SOURCE-ID W/O WRITE-FILE WRITE-LINE 
34
\     FILE-STATUS FLUSH-FILE RENAME-FILE 
35

36
\ Words not tested:
37
\     REFILL INCLUDED INCLUDE-FILE (as these will likely have been
38
\     tested in the execution of the test files)
39
\ ------------------------------------------------------------------------------
40
\ Assumptions, dependencies and notes:
41
\     - tester.fr or ttester.fs has been loaded prior to this file
42
\     - These tests create files in the current directory, if all goes
43
\       well these will be deleted. If something fails they may not be
44
\       deleted. If this is a problem ensure you set a suitable 
45
\       directory before running this test. There is no ANS standard
46
\       way of doing this. Also be aware of the file names used below
47
\       which are:  fatest1.txt, fatest2.txt and fatest3.txt
48
\     - TRUE and FALSE are present from the Core extension word set 
49
\ ------------------------------------------------------------------------------
50

51
TESTING File Access word set
52

53
DECIMAL
54

55
\ ------------------------------------------------------------------------------
56
TESTING CREATE-FILE CLOSE-FILE
57

58
: FN1 S" fatest1.txt" ;
59
VARIABLE FID1
60

61
T{ FN1 R/W CREATE-FILE SWAP FID1 ! -> 0 }T
62
T{ FID1 @ CLOSE-FILE -> 0 }T
63

64
\ ------------------------------------------------------------------------------
65
TESTING OPEN-FILE W/O WRITE-LINE
66

67
: LINE1 S" Line 1" ;
68

69
T{ FN1 W/O OPEN-FILE SWAP FID1 ! -> 0 }T
70
T{ LINE1 FID1 @ WRITE-LINE -> 0 }T
71
T{ FID1 @ CLOSE-FILE -> 0 }T
72

73
\ ------------------------------------------------------------------------------
74
TESTING R/O FILE-POSITION (simple)  READ-LINE 
75

76
200 CONSTANT BSIZE
77
CREATE BUF BSIZE ALLOT
78
VARIABLE #CHARS
79

80
T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T
81
T{ FID1 @ FILE-POSITION -> 0. 0 }T
82
T{ BUF 100 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 SWAP DROP }T
83
T{ BUF #CHARS @ LINE1 COMPARE -> 0 }T
84
T{ FID1 @ CLOSE-FILE -> 0 }T
85

86
\ ------------------------------------------------------------------------------
87
TESTING R/W WRITE-FILE REPOSITION-FILE READ-FILE FILE-POSITION S"
88

89
: LINE2 S" Line 2 blah blah blah" ;
90
: RL1 BUF 100 FID1 @ READ-LINE ;
91
2VARIABLE FP
92

93
T{ FN1 R/W OPEN-FILE SWAP FID1 ! -> 0 }T
94
T{ FID1 @ FILE-SIZE DROP FID1 @ REPOSITION-FILE -> 0 }T
95
T{ FID1 @ FILE-SIZE -> FID1 @ FILE-POSITION }T
96
T{ LINE2 FID1 @ WRITE-FILE -> 0 }T
97
T{ 10. FID1 @ REPOSITION-FILE -> 0 }T
98
T{ FID1 @ FILE-POSITION -> 10. 0 }T
99
T{ 0. FID1 @ REPOSITION-FILE -> 0 }T
100
T{ RL1 -> LINE1 SWAP DROP TRUE 0 }T
101
T{ RL1 ROT DUP #CHARS ! -> TRUE 0 LINE2 SWAP DROP }T
102
T{ BUF #CHARS @ LINE2 COMPARE -> 0 }T
103
T{ RL1 -> 0 FALSE 0 }T
104
T{ FID1 @ FILE-POSITION ROT ROT FP 2! -> 0 }T
105
T{ FP 2@ FID1 @ FILE-SIZE DROP D= -> TRUE }T
106
T{ S" " FID1 @ WRITE-LINE -> 0 }T
107
T{ S" " FID1 @ WRITE-LINE -> 0 }T
108
T{ FP 2@ FID1 @ REPOSITION-FILE -> 0 }T
109
T{ RL1 -> 0 TRUE 0 }T
110
T{ RL1 -> 0 TRUE 0 }T
111
T{ RL1 -> 0 FALSE 0 }T
112
T{ FID1 @ CLOSE-FILE -> 0 }T
113

114
\ ------------------------------------------------------------------------------
115
TESTING BIN READ-FILE FILE-SIZE
116

117
: CBUF BUF BSIZE 0 FILL ;
118
: FN2 S" FATEST2.TXT" ;
119
VARIABLE FID2
120
: SETPAD PAD 50 0 DO I OVER C! CHAR+ LOOP DROP ;
121

122
SETPAD   \ If anything else is defined setpad must be called again
123
         \ as pad may move
124

125
T{ FN2 R/W BIN CREATE-FILE SWAP FID2 ! -> 0 }T
126
T{ PAD 50 FID2 @ WRITE-FILE FID2 @ FLUSH-FILE -> 0 0 }T
127
T{ FID2 @ FILE-SIZE -> 50. 0 }T
128
T{ 0. FID2 @ REPOSITION-FILE -> 0 }T
129
T{ CBUF BUF 29 FID2 @ READ-FILE -> 29 0 }T
130
T{ PAD 29 BUF 29 COMPARE -> 0 }T
131
T{ PAD 30 BUF 30 COMPARE -> 1 }T
132
T{ CBUF BUF 29 FID2 @ READ-FILE -> 21 0 }T
133
T{ PAD 29 + 21 BUF 21 COMPARE -> 0 }T
134
T{ FID2 @ FILE-SIZE DROP FID2 @ FILE-POSITION DROP D= -> TRUE }T
135
T{ BUF 10 FID2 @ READ-FILE -> 0 0 }T
136
T{ FID2 @ CLOSE-FILE -> 0 }T
137

138
\ ------------------------------------------------------------------------------
139
TESTING RESIZE-FILE
140

141
T{ FN2 R/W BIN OPEN-FILE SWAP FID2 ! -> 0 }T
142
T{ 37. FID2 @ RESIZE-FILE -> 0 }T
143
T{ FID2 @ FILE-SIZE -> 37. 0 }T
144
T{ 0. FID2 @ REPOSITION-FILE -> 0 }T
145
T{ CBUF BUF 100 FID2 @ READ-FILE -> 37 0 }T
146
T{ PAD 37 BUF 37 COMPARE -> 0 }T
147
T{ PAD 38 BUF 38 COMPARE -> 1 }T
148
T{ 500. FID2 @ RESIZE-FILE -> 0 }T
149
T{ FID2 @ FILE-SIZE -> 500. 0 }T
150
T{ 0. FID2 @ REPOSITION-FILE -> 0 }T
151
T{ CBUF BUF 100 FID2 @ READ-FILE -> 100 0 }T
152
T{ PAD 37 BUF 37 COMPARE -> 0 }T
153
T{ FID2 @ CLOSE-FILE -> 0 }T
154

155
\ ------------------------------------------------------------------------------
156
TESTING DELETE-FILE
157

158
T{ FN2 DELETE-FILE -> 0 }T
159
T{ FN2 R/W BIN OPEN-FILE SWAP DROP 0= -> FALSE }T
160
T{ FN2 DELETE-FILE 0= -> FALSE }T
161

162
\ ------------------------------------------------------------------------------
163
TESTING multi-line ( comments
164

165
T{ ( 1 2 3
166
4 5 6
167
7 8 9 ) 11 22 33 -> 11 22 33 }T
168

169
\ ------------------------------------------------------------------------------
170
TESTING SOURCE-ID (can only test it does not return 0 or -1)
171

172
T{ SOURCE-ID DUP -1 = SWAP 0= OR -> FALSE }T
173

174
\ ------------------------------------------------------------------------------
175
TESTING RENAME-FILE FILE-STATUS FLUSH-FILE
176

177
: FN3 S" fatest3.txt" ;
178
: >END FID1 @ FILE-SIZE DROP FID1 @ REPOSITION-FILE ;
179

180

181
T{ FN3 DELETE-FILE DROP -> }T
182
T{ FN1 FN3 RENAME-FILE 0= -> TRUE }T
183
T{ FN1 FILE-STATUS SWAP DROP 0= -> FALSE }T
184
T{ FN3 FILE-STATUS SWAP DROP 0= -> TRUE }T  \ Return value is undefined
185
T{ FN3 R/W OPEN-FILE SWAP FID1 ! -> 0 }T
186
T{ >END -> 0 }T
187
T{ S" Final line" fid1 @ WRITE-LINE -> 0 }T
188
T{ FID1 @ FLUSH-FILE -> 0 }T		\ Can only test FLUSH-FILE doesn't fail
189
T{ FID1 @ CLOSE-FILE -> 0 }T
190

191
\ Tidy the test folder
192
T{ fn3 DELETE-FILE DROP -> }T
193

194
\ ------------------------------------------------------------------------------
195
TESTING REQUIRED REQUIRE INCLUDED
196
\ Tests taken from Forth 2012 RfD
197

198
T{ 0
199
  S" required-helper1.fth" REQUIRED
200
  REQUIRE required-helper1.fth
201
  INCLUDE required-helper1.fth
202
  -> 2 }T
203

204
T{ 0
205
  INCLUDE required-helper2.fth
206
  S" required-helper2.fth" REQUIRED
207
  REQUIRE required-helper2.fth
208
  S" required-helper2.fth" INCLUDED
209
  -> 2 }T
210
  
211
\ ------------------------------------------------------------------------------
212
TESTING S\" (Forth 2012 interpretation mode)
213

214
\ S\" in compilation mode already tested in Core Extension tests
215
T{ : SSQ10 S\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" ; -> }T
216
T{ S\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" SSQ10  COMPARE -> 0 }T
217

218
\ ------------------------------------------------------------------------------
219
TESTING two buffers available for S" and/or S\"
220

221
: SSQ11 S" abcd" ;   : SSQ12 S" 1234" ;
222
T{ S" abcd"  S" 1234" SSQ12  COMPARE ROT ROT SSQ11 COMPARE -> 0 0 }T
223
T{ S\" abcd" S\" 1234" SSQ12 COMPARE ROT ROT SSQ11 COMPARE -> 0 0 }T
224
T{ S" abcd"  S\" 1234" SSQ12 COMPARE ROT ROT SSQ11 COMPARE -> 0 0 }T
225
T{ S\" abcd" S" 1234" SSQ12  COMPARE ROT ROT SSQ11 COMPARE -> 0 0 }T
226

227

228
\ ------------------------------------------------------------------------------
229

230
FILE-ERRORS SET-ERROR-COUNT
231

232
CR .( End of File-Access word set tests) CR
233