1 \ Test PForth FILE wordset
3 \ To test the ANS File Access word set and extension words
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.
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.
13 \ The tests are not claimed to be comprehensive or correct
15 \ ----------------------------------------------------------------------------
16 \ Version 0.13 S" in interpretation mode tested.
17 \ Added SAVE-INPUT RESTORE-INPUT REFILL in a file, (moved from
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.
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
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
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 \ ----------------------------------------------------------------------------
59 include? }T{ t_tools.fth
67 source >in @ /string ." TESTING: " type cr
74 : $" state IF postpone s" else ['] s" execute THEN ; immediate
77 \ FIXME: stubs for missing definition
78 : flush-file drop -1 ;
79 : resize-file drop 2drop -1 ;
80 : rename-file 2drop 2drop -1 ;
81 : file-status 2drop 0 -1 ;
84 TESTING File Access word set
90 \ ----------------------------------------------------------------------------
91 TESTING CREATE-FILE CLOSE-FILE
93 : FN1 S" fatest1.txt" ;
96 T{ FN1 R/W CREATE-FILE SWAP FID1 ! -> 0 }T
97 T{ FID1 @ CLOSE-FILE -> 0 }T
99 \ ----------------------------------------------------------------------------
100 TESTING OPEN-FILE W/O WRITE-LINE
104 T{ FN1 W/O OPEN-FILE SWAP FID1 ! -> 0 }T
105 T{ LINE1 FID1 @ WRITE-LINE -> 0 }T
106 T{ FID1 @ CLOSE-FILE -> 0 }T
108 \ ----------------------------------------------------------------------------
109 TESTING R/O FILE-POSITION (simple) READ-LINE
112 CREATE BUF BSIZE ALLOT
115 T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T
116 T{ FID1 @ FILE-POSITION -> 0. 0 }T
117 T{ BUF 100 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 SWAP DROP }T
118 T{ BUF #CHARS @ LINE1 S= -> TRUE }T
119 T{ FID1 @ CLOSE-FILE -> 0 }T
121 \ Test with buffer shorter than line.
122 T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T
123 T{ FID1 @ FILE-POSITION -> 0. 0 }T
124 T{ BUF 0 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 0 }T
125 T{ BUF 3 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 3 }T
126 T{ BUF #CHARS @ LINE1 DROP 3 S= -> TRUE }T
127 T{ BUF 100 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 NIP 3 - }T
128 T{ BUF #CHARS @ LINE1 3 /STRING S= -> TRUE }T
129 T{ FID1 @ CLOSE-FILE -> 0 }T
131 \ Test with buffer exactly as long as the line.
132 T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T
133 T{ FID1 @ FILE-POSITION -> 0. 0 }T
134 T{ BUF LINE1 NIP FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 NIP }T
135 T{ BUF #CHARS @ LINE1 S= -> TRUE }T
136 T{ FID1 @ CLOSE-FILE -> 0 }T
138 \ ----------------------------------------------------------------------------
139 TESTING S" in interpretation mode (compile mode tested in Core tests)
141 T{ S" abcdef" $" abcdef" S= -> TRUE }T
142 T{ S" " $" " S= -> TRUE }T
143 T{ S" ghi"$" ghi" S= -> TRUE }T
145 \ ----------------------------------------------------------------------------
146 TESTING R/W WRITE-FILE REPOSITION-FILE READ-FILE FILE-POSITION S"
148 : LINE2 S" Line 2 blah blah blah" ;
149 : RL1 BUF 100 FID1 @ READ-LINE ;
152 T{ FN1 R/W OPEN-FILE SWAP FID1 ! -> 0 }T
153 T{ FID1 @ FILE-SIZE DROP FID1 @ REPOSITION-FILE -> 0 }T
154 T{ FID1 @ FILE-SIZE -> FID1 @ FILE-POSITION }T
155 T{ LINE2 FID1 @ WRITE-FILE -> 0 }T
156 T{ 10. FID1 @ REPOSITION-FILE -> 0 }T
157 T{ FID1 @ FILE-POSITION -> 10. 0 }T
158 T{ 0. FID1 @ REPOSITION-FILE -> 0 }T
159 T{ RL1 -> LINE1 SWAP DROP TRUE 0 }T
160 T{ RL1 ROT DUP #CHARS ! -> TRUE 0 LINE2 SWAP DROP }T
161 T{ BUF #CHARS @ LINE2 S= -> TRUE }T
162 T{ RL1 -> 0 FALSE 0 }T
163 T{ FID1 @ FILE-POSITION ROT ROT FP 2! -> 0 }T
164 T{ FP 2@ FID1 @ FILE-SIZE DROP D= -> TRUE }T
165 T{ S" " FID1 @ WRITE-LINE -> 0 }T
166 T{ S" " FID1 @ WRITE-LINE -> 0 }T
167 T{ FP 2@ FID1 @ REPOSITION-FILE -> 0 }T
168 T{ RL1 -> 0 TRUE 0 }T
169 T{ RL1 -> 0 TRUE 0 }T
170 T{ RL1 -> 0 FALSE 0 }T
171 T{ FID1 @ CLOSE-FILE -> 0 }T
173 \ ----------------------------------------------------------------------------
174 TESTING BIN READ-FILE FILE-SIZE
176 : CBUF BUF BSIZE 0 FILL ;
177 : FN2 S" FATEST2.TXT" ;
179 : SETPAD PAD 50 0 DO I OVER C! CHAR+ LOOP DROP ;
181 SETPAD \ If anything else is defined setpad must be called again
184 T{ FN2 R/W BIN CREATE-FILE SWAP FID2 ! -> 0 }T
185 T{ PAD 50 FID2 @ WRITE-FILE FID2 @ FLUSH-FILE -> 0 0 }T
186 T{ FID2 @ FILE-SIZE -> 50. 0 }T
187 T{ 0. FID2 @ REPOSITION-FILE -> 0 }T
188 T{ CBUF BUF 29 FID2 @ READ-FILE -> 29 0 }T
189 T{ PAD 29 BUF 29 S= -> TRUE }T
190 T{ PAD 30 BUF 30 S= -> FALSE }T
191 T{ CBUF BUF 29 FID2 @ READ-FILE -> 21 0 }T
192 T{ PAD 29 + 21 BUF 21 S= -> TRUE }T
193 T{ FID2 @ FILE-SIZE DROP FID2 @ FILE-POSITION DROP D= -> TRUE }T
194 T{ BUF 10 FID2 @ READ-FILE -> 0 0 }T
195 T{ FID2 @ CLOSE-FILE -> 0 }T
197 \ ----------------------------------------------------------------------------
200 T{ FN2 R/W BIN OPEN-FILE SWAP FID2 ! -> 0 }T
201 T{ 37. FID2 @ RESIZE-FILE -> 0 }T
202 T{ FID2 @ FILE-SIZE -> 37. 0 }T
203 T{ 0. FID2 @ REPOSITION-FILE -> 0 }T
204 T{ CBUF BUF 100 FID2 @ READ-FILE -> 37 0 }T
205 T{ PAD 37 BUF 37 S= -> TRUE }T
206 T{ PAD 38 BUF 38 S= -> FALSE }T
207 T{ 500. FID2 @ RESIZE-FILE -> 0 }T
208 T{ FID2 @ FILE-SIZE -> 500. 0 }T
209 T{ 0. FID2 @ REPOSITION-FILE -> 0 }T
210 T{ CBUF BUF 100 FID2 @ READ-FILE -> 100 0 }T
211 T{ PAD 37 BUF 37 S= -> TRUE }T
212 T{ FID2 @ CLOSE-FILE -> 0 }T
214 \ ----------------------------------------------------------------------------
217 T{ FN2 DELETE-FILE -> 0 }T
218 T{ FN2 R/W BIN OPEN-FILE SWAP DROP 0= -> FALSE }T
219 T{ FN2 DELETE-FILE 0= -> FALSE }T
221 \ ----------------------------------------------------------------------------
222 \ TESTING multi-line ( comments
226 \ 7 8 9 ) 11 22 33 -> 11 22 33 }T
228 \ ----------------------------------------------------------------------------
229 TESTING SOURCE-ID (can only test it does not return 0 or -1)
231 T{ SOURCE-ID DUP -1 = SWAP 0= OR -> FALSE }T
233 \ ----------------------------------------------------------------------------
234 TESTING RENAME-FILE FILE-STATUS FLUSH-FILE
236 : FN3 S" fatest3.txt" ;
237 : >END FID1 @ FILE-SIZE .s DROP FID1 @ REPOSITION-FILE ;
240 T{ FN3 DELETE-FILE DROP -> }T
241 T{ FN1 FN3 RENAME-FILE 0= -> TRUE }T
242 T{ FN1 FILE-STATUS SWAP DROP 0= -> FALSE }T
243 T{ FN3 FILE-STATUS SWAP DROP 0= -> TRUE }T \ Return value is undefined
244 T{ FN3 R/W OPEN-FILE SWAP FID1 ! -> 0 }T
245 \ nyi T{ >END -> 0 }T
246 \ nyi T{ S" Final line" fid1 @ WRITE-LINE -> 0 }T
248 \ nyi T{ FID1 @ FLUSH-FILE -> 0 }T \ Can only test FLUSH-FILE doesn't fail
249 \ nyi T{ FID1 @ CLOSE-FILE -> 0 }T
251 \ Tidy the test folder
252 T{ fn3 DELETE-FILE DROP -> }T
254 \ ----------------------------------------------------------------------------
255 TESTING two buffers available for S" and/or S\" (Forth 2012)
257 : SSQ12 S" abcd" ; : SSQ13 S" 1234" ;
258 T{ S" abcd" S" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T
259 \ nyi T{ S\" abcd" S\" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T
260 \ nyi T{ S" abcd" S\" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T
261 \ nyi T{ S\" abcd" S" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T
264 \ -----------------------------------------------------------------------------
265 TESTING SAVE-INPUT and RESTORE-INPUT with a file source
267 VARIABLE SIV -1 SIV !
270 CR ." This should never be executed" CR
278 TESTING the -[IF]- part is executed
285 TESTING the -[ELSE]- part is executed
290 -> 11111 0 22222 }T \ 0 comes from RESTORE-INPUT
292 TESTING nested SAVE-INPUT, RESTORE-INPUT and REFILL from a file
296 ABORT" REFILL FAILED"
299 VARIABLE SI_INC 0 SI_INC !
306 : S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ;
308 CREATE 2RES -1 , -1 , \ Don't use 2VARIABLE from Double number word set
320 \ WARNING: do not delete or insert lines of text after si2 is called
321 \ otherwise the next test will fail
324 33333 \ This line should be ignored
325 2RES 2@ 44444 \ RESTORE-INPUT should return to this line
328 TESTING the nested results
329 -> 0 0 2345 44444 55555 }T
333 \ ----------------------------------------------------------------------------
335 \ CR .( End of File-Access word set tests) CR