]> git.gag.com Git - debian/pforth/blob - fth/t_file.fth
Update release notes for v2.0.0
[debian/pforth] / fth / t_file.fth
1 \ Test PForth FILE wordset
2
3 \ To test the ANS File Access word set and extension words
4
5 \ This program was written by Gerry Jackson in 2006, with contributions from
6 \ others where indicated, and is in the public domain - it can be distributed
7 \ and/or modified in any way but please retain this notice.
8
9 \ This program is distributed in the hope that it will be useful,
10 \ but WITHOUT ANY WARRANTY; without even the implied warranty of
11 \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
12
13 \ The tests are not claimed to be comprehensive or correct
14
15 \ ----------------------------------------------------------------------------
16 \ Version 0.13 S" in interpretation mode tested.
17 \              Added SAVE-INPUT RESTORE-INPUT REFILL in a file, (moved from
18 \              coreexttest.fth).
19 \              Calls to COMPARE replaced with S= (in utilities.fth)
20 \         0.11 25 April 2015 S\" in interpretation mode test added
21 \              REQUIRED REQUIRE INCLUDE tests added
22 \              Two S" and/or S\" buffers availability tested
23 \         0.5  1 April 2012  Tests placed in the public domain.
24 \         0.4  22 March 2009 { and } replaced with T{ and }T
25 \         0.3  20 April 2007  ANS Forth words changed to upper case.
26 \              Removed directory test from the filenames.
27 \         0.2  30 Oct 2006 updated following GForth tests to remove
28 \              system dependency on file size, to allow for file
29 \              buffering and to allow for PAD moving around.
30 \         0.1  Oct 2006 First version released.
31
32 \ ----------------------------------------------------------------------------
33 \ The tests are based on John Hayes test program for the core word set
34 \ and requires those files to have been loaded
35
36 \ Words tested in this file are:
37 \     ( BIN CLOSE-FILE CREATE-FILE DELETE-FILE FILE-POSITION FILE-SIZE
38 \     OPEN-FILE R/O R/W READ-FILE READ-LINE REPOSITION-FILE RESIZE-FILE
39 \     S" S\" SOURCE-ID W/O WRITE-FILE WRITE-LINE
40 \     FILE-STATUS FLUSH-FILE RENAME-FILE SAVE-INPUT RESTORE-INPUT
41 \     REFILL
42
43 \ Words not tested:
44 \     INCLUDED INCLUDE-FILE (as these will likely have been
45 \     tested in the execution of the test files)
46 \ ----------------------------------------------------------------------------
47 \ Assumptions, dependencies and notes:
48 \     - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been
49 \       included prior to this file
50 \     - the Core word set is available and tested
51 \     - These tests create files in the current directory, if all goes
52 \       well these will be deleted. If something fails they may not be
53 \       deleted. If this is a problem ensure you set a suitable
54 \       directory before running this test. There is no ANS standard
55 \       way of doing this. Also be aware of the file names used below
56 \       which are:  fatest1.txt, fatest2.txt and fatest3.txt
57 \ ----------------------------------------------------------------------------
58
59 include? }T{  t_tools.fth
60
61 true fp-require-e !
62
63 false value verbose
64
65 : testing
66     verbose IF
67         source >in @ /string ." TESTING: " type cr
68     THEN
69     source nip >in !
70 ; immediate
71
72 : -> }T{ ;
73 : s= compare 0= ;
74 : $" state IF postpone s" else ['] s" execute THEN ; immediate
75
76 TESTING File Access word set
77
78 DECIMAL
79
80 TEST{
81
82 \ ----------------------------------------------------------------------------
83 TESTING CREATE-FILE CLOSE-FILE
84
85 : FN1 S" fatest1.txt" ;
86 VARIABLE FID1
87
88 T{ FN1 R/W CREATE-FILE SWAP FID1 ! -> 0 }T
89 T{ FID1 @ CLOSE-FILE -> 0 }T
90
91 \ ----------------------------------------------------------------------------
92 TESTING OPEN-FILE W/O WRITE-LINE
93
94 : LINE1 S" Line 1" ;
95
96 T{ FN1 W/O OPEN-FILE SWAP FID1 ! -> 0 }T
97 T{ LINE1 FID1 @ WRITE-LINE -> 0 }T
98 T{ FID1 @ CLOSE-FILE -> 0 }T
99
100 \ ----------------------------------------------------------------------------
101 TESTING R/O FILE-POSITION (simple)  READ-LINE
102
103 200 CONSTANT BSIZE
104 CREATE BUF BSIZE ALLOT
105 VARIABLE #CHARS
106
107 T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T
108 T{ FID1 @ FILE-POSITION -> 0. 0 }T
109 T{ BUF 100 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 SWAP DROP }T
110 T{ BUF #CHARS @ LINE1 S= -> TRUE }T
111 T{ FID1 @ CLOSE-FILE -> 0 }T
112
113 \ Test with buffer shorter than line.
114 T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T
115 T{ FID1 @ FILE-POSITION -> 0. 0 }T
116 T{ BUF 0 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 0 }T
117 T{ BUF 3 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 3 }T
118 T{ BUF #CHARS @ LINE1 DROP 3 S= -> TRUE }T
119 T{ BUF 100 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 NIP 3 - }T
120 T{ BUF #CHARS @ LINE1 3 /STRING S= -> TRUE }T
121 T{ FID1 @ CLOSE-FILE -> 0 }T
122
123 \ Test with buffer exactly as long as the line.
124 T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T
125 T{ FID1 @ FILE-POSITION -> 0. 0 }T
126 T{ BUF LINE1 NIP FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 NIP }T
127 T{ BUF #CHARS @ LINE1 S= -> TRUE }T
128 T{ FID1 @ CLOSE-FILE -> 0 }T
129
130 \ ----------------------------------------------------------------------------
131 TESTING S" in interpretation mode (compile mode tested in Core tests)
132
133 T{ S" abcdef" $" abcdef" S= -> TRUE }T
134 T{ S" " $" " S= -> TRUE }T
135 T{ S" ghi"$" ghi" S= -> TRUE }T
136
137 \ ----------------------------------------------------------------------------
138 TESTING R/W WRITE-FILE REPOSITION-FILE READ-FILE FILE-POSITION S"
139
140 : LINE2 S" Line 2 blah blah blah" ;
141 : RL1 BUF 100 FID1 @ READ-LINE ;
142 2VARIABLE FP
143
144 T{ FN1 R/W OPEN-FILE SWAP FID1 ! -> 0 }T
145 T{ FID1 @ FILE-SIZE DROP FID1 @ REPOSITION-FILE -> 0 }T
146 T{ FID1 @ FILE-SIZE -> FID1 @ FILE-POSITION }T
147 T{ LINE2 FID1 @ WRITE-FILE -> 0 }T
148 T{ 10. FID1 @ REPOSITION-FILE -> 0 }T
149 T{ FID1 @ FILE-POSITION -> 10. 0 }T
150 T{ 0. FID1 @ REPOSITION-FILE -> 0 }T
151 T{ RL1 -> LINE1 SWAP DROP TRUE 0 }T
152 T{ RL1 ROT DUP #CHARS ! -> TRUE 0 LINE2 SWAP DROP }T
153 T{ BUF #CHARS @ LINE2 S= -> TRUE }T
154 T{ RL1 -> 0 FALSE 0 }T
155 T{ FID1 @ FILE-POSITION ROT ROT FP 2! -> 0 }T
156 T{ FP 2@ FID1 @ FILE-SIZE DROP D= -> TRUE }T
157 T{ S" " FID1 @ WRITE-LINE -> 0 }T
158 T{ S" " FID1 @ WRITE-LINE -> 0 }T
159 T{ FP 2@ FID1 @ REPOSITION-FILE -> 0 }T
160 T{ RL1 -> 0 TRUE 0 }T
161 T{ RL1 -> 0 TRUE 0 }T
162 T{ RL1 -> 0 FALSE 0 }T
163 T{ FID1 @ CLOSE-FILE -> 0 }T
164
165 \ ----------------------------------------------------------------------------
166 TESTING BIN READ-FILE FILE-SIZE
167
168 : CBUF BUF BSIZE 0 FILL ;
169 : FN2 S" FATEST2.TXT" ;
170 VARIABLE FID2
171 : SETPAD PAD 50 0 DO I OVER C! CHAR+ LOOP DROP ;
172
173 SETPAD   \ If anything else is defined setpad must be called again
174          \ as pad may move
175
176 T{ FN2 R/W BIN CREATE-FILE SWAP FID2 ! -> 0 }T
177 T{ PAD 50 FID2 @ WRITE-FILE FID2 @ FLUSH-FILE -> 0 0 }T
178 T{ FID2 @ FILE-SIZE -> 50. 0 }T
179 T{ 0. FID2 @ REPOSITION-FILE -> 0 }T
180 T{ CBUF BUF 29 FID2 @ READ-FILE -> 29 0 }T
181 T{ PAD 29 BUF 29 S= -> TRUE }T
182 T{ PAD 30 BUF 30 S= -> FALSE }T
183 T{ CBUF BUF 29 FID2 @ READ-FILE -> 21 0 }T
184 T{ PAD 29 + 21 BUF 21 S= -> TRUE }T
185 T{ FID2 @ FILE-SIZE DROP FID2 @ FILE-POSITION DROP D= -> TRUE }T
186 T{ BUF 10 FID2 @ READ-FILE -> 0 0 }T
187 T{ FID2 @ CLOSE-FILE -> 0 }T
188
189 \ ----------------------------------------------------------------------------
190 TESTING RESIZE-FILE
191
192 T{ FN2 R/W BIN OPEN-FILE SWAP FID2 ! -> 0 }T
193 T{ 37. FID2 @ RESIZE-FILE -> 0 }T
194 T{ FID2 @ FILE-SIZE -> 37. 0 }T
195 T{ 0. FID2 @ REPOSITION-FILE -> 0 }T
196 T{ CBUF BUF 100 FID2 @ READ-FILE -> 37 0 }T
197 T{ PAD 37 BUF 37 S= -> TRUE }T
198 T{ PAD 38 BUF 38 S= -> FALSE }T
199 T{ 500. FID2 @ RESIZE-FILE -> 0 }T
200 T{ FID2 @ FILE-SIZE -> 500. 0 }T
201 T{ 0. FID2 @ REPOSITION-FILE -> 0 }T
202 T{ CBUF BUF 100 FID2 @ READ-FILE -> 100 0 }T
203 T{ PAD 37 BUF 37 S= -> TRUE }T
204 T{ FID2 @ CLOSE-FILE -> 0 }T
205
206 \ ----------------------------------------------------------------------------
207 TESTING DELETE-FILE
208
209 T{ FN2 DELETE-FILE -> 0 }T
210 T{ FN2 R/W BIN OPEN-FILE SWAP DROP 0= -> FALSE }T
211 T{ FN2 DELETE-FILE 0= -> FALSE }T
212
213 \ ----------------------------------------------------------------------------
214 TESTING multi-line ( comments
215
216 T{ ( 1 2 3
217 4 5 6
218 7 8 9 ) 11 22 33 -> 11 22 33 }T
219
220 \ ----------------------------------------------------------------------------
221 TESTING SOURCE-ID (can only test it does not return 0 or -1)
222
223 T{ SOURCE-ID DUP -1 = SWAP 0= OR -> FALSE }T
224
225 \ ----------------------------------------------------------------------------
226 TESTING RENAME-FILE FILE-STATUS FLUSH-FILE
227
228 : FN3 S" fatest3.txt" ;
229 : >END FID1 @ FILE-SIZE DROP FID1 @ REPOSITION-FILE ;
230
231
232 T{ FN3 DELETE-FILE DROP -> }T
233 T{ FN1 FN3 RENAME-FILE 0= -> TRUE }T
234 T{ FN1 FILE-STATUS SWAP DROP 0= -> FALSE }T
235 T{ FN3 FILE-STATUS SWAP DROP 0= -> TRUE }T  \ Return value is undefined
236 T{ FN3 R/W OPEN-FILE SWAP FID1 ! -> 0 }T
237 T{ >END -> 0 }T
238 T{ S" Final line" fid1 @ WRITE-LINE -> 0 }T
239
240 T{ FID1 @ FLUSH-FILE -> 0 }T      \ Can only test FLUSH-FILE doesn't fail
241 T{ FID1 @ CLOSE-FILE -> 0 }T
242
243 \ Tidy the test folder
244 T{ fn3 DELETE-FILE DROP -> }T
245
246 \ ------------------------------------------------------------------------------
247 TESTING REQUIRED REQUIRE INCLUDED
248 \ Tests taken from Forth 2012 RfD
249
250 T{ 0 S" t_required_helper1.fth" REQUIRED
251      REQUIRE t_required_helper1.fth
252      INCLUDE t_required_helper1.fth
253      -> 2 }T
254
255 T{ 0 INCLUDE t_required_helper2.fth
256      S" t_required_helper2.fth" REQUIRED
257      REQUIRE t_required_helper2.fth
258      S" t_required_helper2.fth" INCLUDED
259      -> 2 }T
260
261 \ ----------------------------------------------------------------------------
262
263 T{ : GC4 S" XY" ; }T{   }T
264 T{ GC4 SWAP DROP   }T{  2 }T
265 T{ GC4 DROP DUP C@ SWAP CHAR+ C@  }T{  $ 58  $ 59 }T
266 : GC5 S" A String"2DROP ; \ There is no space between the " and 2DROP
267 T{ GC5 }T{ }T
268
269 \ -----------------------------------------------------------------------------
270 TESTING SAVE-INPUT and RESTORE-INPUT with a file source
271
272 VARIABLE SIV -1 SIV !
273
274 : NEVEREXECUTED
275    CR ." This should never be executed" CR
276 ;
277
278 T{ 11111 SAVE-INPUT
279
280 SIV @
281
282 [IF]
283    TESTING the -[IF]- part is executed
284    0 SIV !
285    RESTORE-INPUT
286    NEVEREXECUTED
287    33333
288 [ELSE]
289
290   TESTING the -[ELSE]- part is executed
291   22222
292
293 [THEN]
294
295    -> 11111 0 22222 }T   \ 0 comes from RESTORE-INPUT
296
297 TESTING nested SAVE-INPUT, RESTORE-INPUT and REFILL from a file
298
299 : READ_A_LINE
300    REFILL 0=
301    ABORT" REFILL FAILED"
302 ;
303
304 VARIABLE SI_INC 0 SI_INC !
305
306 : SI1
307    SI_INC @ >IN +!
308    15 SI_INC !
309 ;
310
311 : S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ;
312
313 CREATE 2RES -1 , -1 ,   \ Don't use 2VARIABLE from Double number word set
314
315 : SI2
316    READ_A_LINE
317    READ_A_LINE
318    SAVE-INPUT
319    READ_A_LINE
320    READ_A_LINE
321    S$ EVALUATE 2RES 2!
322    RESTORE-INPUT
323 ;
324
325 \ WARNING: do not delete or insert lines of text after si2 is called
326 \ otherwise the next test will fail
327
328 T{ SI2
329 33333               \ This line should be ignored
330 2RES 2@ 44444      \ RESTORE-INPUT should return to this line
331
332 55555
333 TESTING the nested results
334  -> 0 0 2345 44444 55555 }T
335
336 \ End of warning
337
338 \ ----------------------------------------------------------------------------
339
340 \ CR .( End of File-Access word set tests) CR
341
342 }TEST