1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
\ https://github.com/philburk/pforth/fth/file.fth
\ READ-LINE and WRITE-LINE
\
\ This code is part of pForth.
\
\ The pForth software code is dedicated to the public domain,
\ and any third party may reproduce, distribute and modify
\ the pForth software code or any derivative works thereof
\ without any compensation or license. The pForth software
\ code is provided on an "as is" basis without any warranty
\ of any kind, including, without limitation, the implied
\ warranties of merchantability and fitness for a particular
\ purpose and their equivalents under the laws of any jurisdiction.
private{
10 constant \N
13 constant \R
\ Unread one char from file FILEID.
: UNREAD { fileid -- ior }
fileid file-position ( ud ior )
?dup
IF nip nip \ IO error
ELSE 1 s>d d- fileid 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 one char.
: SKIP-\N { c-addr fileid -- ior }
c-addr 1 fileid read-file ( u ior )
?dup
IF \ Read error?
nip
ELSE ( u )
0=
IF \ End of file?
0
ELSE
c-addr c@ \n = ( is-it-a-\n? )
IF 0
ELSE fileid 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 ;
\ Standard throw code
\ See: http://lars.nocrew.org/forth2012/exception.html#table:throw
-72 constant THROW_RENAME_FILE
\ Copy the string C-ADDR/U1 to C-ADDR2 and append a NUL.
: PLACE-CSTR ( c-addr1 u1 c-addr2 -- )
2dup 2>r ( c-addr1 u1 c-addr2 ) ( r: u1 c-addr2 )
swap cmove ( ) ( r: u1 c-addr2 )
0 2r> + c! ( )
;
: MULTI-LINE-COMMENT ( "comment<rparen>" -- )
BEGIN
>in @ ')' parse ( >in c-addr len )
nip + >in @ = ( delimiter-not-found? )
WHILE ( )
refill 0= IF EXIT THEN ( )
REPEAT
;
}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 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
;
: RENAME-FILE ( c-addr1 u1 c-addr2 u2 -- ior )
{ a1 u1 a2 u2 | new }
\ Convert the file-names to C-strings by copying them after HERE.
a1 u1 here place-cstr
here u1 1+ chars + to new
a2 u2 new place-cstr
here new (rename-file) 0=
IF 0
ELSE throw_rename_file
THEN
;
\ A limit used to perform a sanity check on the size argument for
\ RESIZE-FILE.
2variable RESIZE-FILE-LIMIT
10000000 0 resize-file-limit 2! \ 10MB is somewhat arbitrarily chosen
: RESIZE-FILE ( ud fileid -- ior )
-rot 2dup resize-file-limit 2@ d> ( fileid ud big? )
IF
." Argument (" 0 d.r ." ) is larger then RESIZE-FILE-LIMIT." cr
." (You can increase RESIZE-FILE-LIMIT with 2!)" cr
abort
ELSE
rot (resize-file)
THEN
;
: ( ( "comment<rparen>" -- )
source-id
CASE
-1 OF postpone ( ENDOF
0 OF postpone ( ENDOF
\ for input from files
multi-line-comment
ENDCASE
; immediate
\ We basically try to open the file in read-only mode. That seems to
\ be the best that we can do with ANSI C. If we ever want to do
\ something more sophisticated, like calling access(2), we must create
\ a proper primitive. (OTOH, portable programs can't assume much
\ about FILE-STATUS and non-portable programs could create a custom
\ function for access(2).)
: FILE-STATUS ( c-addr u -- 0 ior )
r/o bin open-file ( fileid ior1 )
?dup
IF nip 0 swap ( 0 ior1 )
ELSE close-file 0 swap ( 0 ior2 )
THEN
;
privatize
|
