rts-transput.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 _reset_ftnfile (FTNFILE *f)
185 {
186 if (f != NO_FTNFILE) {
187 *f = (FTNFILE) {
188 .unit = NO_FILE,
189 .name = NO_TEXT,
190 .form = NO_TEXT,
191 .action = NO_TEXT,
192 .disp = NO_TEXT,
193 .vers = 0,
194 .buff = NO_TEXT,
195 .buff_init = FALSE,
196 .buff_pos = 0,
197 .buff_len = 0
198 };
199 }
200 }
201
202 void _funregister (char *where, int_4 unit)
203 {
204 FTNFILE *_f = &_ffile[unit];
205 if (unit >= 0 && unit < MAX_FILES) {
206 if (_f->unit != NO_FILE) {
207 _fclose (unit);
208 }
209 if (_f->disp == disp_delete) {
210 remove (_f->name);
211 }
212 if (_f->name != NO_TEXT) {
213 free (_f->name);
214 }
215 if (_f->buff != NO_TEXT) {
216 free (_f->buff);
217 }
218 _reset_ftnfile (_f);
219 } else {
220 RTE (where, "unit out of range");
221 }
222 }
223
224 void _skip_eol (FILE * f)
225 {
226 while (fgetc (f) != '\n');
227 }
228
229 void _ioerr (char *where, int_4 unit)
230 {
231 NEW_RECORD (err);
232 _srecordf (err, "'unit %d': IO error", unit);
233 RTE (where, err);
234 }
235
236 void _ioerr_write (char *where, int_4 unit)
237 {
238 NEW_RECORD (err);
239 _srecordf (err, "'unit %d': IO error while writing", unit);
240 RTE (where, err);
241 }
242
243 void _ioerr_read (char *where, int_4 unit)
244 {
245 NEW_RECORD (err);
246 _srecordf (err, "'unit %d': IO error while reading", unit);
247 RTE (where, err);
248 }
249
250 void _ioend_read (char *where, int_4 unit)
251 {
252 NEW_RECORD (err);
253 _srecordf (err, "'unit %d': end of file while reading", unit);
254 RTE (where, err);
255 }
256
257 int_4 _init_file_buffer (int_4 unit)
258 {
259 FTNFILE *_f = &_ffile[unit];
260 if (unit == 0) {
261 if (_f->record < _f->records) {
262 // String lengths are powers of 2 in VIF.
263 int_4 len = 1;
264 while (len <= _f->lrecl) {
265 len *= 2;
266 }
267 _f->buff = &((_ffile[0].rewind)[_f->record * len]);
268 _f->buff_init = TRUE;
269 _f->buff_pos = 0;
270 _f->buff_len = strlen (_f->buff);
271 _f->record++;
272 return 0;
273 } else {
274 _f->buff = NO_TEXT;
275 _f->buff_init = FALSE;
276 _f->buff_pos = 0;
277 _f->buff_len = 0;
278 return 1;
279 }
280 } else {
281 if (_f->in_stream) {
282 if (_f->record > 1) {
283 char *q = _f->buff;
284 while (q[0] != '\n') {
285 q++;
286 }
287 _f->buff = &q[1];
288 }
289 } else {
290 (void) fgets (_f->buff, _f->lrecl, _f->unit);
291 }
292 _f->buff_len = strlen (_f->buff);
293 if (_f->buff[_f->buff_len - 1] == '\n') {
294 _f->buff[_f->buff_len - 1] = '\0';
295 _f->buff_len--;
296 }
297 _f->buff_init = TRUE;
298 _f->buff_pos = 0;
299 _f->record++;
300 return 0;
301 }
302 }
303
304 int_4 _rewind (char *where, int_4 unit)
305 {
306 FTNFILE *_f = &_ffile[unit];
307 if (unit == 0) {
308 _f->record = 0;
309 _init_file_buffer (0);
310 } else if (_f != NO_FTNFILE) {
311 if (_f->in_stream) {
312 _f->buff = _f->rewind;
313 } else {
314 rewind (_f->unit);
315 }
316 _f->buff_pos = 0;
317 _f->record = 1;
318 }
319 if (_f == NO_FTNFILE || errno != 0) {
320 RECORD buf;
321 _srecordf (buf, "cannot rewind unit %d", unit);
322 RTE (where, buf);
323 }
324 return 0;
325 }
326
327 int_4 _set_record (char *where, int_4 unit, int_4 rec)
328 {
329 FTNFILE *_f = &_ffile[unit];
330 if (unit == 0) {
331 _f->record = rec - 1;
332 _init_file_buffer (0);
333 } else if (_f != NO_FTNFILE) {
334 _rewind (where, unit);
335 _init_file_buffer (unit);
336 for (int_4 k = 1; k < rec; k++) {
337 _init_file_buffer (unit);
338 }
339 }
340 if (_f == NO_FTNFILE || errno != 0) {
341 RECORD buf;
342 _srecordf (buf, "cannot set record on unit %d", unit);
343 RTE (where, buf);
344 }
345 return 0;
346 }
347
348 int_4 _backspace (char *where, int_4 unit)
349 {
350 FTNFILE *_f = &_ffile[unit];
351 _set_record (where, unit, _f->record - 1);
352 if (_f == NO_FTNFILE || errno != 0) {
353 RECORD buf;
354 _srecordf (buf, "cannot backspace unit %d", unit);
355 RTE (where, buf);
356 }
357 return 0;
358 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
