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 FTN_FILE _ffile[MAX_FTN_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 FTN_FILE *_f = _get_ftn_file (where, unit);
46 NEW_RECORD (str);
47 __scale__ = 1;
48 if (unit < 0 || unit >= MAX_FTN_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 FTN_FILE *_f = _get_ftn_file (where, unit);
147 if (unit >= 0 && unit < MAX_FTN_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] = (FTN_FILE) {
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_ftn_file (FTN_FILE *f)
185 {
186 if (f != NO_FTN_FILE) {
187 *f = (FTN_FILE) {
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 FTN_FILE *_f = _get_ftn_file (where, unit);
205 if (unit >= 0 && unit < MAX_FTN_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_ftn_file (_f);
219 } else {
220 RTE (where, "unit out of range");
221 }
222 }
223
224 FTN_FILE *_get_ftn_file (char *where, int_4 unit)
225 {
226 if (unit < 0 || unit >= MAX_FTN_FILES) {
227 RTE (where, "unit out of range");
228 return NO_FTN_FILE;
229 } else {
230 return &(_ffile[unit]);
231 }
232 }
233
234 void _skip_eol (FILE * f)
235 {
236 while (fgetc (f) != '\n');
237 }
238
239 void _ioerr (char *where, int_4 unit)
240 {
241 NEW_RECORD (err);
242 _srecordf (err, "'unit %d': IO error", unit);
243 RTE (where, err);
244 }
245
246 void _ioerr_write (char *where, int_4 unit)
247 {
248 NEW_RECORD (err);
249 _srecordf (err, "'unit %d': IO error while writing", unit);
250 RTE (where, err);
251 }
252
253 void _ioerr_read (char *where, int_4 unit)
254 {
255 NEW_RECORD (err);
256 _srecordf (err, "'unit %d': IO error while reading", unit);
257 RTE (where, err);
258 }
259
260 void _ioend_read (char *where, int_4 unit)
261 {
262 NEW_RECORD (err);
263 _srecordf (err, "'unit %d': end of file while reading", unit);
264 RTE (where, err);
265 }
266
267 int_4 _init_file_buffer (int_4 unit)
268 {
269 FTN_FILE *_f = _get_ftn_file (NO_TEXT, unit);
270 if (unit == 0) {
271 if (_f->record < _f->records) {
272 // String lengths are powers of 2 in VIF.
273 int_4 len = 1;
274 while (len <= _f->lrecl) {
275 len *= 2;
276 }
277 _f->buff = &((_ffile[0].rewind)[_f->record * len]);
278 _f->buff_init = TRUE;
279 _f->buff_pos = 0;
280 _f->buff_len = strlen (_f->buff);
281 _f->record++;
282 return 0;
283 } else {
284 _f->buff = NO_TEXT;
285 _f->buff_init = FALSE;
286 _f->buff_pos = 0;
287 _f->buff_len = 0;
288 return 1;
289 }
290 } else {
291 if (_f->in_stream) {
292 if (_f->record > 1) {
293 char *q = _f->buff;
294 while (q[0] != '\n') {
295 q++;
296 }
297 _f->buff = &q[1];
298 }
299 } else {
300 (void) fgets (_f->buff, _f->lrecl, _f->unit);
301 }
302 _f->buff_len = strlen (_f->buff);
303 if (_f->buff[_f->buff_len - 1] == '\n') {
304 _f->buff[_f->buff_len - 1] = '\0';
305 _f->buff_len--;
306 }
307 _f->buff_init = TRUE;
308 _f->buff_pos = 0;
309 _f->record++;
310 return 0;
311 }
312 }
313
314 int_4 _rewind (char *where, int_4 unit)
315 {
316 FTN_FILE *_f = _get_ftn_file (where, unit);
317 if (unit == 0) {
318 _f->record = 0;
319 _init_file_buffer (0);
320 } else if (_f != NO_FTN_FILE) {
321 if (_f->in_stream) {
322 _f->buff = _f->rewind;
323 } else {
324 rewind (_f->unit);
325 }
326 _f->buff_pos = 0;
327 _f->record = 1;
328 }
329 if (_f == NO_FTN_FILE || errno != 0) {
330 RECORD buf;
331 _srecordf (buf, "cannot rewind unit %d", unit);
332 RTE (where, buf);
333 }
334 return 0;
335 }
336
337 int_4 _set_record (char *where, int_4 unit, int_4 rec)
338 {
339 FTN_FILE *_f = _get_ftn_file (where, unit);
340 if (unit == 0) {
341 _f->record = rec - 1;
342 _init_file_buffer (0);
343 } else if (_f != NO_FTN_FILE) {
344 _rewind (where, unit);
345 _init_file_buffer (unit);
346 for (int_4 k = 1; k < rec; k++) {
347 _init_file_buffer (unit);
348 }
349 }
350 if (_f == NO_FTN_FILE || errno != 0) {
351 RECORD buf;
352 _srecordf (buf, "cannot set record on unit %d", unit);
353 RTE (where, buf);
354 }
355 return 0;
356 }
357
358 int_4 _backspace (char *where, int_4 unit)
359 {
360 FTN_FILE *_f = _get_ftn_file (where, unit);
361 _set_record (where, unit, _f->record - 1);
362 if (_f == NO_FTN_FILE || errno != 0) {
363 RECORD buf;
364 _srecordf (buf, "cannot backspace unit %d", unit);
365 RTE (where, buf);
366 }
367 return 0;
368 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
