\\ ANS Forth File Word Set by U.Hoffmann 17Mar94 $Logfile: C:/SRC/FPC/FPC-ANS/VCS/FILESET.SEV $ $Revision: 1.4 $ $Date: 1999/04/10 13:56:46 $ $Author: uho $ /--------------------------------------------------------uh 29Mai93 | This file contains the definition of an ANS-Forth compatible | | File-Access word set for F-PC. If you do not use F-PC this file | | is useless for you. This is NOT an ANS-Forth program but is | | highly F-PC specific. It is a system extension to F-PC in order | | to make F-PC supply the ANS-Forth File Access word set. | | | | This file is a companion to the F-PC ANS-Forth CORE and CORE EXT| | extensions as provided in the file ANSI.SEQ. ANSI.SEQ is needed | | to load this file. | | | | To support strict ANS-Forth code, a separate vocabulary ANSI | | FILE is defined. By this the F-PC vocabulary search mechanism | | can be used to restrict the visibility of specific word sets. | | To activate the File-Access word set include the phrase | | ANSI FILE ALSO in your program. | | | | This Code is public domain software. | | | | Remarks and comments are welcome. | | | | Ulrich Hoffmann | | Sehestedter Strasse 26 | | 24340 Eckernfoerde | | Germany | | +49 431 712 217 | | +49 431 712 216 (FAX) | | Ulrich.E.Hoffmann@gmx.de | | | \-----------------------------------------------------------------/ This file depends on ANSI.SEQ so we include it here, if it is not already in the system. { needs ANSI.SEQ } -------------------------------------------------------------- Define the ordinary F-PC File header for easy reloading: { Only Forth also definitions decimal warning off Anew *Fileset* beheadable on> beheadable ( We WANT to forget the temporary names. ) } -------------------------------------------------------------- The ANS-Forth File-Access word set has operators (LINE-READ, LINE-WRITE) which work on lines in files. Since line termination is handled differently in different operating systems, it is desirable to add the flexibility to work on either line termination policy: { Forth Definitions Defer line-break ( -- c-addr len ) Create 'crlf 2 c, $0D c, $0A c, \ DOS style line termination \ Create 'lf 1 c, $0A c, \ Unix style line termination \ Create 'cr 1 c, $0D c, \ MAC style line termination ' 'crlf is line-break | Defer scan-line-break ( c-addr1 len1 -- c-addr2 len2 ) \ | : scan-single ( c-addr1 len1 -- c-addr2 len2 ) \ line-break 1+ c@ scan ; | : scan-double ( c-addr1 len1 -- c-addr2 len2 ) BEGIN ( c-addr1 len1 ) line-break 1+ c@ scan ( c-addr1' len1' ) \ scan for first 1 /string dup WHILE ( c-addr1 len1 ) over c@ line-break 2+ c@ = IF -1 /string EXIT THEN REPEAT ; ' scan-double is scan-line-break } -------------------------------------------------------------- Make a new vocabulary, FILE, in the ANSI vocabulary. Subsequent definitions go there. { Only Forth also ANSI CORE also ANSI definitions Vocabulary FILE FILE definitions } -------------------------------------------------------------- F-PC already has file handling words. We need to adapt these words, so they function as required by the standard. Normally, if you want to operate on a file in F-PC you have to create a HANDLE in the dictionary, which is similar to a file control block used in CP/M. This HANDLE contains the path name of a file, its attributes and its operating system (DOS) handle. In ANS-Forth you can operate on files without first allocating any data structures in dictionary. All you have to supply is the file name and the desired access mode. So, what we need is a pool of pre-allocated HANDLEs which we use on a per request basis. #FILES is the number of these pre-allocated HANDLEs and thus limits the number of files you can operate on simultanously. { 8 | Constant #files | Create 'files #files b/hcb * allot | : nth-file ( n -- addr ) b/hcb * 'files + ; | : clear-files ( -- ) #files 0 DO I nth-file clr-hcb LOOP ; clear-files } -------------------------------------------------------------- We not only need the pool of pre-allocated HANDLEs from above but also a way to dynamically use these HANDLEs to work on files. { ANSI FILE definitions | : closed? ( addr -- flag ) >HNDLE @ $FFFF = ; | : new-file ( -- fileid ) #files 0 DO I nth-file closed? IF I nth-file dup clr-hcb UNLOOP EXIT THEN LOOP true Abort" too many open files" ; | : ">new-file ( addr len -- fileid ) new-file dup>r ">handle r> ; } -------------------------------------------------------------- Parsing text in F-PC is not easy to understand. Even worse '(' parses differently than required by the standard. F-PC '(' will stop scanning for ')' as soon as it reaches the end of the current line. Weird - but the reason is in the way F-PC scans its input stream. File input is transferred succesively into TIB and is interpreted there. Anyway. We need a version of '(' which will NOT stop scanning at the end of line. This is similar to the existing F-PC multipl line comments such as /* */ but handles the single line case correctly: { | : eol? ( -- f ) #tib @ >in @ <= ; | : multiline-) ( -- ) \ multi line ) scanner loading @ 0= IF ( end of file ) crunsave is run EXIT THEN [compile] ( \ does ( reach the end of line? eol? ?EXIT \ then multiline-) stays current scanner (RUN) crunsave is run \ else the ordinary scanner becomes cur. scanner (RUN) run ; \ and is performed to interpret the rest of line. : ( ( "ccc -- ) ?loading [compile] ( eol? 0= ?EXIT \ single line ( @> run !> crunsave ['] multiline-) is run ; immediate } -------------------------------------------------------------- F-PC is a DOS Forth system, which does not really distinguish binary and non binary files. { ' noop Alias BIN ( fam1 -- fam2 ) } -------------------------------------------------------------- Now we can define most of the File-Access words. They are build on those pretty-named F-PC h-operators. { ' hclose Alias CLOSE-FILE ( fileid -- ior ) } -------------------------------------------------------------- ANS-Forth requires that CREATE-FILE will make and open the file with the supplied file access mode. This is not what DOS will do. The create file system call will open the file in read-write mode, regardless of the attribute given in the call. So, to comply to the standard, we have to create the file then close and reopen it with correct file access mode. It is stored in the ATTRIB field of the HANDLE to let also FLUSH-FILE close and reopen the file with correct file access mode. { : CREATE-FILE ( c-addr u fam -- fileid ior ) >r ">new-file dup hcreate over >attrib r> swap ! ?dup ?EXIT dup hclose ?dup ?EXIT dup >attrib @ !> r/w-mode dup hopen ; : DELETE-FILE ( c-addr u -- ior ) ">new-file hdelete ; } -------------------------------------------------------------- Ok. F-PC does not provide all we need in a convinient way. For example for moving the file pointer it only has the words CURPOINTER, MOVEPOINTER and ENDFILE to retrieve the file pointer, to move the file pointer absolutely or to move it to the end of the file respectively. Neither returns result-codes, which are required by ANS-Forth and which are generated by DOS. The ANS-Forth words FILE-POSITION and REPOSITION-FILE are similar to CURPOINTER, MOVEPOINTER and ENDFILE in that they call the same DOS function INT $21 function $42. REPOSITION-FILE is defined below, at its appropriate place int the lexicographical (alphabetical) order. { Code FILE-POSITION ( fileid -- ud ior ) pop bx add bx, # HNDLOFFSET mov bx, 0 [bx] mov cx, # 0 mov dx, # 0 mov ax, # $4201 \ relative int $21 push ax push dx u>= IF xor ax, ax THEN 1push end-code } -------------------------------------------------------------- Now that we have these, we continue to define standard words: { : FILE-SIZE ( fileid -- ud ior ) dup>r file-position ?dup ?EXIT r@ endfile 2swap r> movepointer 0 ; : INCLUDE-FILE ( i*x fileid -- j*x ) $fload ?open.error ; : INCLUDED ( i*x c-addr u -- j*x ) ">new-file include-file ; } -------------------------------------------------------------- OPEN-FILE stores the file access mode into the ATTRIB field of the HANDLE. This information is used in FLUSH-FILE from the file access extension word set to reopen the file with correct file access mode. { : OPEN-FILE ( c-addr u fam -- fileid ior ) !> r/w-mode ">new-file r/w-mode over >attrib ! dup hopen ; } -------------------------------------------------------------- The file access modes are determined by DOS: { 0 Constant R/O ( -- fam ) 2 Constant R/W ( -- fam ) } -------------------------------------------------------------- Again, simple file-io is based on F-PC's existing words: { : READ-FILE ( c-addr u1 fileid -- u2 ior ) rwerr off hread rwerr @ ; } -------------------------------------------------------------- More elaborated file-io needs some more. In order to avoid reading character by character on the one hand and to use only the supplied memory as working area on the other hand, READ-LINE has to be quite complicated: It reads as much as the supplied memory can hold. This is faster than reading individual characters, even for short lines. After that READ-LINE scans for the end-of-line in memory and adjusts the returned count as well as the file pointer to compensate the characters read in effect unnecessarily. { | Code backup-position ( u fileid -- ) \ Move file pointer back u characters pop bx ADD bx, # HNDLOFFSET mov bx, 0 [bx] mov cx, # $FFFF pop dx neg dx mov ax, # $4201 \ relative int $21 next end-code : READ-LINE ( c-addr u1 fileid -- u2 flag ior ) >r over swap line-break c@ + r@ READ-FILE \ read as much as possible ?dup IF r>drop nip EXIT THEN \ exit if read error ( c-addr u2' ) dup 0= IF ( eof ) r>drop nip false 0 EXIT THEN \ no chars read ( c-addr u2' ) tuck scan-line-break \ look for eol ( u2' c-addr' u3 ) nip dup IF ( found ) \ Move file pointer back to start of line dup line-break c@ - r@ backup-position THEN - true 0 r>drop ; \ line read succesfull } -------------------------------------------------------------- Here is REPOSITION-FILE in its right lexicographical place: { Code REPOSITION-FILE ( ud fileid -- ior ) pop bx ADD bx, # HNDLOFFSET mov bx, 0 [bx] pop cx pop dx mov ax, # $4200 \ from start of file int $21 u>= IF xor ax, ax THEN 1push end-code } -------------------------------------------------------------- It's a good kept secret that in order to resize a file in DOS you have to fputs, I mean hwrite, the empty string to the file with the file pointer at the desired file end. { : RESIZE-FILE ( ud fileid -- ior ) dup>r movepointer 0 0 r> hwrite 0<> ; } -------------------------------------------------------------- Here is a simple interpretive version of S". It uses only a single buffer to hold the string. A better implementation will for example use a circular buffer to hold multiple strings. (See strbuf.seq) But since any ANS Forth program must expect that the temporary buffer is possibly overwritten by subsequently calling S" anyway, there is no need for this extension to implement more than what is minimally required by the standard. { | Create "buffer 81 allot : S" ( "ccc" -- c-addr u ) ( comp: "ccc" -- ) ( runtime: -- c-addr u ) state @ IF [compile] S" EXIT THEN Ascii " parse "buffer place "buffer count ; immediate } -------------------------------------------------------------- F-PC holds a HANDLE of the current file (The file in the editor, the one you are loading, etc.) in the value SEQHANDLE. This will become our SOURCE-ID in case the input source is a text file. { : source-id ( -- 0 | -1 | fileid ) \ FILE version loading @ IF seqhandle EXIT THEN 'tib @ sp0 @ <> ; } -------------------------------------------------------------- Here is the rest of the File-Access word set. Note that the case that no data is written to the file is handled explicitly, since calling DOS would truncate the file. See RESIZE-FILE. { 1 Constant W/O ( -- fam ) : WRITE-FILE ( c-addr u fileid -- ior ) over ?dup IF >r hwrite r> <> 1 and EXIT THEN drop 2drop 0 ; : WRITE-LINE ( c-addr u fileid -- ior ) dup>r write-file ?dup IF r>drop EXIT THEN line-break count r> write-file ; } -------------------------------------------------------------- The File-Access extension word set adds some more words. First we create the EXT Vocabulary in the ANSI FILE vocabulary. { Vocabulary EXT also EXT also definitions } -------------------------------------------------------------- FILE-STATUS will check, wheter a file exists, ignoring whether it is possible to open that file. The implementation defined return value x is the address of the directory buffer read. Of course accessing this buffer is highly system dependent. { | Create status-buffer 43 allot : FILE-STATUS ( c-addr u -- x ior ) DTA@ 2>r ">new-file 1+ status-buffer SET-DTA $23 find-first \ $23=find any files status-buffer swap 2r> DTA! ; } -------------------------------------------------------------- FLUSH-FILE will save all buffered date in a file to disk. Though new DOS-Versions have a system call for this ("COMMIT FILE"), the general solution is to close the file and reopen it. The file pointer is then adjusted to the position it had before closing the file. { : FLUSH-FILE ( fileid -- ior ) dup>r FILE-POSITION ?dup IF nip nip r>drop EXIT THEN r@ hclose ?dup IF nip nip r>drop EXIT THEN r@ >attrib @ !> r/w-mode r@ hopen ?dup IF nip nip r>drop EXIT THEN r> REPOSITION-FILE ; } -------------------------------------------------------------- REFILL will make available the next line of source code, regardless of the input source (may it be the user input device, a text file or a string via EVALUATE). { : REFILL ( -- flag ) \ File version loading @ IF ( file ) \ similar to filltib but with end of file detection lineread length.check ( addr flag ) IF ( not eof ) crlf>bl's ?.loadline settib true EXIT THEN drop ( eof ) false EXIT THEN 'tib @ sp0 = IF ( User input device ) query true EXIT THEN ( EVALUATE ) false ; } -------------------------------------------------------------- RENAME-FILE will rename the file given by c-addr1 u1 to the new name given by c-addr2 u2. Both can be path names on the same drive and the file will possibly be moved to another directory. The file to be moved must be closed first! { : RENAME-FILE ( c-addr1 u1 c-addr2 u2 -- ior ) ">new-file ( hdl2 ) dup >hndle >r -2 r@ ! ( mark as used to get different hdl1 ) >r ">new-file r> ( hdl1 hdl2 ) -1 r> ! ( mark as hdl1 as unused ) hrename ; } -------------------------------------------------------------- Done with the File-Access and File-Access Extension word sets! { behead !> beheadable warning on cr .( ANS Forth File Access word set loaded. ) Only Forth also definitions Only Forth also ANSI CORE also ANSI CORE EXT also ANSI FILE also } ------------------------------------------------------------ Revision history: $Log: fileset.seq,v $ Revision 1.4 1999/04/10 13:56:46 uho Update Version Number Revision 1.3 1999/04/10 11:42:17 uho Changed Email Address Revision 1.2 1997/08/28 10:04:05 uho *** empty log message *** Revision 1.1 1997/08/28 09:59:14 uho Initial revision Rev 1.3 17 Nov 1995 1:22:02 Clean up for release. Rev 1.2 26 Apr 1995 9:51:22 Translated ß-text to english Rev 1.1 22 Feb 1995 0:03:36 Rev 1.0 21 Feb 1995 23:32:36 Initial revision.