projects / pforth / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Implement REQUIRE (Forth 2012)
[pforth] / fth / t_file.fth
CommitLineData
593eb738
HE		 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
59include? }T{ t_tools.fth
60
61true fp-require-e !
62
63true 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
8bf2fe25 76\ FIXME: stubs for missing definitions
593eb738
HE		 77: file-status 2drop 0 -1 ;
78
593eb738
HE		 79TESTING File Access word set
80
81DECIMAL
82
83TEST{
84
85\ ----------------------------------------------------------------------------
86TESTING CREATE-FILE CLOSE-FILE
87
88: FN1 S" fatest1.txt" ;
89VARIABLE FID1
90
91T{ FN1 R/W CREATE-FILE SWAP FID1 ! -> 0 }T
92T{ FID1 @ CLOSE-FILE -> 0 }T
93
94\ ----------------------------------------------------------------------------
95TESTING OPEN-FILE W/O WRITE-LINE
96
97: LINE1 S" Line 1" ;
98
99T{ FN1 W/O OPEN-FILE SWAP FID1 ! -> 0 }T
100T{ LINE1 FID1 @ WRITE-LINE -> 0 }T
101T{ FID1 @ CLOSE-FILE -> 0 }T
102
103\ ----------------------------------------------------------------------------
104TESTING R/O FILE-POSITION (simple) READ-LINE
105
106200 CONSTANT BSIZE
107CREATE BUF BSIZE ALLOT
108VARIABLE #CHARS
109
110T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T
111T{ FID1 @ FILE-POSITION -> 0. 0 }T
112T{ BUF 100 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 SWAP DROP }T
113T{ BUF #CHARS @ LINE1 S= -> TRUE }T
114T{ FID1 @ CLOSE-FILE -> 0 }T
115
938d9dba
HE		 116\ Test with buffer shorter than line.
117T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T
118T{ FID1 @ FILE-POSITION -> 0. 0 }T
119T{ BUF 0 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 0 }T
120T{ BUF 3 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 3 }T
121T{ BUF #CHARS @ LINE1 DROP 3 S= -> TRUE }T
122T{ BUF 100 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 NIP 3 - }T
123T{ BUF #CHARS @ LINE1 3 /STRING S= -> TRUE }T
124T{ FID1 @ CLOSE-FILE -> 0 }T
125
126\ Test with buffer exactly as long as the line.
127T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T
128T{ FID1 @ FILE-POSITION -> 0. 0 }T
129T{ BUF LINE1 NIP FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 NIP }T
130T{ BUF #CHARS @ LINE1 S= -> TRUE }T
131T{ FID1 @ CLOSE-FILE -> 0 }T
132
593eb738
HE		 133\ ----------------------------------------------------------------------------
134TESTING S" in interpretation mode (compile mode tested in Core tests)
135
136T{ S" abcdef" $" abcdef" S= -> TRUE }T
137T{ S" " $" " S= -> TRUE }T
138T{ S" ghi"$" ghi" S= -> TRUE }T
139
140\ ----------------------------------------------------------------------------
141TESTING R/W WRITE-FILE REPOSITION-FILE READ-FILE FILE-POSITION S"
142
143: LINE2 S" Line 2 blah blah blah" ;
144: RL1 BUF 100 FID1 @ READ-LINE ;
1452VARIABLE FP
146
147T{ FN1 R/W OPEN-FILE SWAP FID1 ! -> 0 }T
148T{ FID1 @ FILE-SIZE DROP FID1 @ REPOSITION-FILE -> 0 }T
149T{ FID1 @ FILE-SIZE -> FID1 @ FILE-POSITION }T
150T{ LINE2 FID1 @ WRITE-FILE -> 0 }T
151T{ 10. FID1 @ REPOSITION-FILE -> 0 }T
152T{ FID1 @ FILE-POSITION -> 10. 0 }T
153T{ 0. FID1 @ REPOSITION-FILE -> 0 }T
154T{ RL1 -> LINE1 SWAP DROP TRUE 0 }T
155T{ RL1 ROT DUP #CHARS ! -> TRUE 0 LINE2 SWAP DROP }T
156T{ BUF #CHARS @ LINE2 S= -> TRUE }T
157T{ RL1 -> 0 FALSE 0 }T
158T{ FID1 @ FILE-POSITION ROT ROT FP 2! -> 0 }T
159T{ FP 2@ FID1 @ FILE-SIZE DROP D= -> TRUE }T
160T{ S" " FID1 @ WRITE-LINE -> 0 }T
161T{ S" " FID1 @ WRITE-LINE -> 0 }T
162T{ FP 2@ FID1 @ REPOSITION-FILE -> 0 }T
163T{ RL1 -> 0 TRUE 0 }T
164T{ RL1 -> 0 TRUE 0 }T
165T{ RL1 -> 0 FALSE 0 }T
166T{ FID1 @ CLOSE-FILE -> 0 }T
167
168\ ----------------------------------------------------------------------------
169TESTING BIN READ-FILE FILE-SIZE
170
171: CBUF BUF BSIZE 0 FILL ;
172: FN2 S" FATEST2.TXT" ;
173VARIABLE FID2
174: SETPAD PAD 50 0 DO I OVER C! CHAR+ LOOP DROP ;
175
176SETPAD \ If anything else is defined setpad must be called again
177 \ as pad may move
178
179T{ FN2 R/W BIN CREATE-FILE SWAP FID2 ! -> 0 }T
180T{ PAD 50 FID2 @ WRITE-FILE FID2 @ FLUSH-FILE -> 0 0 }T
181T{ FID2 @ FILE-SIZE -> 50. 0 }T
182T{ 0. FID2 @ REPOSITION-FILE -> 0 }T
183T{ CBUF BUF 29 FID2 @ READ-FILE -> 29 0 }T
184T{ PAD 29 BUF 29 S= -> TRUE }T
185T{ PAD 30 BUF 30 S= -> FALSE }T
186T{ CBUF BUF 29 FID2 @ READ-FILE -> 21 0 }T
187T{ PAD 29 + 21 BUF 21 S= -> TRUE }T
188T{ FID2 @ FILE-SIZE DROP FID2 @ FILE-POSITION DROP D= -> TRUE }T
189T{ BUF 10 FID2 @ READ-FILE -> 0 0 }T
190T{ FID2 @ CLOSE-FILE -> 0 }T
191
192\ ----------------------------------------------------------------------------
193TESTING RESIZE-FILE
194
195T{ FN2 R/W BIN OPEN-FILE SWAP FID2 ! -> 0 }T
196T{ 37. FID2 @ RESIZE-FILE -> 0 }T
197T{ FID2 @ FILE-SIZE -> 37. 0 }T
198T{ 0. FID2 @ REPOSITION-FILE -> 0 }T
199T{ CBUF BUF 100 FID2 @ READ-FILE -> 37 0 }T
200T{ PAD 37 BUF 37 S= -> TRUE }T
201T{ PAD 38 BUF 38 S= -> FALSE }T
202T{ 500. FID2 @ RESIZE-FILE -> 0 }T
203T{ FID2 @ FILE-SIZE -> 500. 0 }T
204T{ 0. FID2 @ REPOSITION-FILE -> 0 }T
205T{ CBUF BUF 100 FID2 @ READ-FILE -> 100 0 }T
206T{ PAD 37 BUF 37 S= -> TRUE }T
207T{ FID2 @ CLOSE-FILE -> 0 }T
208
209\ ----------------------------------------------------------------------------
210TESTING DELETE-FILE
211
212T{ FN2 DELETE-FILE -> 0 }T
213T{ FN2 R/W BIN OPEN-FILE SWAP DROP 0= -> FALSE }T
214T{ FN2 DELETE-FILE 0= -> FALSE }T
215
216\ ----------------------------------------------------------------------------
fe6f537b
HE		 217TESTING multi-line ( comments
218
219T{ ( 1 2 3
2204 5 6
2217 8 9 ) 11 22 33 -> 11 22 33 }T
222
593eb738
HE		 223\ ----------------------------------------------------------------------------
224TESTING SOURCE-ID (can only test it does not return 0 or -1)
225
226T{ SOURCE-ID DUP -1 = SWAP 0= OR -> FALSE }T
227
228\ ----------------------------------------------------------------------------
229TESTING RENAME-FILE FILE-STATUS FLUSH-FILE
230
231: FN3 S" fatest3.txt" ;
6f3de396 232: >END FID1 @ FILE-SIZE DROP FID1 @ REPOSITION-FILE ;
593eb738
HE		 233
234
235T{ FN3 DELETE-FILE DROP -> }T
236T{ FN1 FN3 RENAME-FILE 0= -> TRUE }T
237T{ FN1 FILE-STATUS SWAP DROP 0= -> FALSE }T
238T{ FN3 FILE-STATUS SWAP DROP 0= -> TRUE }T \ Return value is undefined
239T{ FN3 R/W OPEN-FILE SWAP FID1 ! -> 0 }T
6f3de396
HE		 240T{ >END -> 0 }T
241T{ S" Final line" fid1 @ WRITE-LINE -> 0 }T
593eb738 242
6f3de396
HE		 243T{ FID1 @ FLUSH-FILE -> 0 }T \ Can only test FLUSH-FILE doesn't fail
244T{ FID1 @ CLOSE-FILE -> 0 }T
593eb738
HE		 245
246\ Tidy the test folder
247T{ fn3 DELETE-FILE DROP -> }T
248
5a305613
HE		 249\ ------------------------------------------------------------------------------
250TESTING REQUIRED REQUIRE INCLUDED
251\ Tests taken from Forth 2012 RfD
252
253T{ 0 S" t_required-helper1.fth" REQUIRED
254 REQUIRE t_required-helper1.fth
255 INCLUDE t_required-helper1.fth
256 -> 2 }T
257
258T{ 0 INCLUDE t_required-helper2.fth
259 S" t_required-helper2.fth" REQUIRED
260 REQUIRE t_required-helper2.fth
261 S" t_required-helper2.fth" INCLUDED
262 -> 2 }T
263
593eb738
HE		 264\ ----------------------------------------------------------------------------
265TESTING two buffers available for S" and/or S\" (Forth 2012)
266
267: SSQ12 S" abcd" ; : SSQ13 S" 1234" ;
268T{ S" abcd" S" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T
269\ nyi T{ S\" abcd" S\" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T
270\ nyi T{ S" abcd" S\" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T
271\ nyi T{ S\" abcd" S" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T
272
273
274\ -----------------------------------------------------------------------------
275TESTING SAVE-INPUT and RESTORE-INPUT with a file source
276
277VARIABLE SIV -1 SIV !
278
279: NEVEREXECUTED
280 CR ." This should never be executed" CR
281;
282
283T{ 11111 SAVE-INPUT
284
285SIV @
286
287[IF]
288 TESTING the -[IF]- part is executed
289 0 SIV !
290 RESTORE-INPUT
291 NEVEREXECUTED
292 33333
293[ELSE]
294
295 TESTING the -[ELSE]- part is executed
296 22222
297
298[THEN]
299
300 -> 11111 0 22222 }T \ 0 comes from RESTORE-INPUT
301
302TESTING nested SAVE-INPUT, RESTORE-INPUT and REFILL from a file
303
304: READ_A_LINE
305 REFILL 0=
306 ABORT" REFILL FAILED"
307;
308
309VARIABLE SI_INC 0 SI_INC !
310
311: SI1
312 SI_INC @ >IN +!
313 15 SI_INC !
314;
315
316: S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ;
317
318CREATE 2RES -1 , -1 , \ Don't use 2VARIABLE from Double number word set
319
320: SI2
321 READ_A_LINE
322 READ_A_LINE
323 SAVE-INPUT
324 READ_A_LINE
325 READ_A_LINE
326 S$ EVALUATE 2RES 2!
327 RESTORE-INPUT
328;
329
330\ WARNING: do not delete or insert lines of text after si2 is called
331\ otherwise the next test will fail
332
333T{ SI2
33433333 \ This line should be ignored
3352RES 2@ 44444 \ RESTORE-INPUT should return to this line
336
33755555
338TESTING the nested results
339 -> 0 0 2345 44444 55555 }T
340
341\ End of warning
342
343\ ----------------------------------------------------------------------------
344
345\ CR .( End of File-Access word set tests) CR
346
347}TEST
Fork of 'github/philburk/pforth', a portable ANS-like Forth written in ANSI C.