rts-io.c
1 //! @file rts-io.c
2 //! @author J. Marcel van der Veer
3 //
4 //! @section Copyright
5 //
6 // This file is part of VIF - vintage FORTRAN compiler.
7 // Copyright 2020-2025 J. Marcel van der Veer <algol68g@xs4all.nl>.
8 //
9 //! @section License
10 //
11 // This program is free software; you can redistribute it and/or modify it
12 // under the terms of the GNU General Public License as published by the
13 // Free Software Foundation; either version 3 of the License, or
14 // (at your option) any later version.
15 //
16 // This program is distributed in the hope that it will be useful, but
17 // WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 // or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 // more details. You should have received a copy of the GNU General Public
20 // License along with this program. If not, see <http://www.gnu.org/licenses/>.
21
22 //! @section Synopsis
23 //!
24 //! Runtime support for Fortran IO.
25
26 #include <vif.h>
27
28 FTNFILE _ffile[MAX_FILES];
29
30 char *action_default = "action_default";
31 char *action_read = "action_read";
32 char *action_write = "action_write";
33 char *action_readwrite = "action_readwrite";
34 char *form_formatted = "form_formatted";
35 char *form_unformatted = "form_unformatted";
36 char *disp_new = "disp_new";
37 char *disp_old = "disp_old";
38 char *disp_delete = "disp_delete";
39 char *disp_keep = "disp_keep";
40
41 // Fortran IO
42
43 void _fcheck (char *where, int_4 unit, char *action, char *form)
44 {
45 FTNFILE *_f = &_ffile[unit];
46 NEW_RECORD (str);
47 __scale__ = 1;
48 if (unit < 0 || unit >= MAX_FILES) {
49 _srecordf (str, "unit number %d is not valid", unit);
50 RTE (where, str);
51 }
52 if (action == NO_TEXT) {
53 // CLOSE, REWIND
54 return;
55 }
56 if (_f->unit == NO_FILE) {
57 // File was not opened yet.
58 NEW_RECORD (mode);
59 NEW_RECORD (disp);
60 if (_f->disp != NO_TEXT) {
61 RECCPY (disp, _f->disp);
62 } else {
63 RECCPY (disp, disp_old);
64 }
65 if (_f->action == action_default) {
66 _f->action = action;
67 } else if (_f->action == action_readwrite) {
68 action = action_readwrite;
69 } else if (_f->action != action) {
70 _srecordf (str, "inconsistent action: %s", action);
71 RTE (where, str);
72 }
73 if (_f->form == NO_TEXT) {
74 _f->form = form;
75 } else if (_f->form != form) {
76 _srecordf (str, "inconsistent formatting: %s", form);
77 RTE (where, str);
78 }
79 RECCPY (mode, "UNKNOWN");
80 if (form == form_formatted && action == action_read) {
81 RECCPY (mode, "r");
82 } else if (form == form_formatted && action == action_write) {
83 RECCPY (mode, "w");
84 } else if (form == form_formatted && action == action_readwrite) {
85 if (EQUAL (disp, "disp_old")) {
86 RECCPY (mode, "r+");
87 } else if (EQUAL (disp, "disp_new")) {
88 RECCPY (mode, "w+");
89 }
90 } else if (form == form_unformatted && action == action_read) {
91 RECCPY (mode, "rb");
92 } else if (form == form_unformatted && action == action_write) {
93 RECCPY (mode, "wb");
94 } else if (form == form_unformatted && action == action_readwrite) {
95 if (EQUAL (disp, "disp_old")) {
96 RECCPY (mode, "r+b");
97 } else if (EQUAL (disp, "disp_new")) {
98 RECCPY (mode, "w+b");
99 }
100 } else {
101 _srecordf (str, "error: form=%s, action=%s, disp=%s", form, action, disp);
102 RTE (where, str);
103 }
104 if (_f->in_stream) {
105 if ((_f->unit = fmemopen (_f->buff, strlen (_f->buff) + 1, mode)) == NO_FILE) {
106 _srecordf (str, "cannot open unit %d: form=%s, action=%s, disp=%s", unit, form, action, disp);
107 RTE (where, str);
108 }
109 } else {
110 if ((_f->unit = fopen (_f->name, mode)) == NO_FILE) {
111 _srecordf (str, "cannot open unit %d: form=%s, action=%s, disp=%s", unit, form, action, disp);
112 RTE (where, str);
113 }
114 }
115 _rewind (where, unit);
116 } else {
117 // File was opened.
118 if (action == action_read) {
119 if (unit == 0 && _f->record >= _f->records) {
120 _srecordf (str, "unit %d: reading past end-of-file", unit);
121 RTE (where, str);
122 }
123 if (_f->action == action_write) {
124 _srecordf (str, "unit %d: not open for 'read'", unit);
125 RTE (where, str);
126 }
127 } else if (action == action_write) {
128 if (_f->action == action_read) {
129 _srecordf (str, "unit %d: not open for 'write'", unit);
130 RTE (where, str);
131 }
132 }
133 if (_f->form != form) {
134 if (form == form_formatted) {
135 _srecordf (str, "unit %d: not open for formatted IO", unit);
136 } else {
137 _srecordf (str, "unit %d: not open for unformatted IO", unit);
138 }
139 RTE (where, str);
140 }
141 }
142 }
143
144 void _fregister (char *where, int_4 unit, int_4 lrecl, char *fn, char *form, char *action, char *disp)
145 {
146 FTNFILE *_f = &_ffile[unit];
147 if (unit >= 0 && unit < MAX_FILES) {
148 int_4 len;
149 if (_f->unit != NO_FILE) {
150 NEW_RECORD (err);
151 _srecordf (err, "'unit %d' already open", unit);
152 RTE (where, err);
153 }
154 if (lrecl <= 0 || lrecl > MAX_LRECL) {
155 lrecl = MAX_LRECL;
156 }
157 _ffile[unit] = (FTNFILE) {
158 .form = form,.action = action,.disp = disp,.lrecl = lrecl};
159 _f->buff = (char *) f_malloc (lrecl + 1);
160 if (_f->in_stream) {
161 _f->buff_init = TRUE;
162 _f->action = action_read;
163 } else {
164 _f->buff_init = FALSE;
165 }
166 _f->buff_pos = 0;
167 if (fn == NO_TEXT) {
168 NEW_RECORD (buf);
169 _f->vers++;
170 _srecordf (buf, "ft%02df%03d", unit, _f->vers);
171 len = strlen (buf) + 1;
172 _f->name = (char *) f_malloc (len);
173 strcpy (_f->name, buf);
174 } else {
175 len = strlen (fn) + 1;
176 _f->name = (char *) f_malloc (len);
177 strcpy (_f->name, fn);
178 }
179 } else {
180 RTE (where, "unit out of range");
181 }
182 }
183
184 void _funregister (char *where, int_4 unit)
185 {
186 FTNFILE *_f = &_ffile[unit];
187 if (unit >= 0 && unit < MAX_FILES) {
188 if (_f->unit != NO_FILE) {
189 _fclose (unit);
190 }
191 if (_f->disp == disp_delete) {
192 remove (_f->name);
193 }
194 if (_f->name != NO_TEXT) {
195 free (_f->name);
196 }
197 if (_f->buff != NO_TEXT) {
198 free (_f->buff);
199 }
200 *_f = (FTNFILE) {
201 .unit = NO_FILE,.name = NO_TEXT,.form = NO_TEXT,.action = NO_TEXT,.disp = NO_TEXT,.vers = 0,.buff = NO_TEXT,.buff_init = FALSE,.buff_pos = 0,.buff_len = 0};
202 } else {
203 RTE (where, "unit out of range");
204 }
205 }
206
207 void _skip_eol (FILE * f)
208 {
209 while (fgetc (f) != '\n');
210 }
211
212 void _ioerr (char *where, int_4 unit)
213 {
214 NEW_RECORD (err);
215 _srecordf (err, "'unit %d': IO error", unit);
216 RTE (where, err);
217 }
218
219 void _ioerr_write (char *where, int_4 unit)
220 {
221 NEW_RECORD (err);
222 _srecordf (err, "'unit %d': IO error while writing", unit);
223 RTE (where, err);
224 }
225
226 void _ioerr_read (char *where, int_4 unit)
227 {
228 NEW_RECORD (err);
229 _srecordf (err, "'unit %d': IO error while reading", unit);
230 RTE (where, err);
231 }
232
233 void _ioend_read (char *where, int_4 unit)
234 {
235 NEW_RECORD (err);
236 _srecordf (err, "'unit %d': end of file while reading", unit);
237 RTE (where, err);
238 }
239
240 int_4 _init_file_buffer (int_4 unit)
241 {
242 FTNFILE *_f = &_ffile[unit];
243 if (unit == 0) {
244 if (_f->record < _f->records) {
245 // String lengths are powers of 2 in VIF.
246 int_4 len = 1;
247 while (len <= _f->lrecl) {
248 len *= 2;
249 }
250 _f->buff = &((_ffile[0].rewind)[_f->record * len]);
251 _f->buff_init = TRUE;
252 _f->buff_pos = 0;
253 _f->buff_len = strlen (_f->buff);
254 _f->record++;
255 return 0;
256 } else {
257 _f->buff = NO_TEXT;
258 _f->buff_init = FALSE;
259 _f->buff_pos = 0;
260 _f->buff_len = 0;
261 return 1;
262 }
263 } else {
264 if (_f->in_stream) {
265 if (_f->record > 1) {
266 char *q = _f->buff;
267 while (q[0] != '\n') {
268 q++;
269 }
270 _f->buff = &q[1];
271 }
272 } else {
273 (void) fgets (_f->buff, _f->lrecl, _f->unit);
274 }
275 _f->buff_len = strlen (_f->buff);
276 if (_f->buff[_f->buff_len - 1] == '\n') {
277 _f->buff[_f->buff_len - 1] = '\0';
278 _f->buff_len--;
279 }
280 _f->buff_init = TRUE;
281 _f->buff_pos = 0;
282 _f->record++;
283 return 0;
284 }
285 }
286
287 int_4 _rewind (char *where, int_4 unit)
288 {
289 FTNFILE *_f = &_ffile[unit];
290 if (unit == 0) {
291 _f->record = 0;
292 _init_file_buffer (0);
293 } else if (_f != NO_FTNFILE) {
294 if (_f->in_stream) {
295 _f->buff = _f->rewind;
296 } else {
297 rewind (_f->unit);
298 }
299 _f->buff_pos = 0;
300 _f->record = 1;
301 }
302 if (_f == NO_FTNFILE || errno != 0) {
303 RECORD buf;
304 _srecordf (buf, "cannot rewind unit %d", unit);
305 RTE (where, buf);
306 }
307 return 0;
308 }
309
310 int_4 _set_record (char *where, int_4 unit, int_4 rec)
311 {
312 FTNFILE *_f = &_ffile[unit];
313 if (unit == 0) {
314 _f->record = rec - 1;
315 _init_file_buffer (0);
316 } else if (_f != NO_FTNFILE) {
317 _rewind (where, unit);
318 _init_file_buffer (unit);
319 for (int_4 k = 1; k < rec; k++) {
320 _init_file_buffer (unit);
321 }
322 }
323 if (_f == NO_FTNFILE || errno != 0) {
324 RECORD buf;
325 _srecordf (buf, "cannot set record on unit %d", unit);
326 RTE (where, buf);
327 }
328 return 0;
329 }
330
331 int_4 _backspace (char *where, int_4 unit)
332 {
333 FTNFILE *_f = &_ffile[unit];
334 _set_record (where, unit, _f->record - 1);
335 if (_f == NO_FTNFILE || errno != 0) {
336 RECORD buf;
337 _srecordf (buf, "cannot backspace unit %d", unit);
338 RTE (where, buf);
339 }
340 return 0;
341 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
