From: Helmut Eller Date: Sun, 1 Jan 2017 11:12:08 +0000 (+0100) Subject: Implement READ-LINE and WRITE-LINE X-Git-Url: http://git.subgeniuskitty.com/pforth/.git/commitdiff_plain/593eb738c871efd888f6c8652991dc2a413c8727 Implement READ-LINE and WRITE-LINE This is implemented on top of READ-FILE and WRITE-FILE which avoids new dependencies in the C code. * fth/file.fth: New file. * fth/loadp4th.fth: Load it. * fth/t_file.fth: New tests. Some tests fail and some are commented out due to missing functionality. There's an actual bug in SAVE-INPUT which I know how to fix. * build/unix/Makefile, build/mingw-crossbuild-linux/Makefile (test): Run test in t_file.fth. --- diff --git a/build/mingw-crossbuild-linux/Makefile b/build/mingw-crossbuild-linux/Makefile index f6f8d68..3305fd9 100644 --- a/build/mingw-crossbuild-linux/Makefile +++ b/build/mingw-crossbuild-linux/Makefile @@ -140,6 +140,7 @@ test: $(PFORTHAPP) wd=$$(pwd); (cd $(FTHDIR); $(WINE) $${wd}/$(PFORTHAPP) -q t_locals.fth) wd=$$(pwd); (cd $(FTHDIR); $(WINE) $${wd}/$(PFORTHAPP) -q t_alloc.fth) wd=$$(pwd); (cd $(FTHDIR); $(WINE) $${wd}/$(PFORTHAPP) -q t_floats.fth) + wd=$$(pwd); (cd $(FTHDIR); $(WINE) $${wd}/$(PFORTHAPP) -q t_file.fth) clean: rm -f $(PFOBJS) $(PFEMBOBJS) diff --git a/build/unix/Makefile b/build/unix/Makefile index 141f855..42819ab 100644 --- a/build/unix/Makefile +++ b/build/unix/Makefile @@ -135,6 +135,7 @@ test: $(PFORTHAPP) wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_locals.fth) wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_alloc.fth) wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_floats.fth) + wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_file.fth) clean: rm -f $(PFOBJS) $(PFEMBOBJS) diff --git a/fth/file.fth b/fth/file.fth new file mode 100644 index 0000000..678a991 --- /dev/null +++ b/fth/file.fth @@ -0,0 +1,83 @@ +\ READ-LINE and WRITE-LINE +\ +\ This file is in the public domain. +\ + +private{ + +10 constant \n +13 constant \r + +\ Unread one char from file FILEID. +: UNREAD ( fileid -- ior ) + { f } + f file-position ( ud ior ) + ?dup + IF nip nip \ IO error + ELSE 1 s>d d- f reposition-file + THEN +; + +\ Read the next available char from file FILEID and if it is a \n then +\ skip it; otherwise unread it. IOR is non-zero if an error occured. +\ C-ADDR is a buffer that can hold at least on char. +: SKIP-\n ( c-addr fileid -- ior ) + { a f } + a 1 f read-file ( u ior ) + ?dup + IF \ Read error? + nip + ELSE ( u ) + 0= + IF \ End of file? + 0 + ELSE + a c@ \n = ( is-it-a-\n? ) + IF 0 + ELSE f unread + THEN + THEN + THEN +; + +\ This is just s\" \n" but s\" isn't yet available. +create (LINE-TERMINATOR) \n c, +: LINE-TERMINATOR ( -- c-addr u ) (line-terminator) 1 ; + +}private + + +\ This treats \n, \r\n, and \r as line terminator. Reading is done +\ one char at a time with READ-FILE hence READ-FILE should probably do +\ some form of buffering for good efficiency. +: READ-LINE ( c-addr u1 fileid -- u2 flag ior ) + { a u f } + u 0 ?DO + a i chars + 1 f read-file ( u ior' ) + ?dup IF nip i false rot UNLOOP EXIT THEN \ Read error? ( u ) + 0= IF i i 0> 0 UNLOOP EXIT THEN \ End of file? ( ) + a i chars + c@ + CASE + \n OF i true 0 UNLOOP EXIT ENDOF + \r OF + \ Detect \r\n + a i 1+ chars + f skip-\n ( ior ) + ?dup IF i false rot UNLOOP EXIT THEN \ IO Error? ( ) + i true 0 UNLOOP EXIT + ENDOF + ENDCASE + LOOP + \ Line doesn't fit in buffer + u true 0 +; + +: WRITE-LINE ( c-addr u fileid -- ior ) + { f } + f write-file ( ior ) + ?dup + IF \ IO error + ELSE line-terminator f write-file + THEN +; + +privatize diff --git a/fth/loadp4th.fth b/fth/loadp4th.fth index 0ce27dc..dd835ce 100644 --- a/fth/loadp4th.fth +++ b/fth/loadp4th.fth @@ -25,6 +25,7 @@ include? fm/mod math.fth include? task-misc2.fth misc2.fth include? [if] condcomp.fth include? save-input save-input.fth +include? read-line file.fth \ load floating point support if basic support is in kernel exists? F* diff --git a/fth/t_file.fth b/fth/t_file.fth new file mode 100644 index 0000000..2817f05 --- /dev/null +++ b/fth/t_file.fth @@ -0,0 +1,320 @@ +\ Test PForth FILE wordset + +\ To test the ANS File Access word set and extension words + +\ This program was written by Gerry Jackson in 2006, with contributions from +\ others where indicated, and is in the public domain - it can be distributed +\ and/or modified in any way but please retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ The tests are not claimed to be comprehensive or correct + +\ ---------------------------------------------------------------------------- +\ Version 0.13 S" in interpretation mode tested. +\ Added SAVE-INPUT RESTORE-INPUT REFILL in a file, (moved from +\ coreexttest.fth). +\ Calls to COMPARE replaced with S= (in utilities.fth) +\ 0.11 25 April 2015 S\" in interpretation mode test added +\ REQUIRED REQUIRE INCLUDE tests added +\ Two S" and/or S\" buffers availability tested +\ 0.5 1 April 2012 Tests placed in the public domain. +\ 0.4 22 March 2009 { and } replaced with T{ and }T +\ 0.3 20 April 2007 ANS Forth words changed to upper case. +\ Removed directory test from the filenames. +\ 0.2 30 Oct 2006 updated following GForth tests to remove +\ system dependency on file size, to allow for file +\ buffering and to allow for PAD moving around. +\ 0.1 Oct 2006 First version released. + +\ ---------------------------------------------------------------------------- +\ The tests are based on John Hayes test program for the core word set +\ and requires those files to have been loaded + +\ Words tested in this file are: +\ ( BIN CLOSE-FILE CREATE-FILE DELETE-FILE FILE-POSITION FILE-SIZE +\ OPEN-FILE R/O R/W READ-FILE READ-LINE REPOSITION-FILE RESIZE-FILE +\ S" S\" SOURCE-ID W/O WRITE-FILE WRITE-LINE +\ FILE-STATUS FLUSH-FILE RENAME-FILE SAVE-INPUT RESTORE-INPUT +\ REFILL + +\ Words not tested: +\ INCLUDED INCLUDE-FILE (as these will likely have been +\ tested in the execution of the test files) +\ ---------------------------------------------------------------------------- +\ Assumptions, dependencies and notes: +\ - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been +\ included prior to this file +\ - the Core word set is available and tested +\ - These tests create files in the current directory, if all goes +\ well these will be deleted. If something fails they may not be +\ deleted. If this is a problem ensure you set a suitable +\ directory before running this test. There is no ANS standard +\ way of doing this. Also be aware of the file names used below +\ which are: fatest1.txt, fatest2.txt and fatest3.txt +\ ---------------------------------------------------------------------------- + +include? }T{ t_tools.fth + +true fp-require-e ! + +true value verbose + +: testing + verbose IF + source >in @ /string ." TESTING: " type cr + THEN + source nip >in ! +; immediate + +: -> }T{ ; +: s= compare 0= ; +: $" state IF postpone s" else ['] s" execute THEN ; immediate + + +\ FIXME: stubs for missing definition +: flush-file drop -1 ; +: resize-file drop 2drop -1 ; +: rename-file 2drop 2drop -1 ; +: file-status 2drop 0 -1 ; + + +TESTING File Access word set + +DECIMAL + +TEST{ + +\ ---------------------------------------------------------------------------- +TESTING CREATE-FILE CLOSE-FILE + +: FN1 S" fatest1.txt" ; +VARIABLE FID1 + +T{ FN1 R/W CREATE-FILE SWAP FID1 ! -> 0 }T +T{ FID1 @ CLOSE-FILE -> 0 }T + +\ ---------------------------------------------------------------------------- +TESTING OPEN-FILE W/O WRITE-LINE + +: LINE1 S" Line 1" ; + +T{ FN1 W/O OPEN-FILE SWAP FID1 ! -> 0 }T +T{ LINE1 FID1 @ WRITE-LINE -> 0 }T +T{ FID1 @ CLOSE-FILE -> 0 }T + +\ ---------------------------------------------------------------------------- +TESTING R/O FILE-POSITION (simple) READ-LINE + +200 CONSTANT BSIZE +CREATE BUF BSIZE ALLOT +VARIABLE #CHARS + +T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T +T{ FID1 @ FILE-POSITION -> 0. 0 }T +T{ BUF 100 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 SWAP DROP }T +T{ BUF #CHARS @ LINE1 S= -> TRUE }T +T{ FID1 @ CLOSE-FILE -> 0 }T + +\ ---------------------------------------------------------------------------- +TESTING S" in interpretation mode (compile mode tested in Core tests) + +T{ S" abcdef" $" abcdef" S= -> TRUE }T +T{ S" " $" " S= -> TRUE }T +T{ S" ghi"$" ghi" S= -> TRUE }T + +\ ---------------------------------------------------------------------------- +TESTING R/W WRITE-FILE REPOSITION-FILE READ-FILE FILE-POSITION S" + +: LINE2 S" Line 2 blah blah blah" ; +: RL1 BUF 100 FID1 @ READ-LINE ; +2VARIABLE FP + +T{ FN1 R/W OPEN-FILE SWAP FID1 ! -> 0 }T +T{ FID1 @ FILE-SIZE DROP FID1 @ REPOSITION-FILE -> 0 }T +T{ FID1 @ FILE-SIZE -> FID1 @ FILE-POSITION }T +T{ LINE2 FID1 @ WRITE-FILE -> 0 }T +T{ 10. FID1 @ REPOSITION-FILE -> 0 }T +T{ FID1 @ FILE-POSITION -> 10. 0 }T +T{ 0. FID1 @ REPOSITION-FILE -> 0 }T +T{ RL1 -> LINE1 SWAP DROP TRUE 0 }T +T{ RL1 ROT DUP #CHARS ! -> TRUE 0 LINE2 SWAP DROP }T +T{ BUF #CHARS @ LINE2 S= -> TRUE }T +T{ RL1 -> 0 FALSE 0 }T +T{ FID1 @ FILE-POSITION ROT ROT FP 2! -> 0 }T +T{ FP 2@ FID1 @ FILE-SIZE DROP D= -> TRUE }T +T{ S" " FID1 @ WRITE-LINE -> 0 }T +T{ S" " FID1 @ WRITE-LINE -> 0 }T +T{ FP 2@ FID1 @ REPOSITION-FILE -> 0 }T +T{ RL1 -> 0 TRUE 0 }T +T{ RL1 -> 0 TRUE 0 }T +T{ RL1 -> 0 FALSE 0 }T +T{ FID1 @ CLOSE-FILE -> 0 }T + +\ ---------------------------------------------------------------------------- +TESTING BIN READ-FILE FILE-SIZE + +: CBUF BUF BSIZE 0 FILL ; +: FN2 S" FATEST2.TXT" ; +VARIABLE FID2 +: SETPAD PAD 50 0 DO I OVER C! CHAR+ LOOP DROP ; + +SETPAD \ If anything else is defined setpad must be called again + \ as pad may move + +T{ FN2 R/W BIN CREATE-FILE SWAP FID2 ! -> 0 }T +T{ PAD 50 FID2 @ WRITE-FILE FID2 @ FLUSH-FILE -> 0 0 }T +T{ FID2 @ FILE-SIZE -> 50. 0 }T +T{ 0. FID2 @ REPOSITION-FILE -> 0 }T +T{ CBUF BUF 29 FID2 @ READ-FILE -> 29 0 }T +T{ PAD 29 BUF 29 S= -> TRUE }T +T{ PAD 30 BUF 30 S= -> FALSE }T +T{ CBUF BUF 29 FID2 @ READ-FILE -> 21 0 }T +T{ PAD 29 + 21 BUF 21 S= -> TRUE }T +T{ FID2 @ FILE-SIZE DROP FID2 @ FILE-POSITION DROP D= -> TRUE }T +T{ BUF 10 FID2 @ READ-FILE -> 0 0 }T +T{ FID2 @ CLOSE-FILE -> 0 }T + +\ ---------------------------------------------------------------------------- +TESTING RESIZE-FILE + +T{ FN2 R/W BIN OPEN-FILE SWAP FID2 ! -> 0 }T +T{ 37. FID2 @ RESIZE-FILE -> 0 }T +T{ FID2 @ FILE-SIZE -> 37. 0 }T +T{ 0. FID2 @ REPOSITION-FILE -> 0 }T +T{ CBUF BUF 100 FID2 @ READ-FILE -> 37 0 }T +T{ PAD 37 BUF 37 S= -> TRUE }T +T{ PAD 38 BUF 38 S= -> FALSE }T +T{ 500. FID2 @ RESIZE-FILE -> 0 }T +T{ FID2 @ FILE-SIZE -> 500. 0 }T +T{ 0. FID2 @ REPOSITION-FILE -> 0 }T +T{ CBUF BUF 100 FID2 @ READ-FILE -> 100 0 }T +T{ PAD 37 BUF 37 S= -> TRUE }T +T{ FID2 @ CLOSE-FILE -> 0 }T + +\ ---------------------------------------------------------------------------- +TESTING DELETE-FILE + +T{ FN2 DELETE-FILE -> 0 }T +T{ FN2 R/W BIN OPEN-FILE SWAP DROP 0= -> FALSE }T +T{ FN2 DELETE-FILE 0= -> FALSE }T + +\ ---------------------------------------------------------------------------- +\ TESTING multi-line ( comments +\ +\ T{ ( 1 2 3 +\ 4 5 6 +\ 7 8 9 ) 11 22 33 -> 11 22 33 }T +\ +\ ---------------------------------------------------------------------------- +TESTING SOURCE-ID (can only test it does not return 0 or -1) + +T{ SOURCE-ID DUP -1 = SWAP 0= OR -> FALSE }T + +\ ---------------------------------------------------------------------------- +TESTING RENAME-FILE FILE-STATUS FLUSH-FILE + +: FN3 S" fatest3.txt" ; +: >END FID1 @ FILE-SIZE .s DROP FID1 @ REPOSITION-FILE ; + + +T{ FN3 DELETE-FILE DROP -> }T +T{ FN1 FN3 RENAME-FILE 0= -> TRUE }T +T{ FN1 FILE-STATUS SWAP DROP 0= -> FALSE }T +T{ FN3 FILE-STATUS SWAP DROP 0= -> TRUE }T \ Return value is undefined +T{ FN3 R/W OPEN-FILE SWAP FID1 ! -> 0 }T +\ nyi T{ >END -> 0 }T +\ nyi T{ S" Final line" fid1 @ WRITE-LINE -> 0 }T + +\ nyi T{ FID1 @ FLUSH-FILE -> 0 }T \ Can only test FLUSH-FILE doesn't fail +\ nyi T{ FID1 @ CLOSE-FILE -> 0 }T + +\ Tidy the test folder +T{ fn3 DELETE-FILE DROP -> }T + +\ ---------------------------------------------------------------------------- +TESTING two buffers available for S" and/or S\" (Forth 2012) + +: SSQ12 S" abcd" ; : SSQ13 S" 1234" ; +T{ S" abcd" S" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T +\ nyi T{ S\" abcd" S\" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T +\ nyi T{ S" abcd" S\" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T +\ nyi T{ S\" abcd" S" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T + + +\ ----------------------------------------------------------------------------- +TESTING SAVE-INPUT and RESTORE-INPUT with a file source + +VARIABLE SIV -1 SIV ! + +: NEVEREXECUTED + CR ." This should never be executed" CR +; + +T{ 11111 SAVE-INPUT + +SIV @ + +[IF] + TESTING the -[IF]- part is executed + 0 SIV ! + RESTORE-INPUT + NEVEREXECUTED + 33333 +[ELSE] + + TESTING the -[ELSE]- part is executed + 22222 + +[THEN] + + -> 11111 0 22222 }T \ 0 comes from RESTORE-INPUT + +TESTING nested SAVE-INPUT, RESTORE-INPUT and REFILL from a file + +: READ_A_LINE + REFILL 0= + ABORT" REFILL FAILED" +; + +VARIABLE SI_INC 0 SI_INC ! + +: SI1 + SI_INC @ >IN +! + 15 SI_INC ! +; + +: S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ; + +CREATE 2RES -1 , -1 , \ Don't use 2VARIABLE from Double number word set + +: SI2 + READ_A_LINE + READ_A_LINE + SAVE-INPUT + READ_A_LINE + READ_A_LINE + S$ EVALUATE 2RES 2! + RESTORE-INPUT +; + +\ WARNING: do not delete or insert lines of text after si2 is called +\ otherwise the next test will fail + +T{ SI2 +33333 \ This line should be ignored +2RES 2@ 44444 \ RESTORE-INPUT should return to this line + +55555 +TESTING the nested results + -> 0 0 2345 44444 55555 }T + +\ End of warning + +\ ---------------------------------------------------------------------------- + +\ CR .( End of File-Access word set tests) CR + +}TEST