transput.c
1 //! @file transput.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-2024 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 //! Compile Fortran IO.
25
26 #include <vif.h>
27
28 static char *unum (EXPR *unit)
29 {
30 if (unit->mode.type == INTEGER) {
31 return unit->str;
32 } else {
33 return "0";
34 }
35 }
36
37 void save_iostat (char *iostat)
38 {
39 if (iostat != NULL) {
40 EXPR loc; RECORD ios, str;
41 MODE mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
42 _srecordf (ios, "%s", iostat);
43 RECCLR (loc.str);
44 variable (&loc, NULL, &mode, ios);
45 if (loc.mode.type == mode.type && loc.mode.len == mode.len) {
46 _srecordf (str, "%s = errno;\n", loc.str);
47 code (nprocs, BODY, str);
48 } else {
49 MODE_ERROR (2901, qtype (&(loc.mode)), qtype (&mode));
50 }
51 }
52 }
53
54 void io_event (char *proc, EXPR *unit, char *iorc, LBL *endlbl, LBL *errlbl)
55 {
56 if (EQUAL (proc, "write")) {
57 RECORD str;
58 if (errlbl == NULL) {
59 _srecordf (str, "_write_err (%s, %s, _ioerr_%s (\"%s\", %s));\n", iorc, unum (unit), proc, stat_start, unum (unit));
60 } else {
61 _srecordf (str, "_write_err (%s, %s, goto _l%d);\n", iorc, unum (unit), errlbl->num);
62 }
63 code (nprocs, BODY, str);
64 } else if (EQUAL (proc, "read")) {
65 RECORD str1, str2, str;
66 if (endlbl == NULL) {
67 _srecordf (str1, "_ioend_%s (\"%s\", %s)", proc, stat_start, unum (unit));
68 } else {
69 _srecordf (str1, "goto _l%d", endlbl->num);
70 }
71 if (errlbl == NULL) {
72 _srecordf (str2, "_ioerr_%s (\"%s\", %s)", proc, stat_start, unum (unit));
73 } else {
74 _srecordf (str2, "goto _l%d", errlbl->num);
75 }
76 _srecordf (str, "_read_err (%s, %s, %s, %s);\n", iorc, unum (unit), str1, str2);
77 code (nprocs, BODY, str);
78 } else {
79 BUG ("io_event");
80 }
81 }
82
83 void io_parm (EXPR *reg, char *elem)
84 {
85 if (reg->variant == EXPR_VAR) {
86 if (reg->mode.dim > 0) {
87 _srecordf (elem, "%s", reg->str);
88 } else if (reg->str[0] == '*') {
89 _srecordf (elem, "%s", ®->str[1]);
90 } else if (reg->mode.type == CHARACTER) {
91 _srecordf (elem, "%s", reg->str);
92 } else {
93 (void) impl_decl (reg->str, NULL);
94 _srecordf (elem, "&%s", reg->str);
95 }
96 } else if (reg->variant == EXPR_SLICE) {
97 _srecordf (elem, "&%s", reg->str);
98 } else {
99 RECORD tmp;
100 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
101 if (reg->mode.type == CHARACTER) {
102 norm_mode (®->mode);
103 if (reg->mode.len == 0) {
104 add_local (tmp, reg->mode.type, MAX_STRLEN, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
105 _srecordf (elem, "strcpy (%s, %s);\n", tmp, reg->str);
106 } else {
107 add_local (tmp, reg->mode.type, reg->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
108 _srecordf (elem, "bufcpy (%s, %s, %d);\n", tmp, reg->str, reg->mode.len);
109 }
110 code (nprocs, BODY, elem);
111 _srecordf (elem, "%s", tmp);
112 } else {
113 add_local (tmp, reg->mode.type, reg->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
114 _srecordf (elem, "%s = %s;\n", tmp, reg->str);
115 code (nprocs, BODY, elem);
116 _srecordf (elem, "&%s", tmp);
117 }
118 }
119 }
120
121 void io_text_items (char *proc, EXPR *unit, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl)
122 {
123 RECORD str;
124 if (EQUAL (proc, "write")) {
125 _srecordf (str, "while (%s[%s] != NULL && %s[%s] == FMT_TEXT) {\n", fstr, fid, fstr, fid);
126 code (nprocs, BODY, str);
127 _srecordf (str, "%s = _vifprintf (%s, %s[%s + 2], NULL, NOTYPE, 0);\n", iorc, unum (unit), fstr, fid);
128 code (nprocs, BODY, str);
129 io_event (proc, unit, iorc, endlbl, errlbl);
130 _srecordf (str, "%s += 3;\n", fid);
131 code (nprocs, BODY, str);
132 code (nprocs, BODY, "}\n");
133 } else if (EQUAL (proc, "read")) {
134 _srecordf (str, "while (%s[%s] != NULL && %s[%s] == FMT_TEXT) {\n", fstr, fid, fstr, fid);
135 code (nprocs, BODY, str);
136 _srecordf (str, "%s = _vifscanf (%s, %s[%s + 1], NULL, NOTYPE, 0);\n", iorc, unum (unit), fstr, fid);
137 code (nprocs, BODY, str);
138 io_event (proc, unit, iorc, endlbl, errlbl);
139 _srecordf (str, "%s += 3;\n", fid);
140 code (nprocs, BODY, str);
141 code (nprocs, BODY, "}\n");
142 }
143 }
144
145 void io_format (char *proc, EXPR *unit, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, char *elem, char *type, int_4 len)
146 {
147 RECORD str;
148 if (EQUAL (proc, "write")) {
149 _srecordf (str, "if (%s[%s] == NULL) {\n", fstr, fid);
150 code (nprocs, BODY, str);
151 _srecordf (str, "%s = 0;\n", fid);
152 code (nprocs, BODY, str);
153 _srecordf (str, "%s = fprintf (_ffile[%s].unit, \"\\n\");\n", iorc, unum (unit));
154 code (nprocs, BODY, str);
155 io_text_items (proc, unit, fstr, fid, iorc, endlbl, errlbl);
156 code (nprocs, BODY, "};\n");
157 _srecordf (str, "%s = _vifprintf (%s, %s[%s + 2], %s, %s, %d);\n", iorc, unum (unit), fstr, fid, elem, type, len);
158 code (nprocs, BODY, str);
159 io_event (proc, unit, iorc, endlbl, errlbl);
160 _srecordf (str, "%s += 3;\n", fid);
161 code (nprocs, BODY, str);
162 io_text_items (proc, unit, fstr, fid, iorc, endlbl, errlbl);
163 } else if (EQUAL (proc, "read")) {
164 _srecordf (str, "if (%s[%s] == NULL) {\n", fstr, fid);
165 code (nprocs, BODY, str);
166 _srecordf (str, "%s = 0;\n", fid);
167 code (nprocs, BODY, str);
168 _srecordf (str, "_vifscanf (%s, NULL, NULL, NOTYPE, 0);\n", unum (unit));
169 code (nprocs, BODY, str);
170 io_text_items (proc, unit, fstr, fid, iorc, endlbl, errlbl);
171 code (nprocs, BODY, "};\n");
172 _srecordf (str, "%s = _vifscanf (%s, %s[%s + 1], %s, %s, %d);\n", iorc, unum (unit), fstr, fid, elem, type, len);
173 code (nprocs, BODY, str);
174 io_event (proc, unit, iorc, endlbl, errlbl);
175 _srecordf (str, "%s += 3;\n", fid);
176 code (nprocs, BODY, str);
177 io_text_items (proc, unit, fstr, fid, iorc, endlbl, errlbl);
178 }
179 }
180
181 void io_elemuf (char *proc, EXPR *unit, EXPR *reg, char *iorc, LBL *endlbl, LBL *errlbl, int_4 *items)
182 {
183 RECORD str, elem;
184 RECCLR (elem);
185 io_parm (reg, elem);
186 if (EQUAL (proc, "write")) {
187 _srecordf (str, "%s = fwrite (%s", iorc, elem);
188 code (nprocs, BODY, str);
189 } else if (EQUAL (proc, "read")) {
190 _srecordf (str, "%s = fread (%s", iorc, elem);
191 code (nprocs, BODY, str);
192 } else {
193 BUG ("io_elemuf");
194 }
195 _srecordf (str, ", sizeof (%s), ", wtype (®->mode, NOARG, NOFUN));
196 code (nprocs, BODY, str);
197 if (reg->variant == EXPR_VAR && reg->mode.dim > 0) {
198 code_arrlen (reg->idf);
199 } else {
200 code (nprocs, BODY, "1");
201 }
202 _srecordf (str, ", _ffile[%s].unit);\n", unum (unit));
203 code (nprocs, BODY, str);
204 io_event (proc, unit, iorc, endlbl, errlbl);
205 }
206
207 void io_elemstd (char *proc, EXPR *unit, EXPR *reg, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, int_4 *items)
208 {
209 RECORD str, elem;
210 RECCLR (elem);
211 io_parm (reg, elem);
212 if (reg->mode.type == INTEGER) {
213 if (EQUAL (proc, "write")) {
214 _srecordf (str, "%s = _vifprintf (%s, \"%%d\", %s, INTEGER, %d);\n", iorc, unum (unit), elem, reg->mode.len);
215 } else if (EQUAL (proc, "read")) {
216 _srecordf (str, "%s = _vifscanf (%s, \"%%d\", %s, INTEGER, %d);\n", iorc, unum (unit), elem, reg->mode.len);
217 }
218 } else if (reg->mode.type == LOGICAL) {
219 if (EQUAL (proc, "write")) {
220 _srecordf (str, "%s = _vifprintf (%s, \"%%c\", %s, LOGICAL, %d);\n", iorc, unum (unit), elem, reg->mode.len);
221 } else if (EQUAL (proc, "read")) {
222 _srecordf (str, "%s = _vifscanf (%s, \"%%c\", %s, LOGICAL, %d);\n", iorc, unum (unit), elem, reg->mode.len);
223 }
224 } else if (reg->mode.type == REAL) {
225 if (EQUAL (proc, "write")) {
226 RECORD fmt;
227 if (reg->mode.len == 32) {
228 _srecordf (fmt, "\"%%.%de\"", FLT256_DIG);
229 _srecordf (str, "%s = _vifprintf (%s, %s, %s, REAL, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
230 } else if (reg->mode.len == 16) {
231 _srecordf (fmt, "\"%%.%de\"", FLT128_DIG);
232 _srecordf (str, "%s = _vifprintf (%s, %s, %s, REAL, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
233 } else if (reg->mode.len == 8) {
234 _srecordf (fmt, "\"%%.%de\"", DBL_DIG);
235 _srecordf (str, "%s = _vifprintf (%s, %s, %s, REAL, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
236 } else if (reg->mode.len == 4) {
237 _srecordf (fmt, "\"%%.%de\"", FLT_DIG);
238 _srecordf (str, "%s = _vifprintf (%s, %s, %s, REAL, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
239 }
240 } else if (EQUAL (proc, "read")) {
241 _srecordf (str, "%s = _vifscanf (%s, \"%%e\", %s, REAL, %d);\n", iorc, unum (unit), elem, reg->mode.len);
242 }
243 } else if (reg->mode.type == COMPLEX) {
244 if (EQUAL (proc, "write")) {
245 RECORD fmt;
246 if (reg->mode.len == 8) {
247 _srecordf (fmt, "\"%%.%de\"", FLT_DIG);
248 } else if (reg->mode.len == 16) {
249 _srecordf (fmt, "\"%%.%de\"", DBL_DIG);
250 } else if (reg->mode.len == 32) {
251 _srecordf (fmt, "\"%%.%de\"", FLT128_DIG);
252 } else if (reg->mode.len == 64) {
253 _srecordf (fmt, "\"%%.%de\"", FLT256_DIG);
254 }
255 _srecordf (str, "%s = _vifprintf (%s, %s, %s, COMPLEX, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
256 code (nprocs, BODY, str);
257 io_event (proc, unit, iorc, endlbl, errlbl);
258 _srecordf (str, "%s = _vifprintf (%s, \" \", NULL, NOTYPE, 0);\n", iorc, unum (unit));
259 code (nprocs, BODY, str);
260 io_event (proc, unit, iorc, endlbl, errlbl);
261 _srecordf (str, "%s = _vifprintf (%s, %s, %s, COMPLEX, -%d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
262 } else if (EQUAL (proc, "read")) {
263 _srecordf (str, "%s = _vifscanf (%s, \"%%e\", %s, COMPLEX, %d);\n", iorc, unum (unit), elem, reg->mode.len);
264 code (nprocs, BODY, str);
265 io_event (proc, unit, iorc, endlbl, errlbl);
266 _srecordf (str, "%s = _vifscanf (%s, \"%%e\", %s, COMPLEX, -%d);\n", iorc, unum (unit), elem, reg->mode.len);
267 }
268 } else if (reg->mode.type == CHARACTER) {
269 if (EQUAL (proc, "write")) {
270 // _srecordf (str, "%s = _vifprintf (%s, \"%%-%ds\", %s, CHARACTER, %d);\n", iorc, unum (unit), reg->mode.len, elem, reg->mode.len);
271 _srecordf (str, "%s = _vifprintf (%s, \"%%s\", %s, CHARACTER, %d);\n", iorc, unum (unit), elem, reg->mode.len);
272 } else if (EQUAL (proc, "read")) {
273 // _srecordf (str, "%s = _vifscanf (%s, \"%%%ds\", %s, CHARACTER, %d);\n", iorc, unum (unit), reg->mode.len, elem, reg->mode.len);
274 _srecordf (str, "%s = _vifscanf (%s, \"%%s\", %s, CHARACTER, %d);\n", iorc, unum (unit), elem, reg->mode.len);
275 }
276 }
277 code (nprocs, BODY, str);
278 io_event (proc, unit, iorc, endlbl, errlbl);
279 (*items) ++;
280 }
281
282 void io_elemf (char *proc, EXPR *unit, EXPR *reg, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, int_4 *items)
283 {
284 RECORD elem;
285 RECCLR (elem);
286 io_parm (reg, elem);
287 if (reg->mode.type == INTEGER) {
288 io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "INTEGER", reg->mode.len);
289 (*items) ++;
290 } else if (reg->mode.type == LOGICAL) {
291 io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "LOGICAL", reg->mode.len);
292 (*items) ++;
293 } else if (reg->mode.type == REAL) {
294 io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "REAL", reg->mode.len);
295 (*items) ++;
296 } else if (reg->mode.type == COMPLEX) {
297 io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "COMPLEX", reg->mode.len);
298 io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "COMPLEX", -reg->mode.len);
299 (*items) ++;
300 } else if (reg->mode.type == CHARACTER) {
301 io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "CHARACTER", reg->mode.len);
302 (*items) ++;
303 }
304 }
305
306 void io_array (char *proc, EXPR *unit, EXPR *reg, int_4 form, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, int_4 *items)
307 {
308 RECORD str, tmpa, tmpk;
309 EXPR elem;
310 IDENT *ptr;
311 _srecordf (tmpa, "_arr_%d", nloctmps++);
312 ptr = add_local (tmpa, reg->mode.type, reg->mode.len, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
313 ptr->alias = reg->idf;
314 _srecordf (tmpk, "_k_%d", nloctmps++);
315 add_local (tmpk, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
316 _srecordf (str, "for (%s = %s %s, %s = 0; %s < ", tmpa, ptr_to_array (ptr, NOCONST, CAST, ACTUAL), reg->str, tmpk, tmpk);
317 code (nprocs, BODY, str);
318 code_arrlen (reg->idf);
319 _srecordf (str, "; %s++, %s++) {\n", tmpa, tmpk);
320 code (nprocs, BODY, str);
321 memcpy (&elem, reg, sizeof (EXPR));
322 elem.mode.dim = 0;
323 if (EQUAL (proc, "read")) {
324 _srecordf (elem.str, "%s", tmpa);
325 } else if (EQUAL (proc, "write")) {
326 _srecordf (elem.str, "*%s", tmpa);
327 } else {
328 BUG ("io_array");
329 }
330 if (form == STDFORMAT) {
331 io_elemstd (proc, unit, &elem, fstr, fid, iorc, endlbl, errlbl, items);
332 } else if (form == FORMATTED) {
333 io_elemf (proc, unit, &elem, fstr, fid, iorc, endlbl, errlbl, items);
334 }
335 code (nprocs, BODY, "}\n");
336 }
337
338 void io_elem (char *proc, EXPR *unit, int_4 form, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, int_4 *items)
339 {
340 EXPR reg;
341 express (®, NOTYPE, 0);
342 if (form == UNFORMATTED) {
343 io_elemuf (proc, unit, ®, iorc, endlbl, errlbl, items);
344 } else if (form == STDFORMAT) {
345 if (reg.variant == EXPR_VAR && reg.mode.dim > 0) {
346 io_array (proc, unit, ®, form, fstr, fid, iorc, endlbl, errlbl, items);
347 } else {
348 io_elemstd (proc, unit, ®, fstr, fid, iorc, endlbl, errlbl, items);
349 }
350 } else if (form == FORMATTED) {
351 if (reg.variant == EXPR_VAR && reg.mode.dim > 0) {
352 io_array (proc, unit, ®, form, fstr, fid, iorc, endlbl, errlbl, items);
353 } else {
354 io_elemf (proc, unit, ®, fstr, fid, iorc, endlbl, errlbl, items);
355 }
356 } else {
357 BUG ("IO formatting unspecified");
358 }
359 }
360
361 int_4 impl_do (void)
362 {
363 // Quick check whether (...) in a list is an implied DO loop.
364 int_4 rc, nest = 1;
365 while ((rc = scan (NULL)) != END_OF_LINE) {
366 if (TOKEN ("(")) {
367 nest++;
368 } else if (TOKEN (")")) {
369 nest--;
370 if (nest == 0) {
371 return FALSE;
372 }
373 } else if (nest == 1 && TOKEN (",")) {
374 // Trigger is the sequence ", I =" in outer nest.
375 rc = scan (NULL);
376 if (rc == WORD) {
377 RECORD name;
378 strcpy (name, curlex);
379 rc = scan (NULL);
380 if (TOKEN ("=")) {
381 (void) impl_decl (name, NULL);
382 return TRUE;
383 } else {
384 UNSCAN;
385 }
386 }
387 }
388 }
389 (void) rc;
390 return FALSE;
391 }
392
393 void io_list (char *proc, EXPR *unit, int_4 form, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, int_4 lpatch, int_4 *nest, int_4 *items)
394 {
395 while (WITHIN) {
396 int_4 rc;
397 if (TOKEN (",")) {
398 rc = scan (NULL);
399 if (! WITHIN) {
400 SYNTAX (2902, prelex);
401 break;
402 }
403 if (TOKEN (",")) {
404 SYNTAX (2903, ",,");
405 continue;
406 }
407 } else {
408 rc = scan (NULL);
409 if (TOKEN (",")) {
410 continue;
411 }
412 }
413 if (! WITHIN) {
414 break;
415 }
416 if (TOKEN ("(")) {
417 SAVE_PRE;
418 // Quick lookahead.
419 int_4 loop = impl_do ();
420 // Restore.
421 RESTORE_POS;
422 rc = scan ("(");
423 // Decide.
424 if (loop) {
425 (*nest)++;
426 int_4 where = code (nprocs, BODY, NULL);
427 io_list (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, where, nest, items);
428 } else {
429 io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
430 rc = scan (NULL);
431 }
432 } else if (TOKEN (")")) {
433 // Expression closed by ')'
434 (*nest)--;
435 return;
436 } else if (rc == WORD) {
437 if (*nest == 0) {
438 io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
439 rc = scan (NULL);
440 } else {
441 SAVE_PRE;
442 rc = scan (NULL);
443 if (!TOKEN ("=")) {
444 RESTORE_POS;
445 rc = scan (NULL);
446 io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
447 rc = scan (NULL);
448 } else {
449 RECORD lid, loop;
450 EXPR from, to, by;
451 MODE mode;
452 IDENT *idf = impl_decl (prelex, &mode);
453 if (idf->arg || idf->alias != NULL) {
454 _srecordf (lid, "*%s", CID (idf));
455 } else if (idf->common == EXTERN) {
456 _srecordf (lid, "%s->%s", commons[idf->common], CID (idf));
457 } else if (idf->common > 0) {
458 _srecordf (lid, "%s.%s", commons[idf->common], CID (idf));
459 } else {
460 _srecordf (lid, "%s", CID (idf));
461 }
462 rc = scan (NULL);
463 express (&from, idf->mode.type, idf->mode.len);
464 rc = scan (",");
465 rc = scan (NULL);
466 express (&to, idf->mode.type, idf->mode.len);
467 rc = scan (NULL);
468 if (TOKEN (",")) {
469 rc = scan (NULL);
470 express (&by, idf->mode.type, idf->mode.len);
471 _srecordf (loop, "for (%s = %s; %s <= %s; %s += %s) {\n",
472 lid, from.str, lid, to.str, lid, by.str);
473 rc = scan (NULL);
474 } else {
475 _srecordf (loop, "for (%s = %s; %s <= %s; %s++) {\n",
476 lid, from.str, lid, to.str, lid);
477 }
478 patch (lpatch, loop);
479 if (TOKEN (")")) {
480 // Implied DO loop closed by ')'.
481 (*nest)--;
482 code (nprocs, BODY, "}; // implied DO \n");
483 } else {
484 EXPECT (2904, ")");
485 }
486 return;
487 }
488 }
489 } else {
490 io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
491 rc = scan (NULL);
492 }
493 }
494 }
495
496 void io_unit (EXPR *unit, int_4 defunit)
497 {
498 // Reasonable default.
499 unit->mode.type = INTEGER;
500 unit->mode.len = 4;
501 //
502 if (TOKEN ("*")) {
503 _srecordf (unit->str, "%d", defunit);
504 } else if (TOKEN ("stdin")) {
505 _srecordf (unit->str, "STDF_IN");
506 } else if (TOKEN ("stdout")) {
507 _srecordf (unit->str, "STDF_OUT");
508 } else if (TOKEN ("stderr")) {
509 _srecordf (unit->str, "STDF_ERR");
510 } else {
511 EXPR reg;
512 express (®, NOTYPE, NOLEN);
513 if (reg.mode.type == INTEGER) {
514 if (reg.variant == EXPR_CONST) {
515 _srecordf (unit->str, "%s", reg.str);
516 int_4 val;
517 (void) isint_4 (unit->str, &val);
518 if (val < 1 || val > MAX_FILES - 1) {
519 ERROR (2905, "unit number out of range", unit->str);
520 }
521 } else {
522 RECORD str;
523 _srecordf (unit->str, "%s", edit_unit (nloctmps++));
524 add_local (unit->str, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
525 _srecordf (str, "%s = %s;\n", unit, reg.str);
526 code (nprocs, BODY, str);
527 }
528 } else if (reg.mode.type == CHARACTER) {
529 if (reg.variant == EXPR_CONST) {
530 ERROR (2906, "unit cannot be a denotation", unit->str);
531 } else {
532 _srecordf (unit->str, "%s", reg.str);
533 unit->mode = reg.mode;
534 }
535 } else {
536 ERROR (2907, "unit must be INTEGER or CHARACTER", NULL);
537 }
538 }
539 }
540
541 void io_specs (EXPR *unit, int_4 defunit, char *fmt, char **fn, char **form, char **action, int_4 *lrecl, char **disp, LBL **end, LBL **err, char **iostat)
542 {
543 int_4 rc, parm = 1;
544 unit->str[0] = '\0';
545 fmt[0] = '\0';
546 *form = form_formatted;
547 *fn = NULL;
548 *action = action_default;
549 *disp = disp_old;
550 *end = NULL;
551 *err = NULL;
552 *iostat = NULL;
553 //
554 rc = scan (NULL);
555 while (!TOKEN (")") && rc != END_OF_MODULE) {
556 // ([UNIT], [FMT] [, FMT=n | FILE=expr | FORM=str | action=str | DISP=str | END=n | ERR=n])
557 if (TOKEN ("*") && parm == 2) {
558 *form = form_formatted;
559 } else if (rc == TEXT && parm == 2) {
560 int_4 k = format_str (curlex);
561 _srecordf (fmt, "%d", k);
562 *form = form_formatted;
563 } else if (TOKEN ("unit")) {
564 rc = scan ("=");
565 rc = scan (NULL);
566 io_unit (unit, defunit);
567 } else if (TOKEN ("file")) {
568 EXPR reg;
569 rc = scan ("=");
570 rc = scan (NULL);
571 if (express (®, CHARACTER, NOLEN)) {
572 *fn = stralloc (reg.str);
573 }
574 } else if (TOKEN ("form")) {
575 rc = scan ("=");
576 rc = scan (NULL);
577 if (TOKEN ("formatted")) {
578 *form = form_formatted;
579 } else if (TOKEN ("unformatted")) {
580 *form = form_unformatted;
581 } else {
582 SYNTAX (2908, "invalid FORM specification");
583 }
584 } else if (TOKEN ("action") || TOKEN ("access")) {
585 rc = scan ("=");
586 rc = scan (NULL);
587 if (TOKEN ("read")) {
588 *action = action_read;
589 } else if (TOKEN ("write")) {
590 *action = action_write;
591 } else if (TOKEN ("readwrite")) {
592 *action = action_readwrite;
593 } else {
594 SYNTAX (2909, "invalid ACCESS specification");
595 }
596 } else if (TOKEN ("disp") || TOKEN ("status")) {
597 // Straight from JCL :-)
598 rc = scan ("=");
599 rc = scan (NULL);
600 if (TOKEN ("\"old\"")) {
601 *disp = disp_old;
602 } else if (TOKEN ("\"new\"")) {
603 *disp = disp_new;
604 } else if (TOKEN ("\"keep\"")) {
605 *disp = disp_keep;
606 } else if (TOKEN ("\"delete\"")) {
607 *disp = disp_delete;
608 } else if (TOKEN ("\"unknown\"")) {
609 *disp = disp_new;
610 } else {
611 SYNTAX (2910, "invalid DISP specification");
612 }
613 } else if (TOKEN ("lrecl")) {
614 rc = scan ("=");
615 if ((rc = scan (NULL)) == INT_NUMBER) {
616 (void) isint_4 (curlex, lrecl);
617 } else {
618 EXPECT (2911, "record length");
619 }
620 } else if (TOKEN ("fmt")) {
621 rc = scan ("=");
622 rc = scan (NULL);
623 if (TOKEN ("*")) {
624 fmt[0] = '\0';
625 *form = form_formatted;
626 } else if (rc == WORD || rc == INT_NUMBER) {
627 bufcpy (fmt, curlex, RECLN);
628 *form = form_formatted;
629 } else if (rc == TEXT) {
630 int_4 k = format_str (curlex);
631 _srecordf (fmt, "%d", k);
632 *form = form_formatted;
633 } else {
634 EXPECT (2912, "label or format string");
635 }
636 } else if (TOKEN ("end")) {
637 rc = scan ("=");
638 if ((rc = scan (NULL)) == INT_NUMBER) {
639 if (((*end) = find_label (curlex)) == NULL) {
640 ERROR (2913, "no such label", curlex);
641 }
642 (*end)->jumped++;
643 } else {
644 EXPECT (2914, "label");
645 }
646 } else if (TOKEN ("err")) {
647 rc = scan ("=");
648 if ((rc = scan (NULL)) == INT_NUMBER) {
649 if (((*err) = find_label (curlex)) == NULL) {
650 ERROR (2915, "no such label", curlex);
651 }
652 (*err)->jumped++;
653 } else {
654 EXPECT (2916, "label");
655 }
656 } else if (TOKEN ("iostat")) {
657 rc = scan ("=");
658 rc = scan (NULL);
659 if (rc != WORD) {
660 EXPECT (2917, "variable")
661 } else {
662 *iostat = stralloc (curlex);
663 }
664 } else if ((rc == WORD || rc == INT_NUMBER) && parm == 2) {
665 bufcpy (fmt, curlex, RECLN);
666 *form = form_formatted;
667 } else if (parm == 1) {
668 io_unit (unit, defunit);
669 } else {
670 SYNTAX (2918, curlex);
671 }
672 // Next item.
673 parm++;
674 rc = scan (NULL);
675 if (TOKEN (",")) {
676 rc = scan (NULL);
677 } else if (TOKEN (")")) {
678 ;
679 } else {
680 SYNTAX (2919, curlex);
681 }
682 }
683 }
684
685 void vif_close (void)
686 {
687 int_4 rc, lrecl = 0;
688 char *daction = NULL, *ddisp = NULL, *dfn = NULL, *dform = NULL, *iostat = NULL;
689 RECORD str, fmt;
690 EXPR unit;
691 LBL *endlbl = NULL, *errlbl = NULL;
692 RECCLR (fmt);
693 rc = scan (NULL);
694 io_specs (&unit, ERR, fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
695 _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
696 code (nprocs, BODY, str);
697 _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
698 code (nprocs, BODY, str);
699 _srecordf (str, "_funregister (\"%s\", %s);\n", stat_start, unum (&unit));
700 code (nprocs, BODY, str);
701 if (iostat != NULL) {
702 RECORD ios;
703 _srecordf (ios, "%s = errno;\n", iostat);
704 code (nprocs, BODY, ios);
705 } else {
706 code (nprocs, BODY, "if (errno != 0) {\n");
707 if (errlbl == NULL) {
708 _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
709 } else {
710 _srecordf (str, "goto _l%d;\n", errlbl->num);
711 }
712 code (nprocs, BODY, str);
713 code (nprocs, BODY, "}\n");
714 code (nprocs, BODY, "}\n");
715 }
716 (void) rc;
717 }
718
719 void vif_rewind (void)
720 {
721 int_4 rc, lrecl = 0;
722 char *daction = NULL, *ddisp = NULL, *dfn = NULL, *dform = NULL, *iostat = NULL;
723 RECORD str, fmt;
724 EXPR unit;
725 LBL *endlbl = NULL, *errlbl = NULL;
726 RECCLR (fmt);
727 rc = scan (NULL);
728 io_specs (&unit, ERR, fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
729 _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
730 code (nprocs, BODY, str);
731 _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
732 code (nprocs, BODY, str);
733 _srecordf (str, "rewind (%s);\n", unum (&unit));
734 code (nprocs, BODY, str);
735 if (iostat != NULL) {
736 RECORD ios;
737 _srecordf (ios, "%s = errno;\n", iostat);
738 code (nprocs, BODY, ios);
739 } else {
740 code (nprocs, BODY, "if (errno != 0) {\n");
741 if (errlbl == NULL) {
742 _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
743 } else {
744 _srecordf (str, "goto _l%d;\n", errlbl->num);
745 }
746 code (nprocs, BODY, str);
747 code (nprocs, BODY, "}\n");
748 code (nprocs, BODY, "}\n");
749 }
750 (void) rc;
751 }
752
753 void vif_open (void)
754 {
755 int_4 rc, lrecl = 0;
756 char *daction = NULL, *dfn = NULL, *dform = NULL, *ddisp = NULL, *iostat = NULL;
757 LBL *endlbl = NULL, *errlbl = NULL;
758 RECORD str, fmt;
759 EXPR unit;
760 RECCLR (fmt);
761 rc = scan (NULL);
762 io_specs (&unit, ERR, fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
763 if (dfn != NULL) {
764 _srecordf (str, "_fregister (\"%s\", %s, %d, %s, %s, %s, %s);\n", stat_start, unum (&unit), lrecl, dfn, dform, daction, ddisp);
765 } else {
766 _srecordf (str, "_fregister (\"%s\", %s, %d, NULL, %s, %s, %s);\n", stat_start, unum (&unit), lrecl, dform, daction, ddisp);
767 }
768 code (nprocs, BODY, str);
769 if (iostat != NULL) {
770 RECORD ios;
771 _srecordf (ios, "%s = errno;\n", iostat);
772 code (nprocs, BODY, ios);
773 }
774 (void) rc;
775 }
776
777 void do_io (char *proc, int_4 *nest)
778 {
779 int_4 form = UNFORMATTED, lrecl = 0;
780 LBL *endlbl = NULL, *errlbl = NULL;
781 RECORD fstr, fid, iorc, str, fmt;
782 char *daction = NULL, *ddisp = NULL, *dfn = NULL, *dform = NULL, *iostat = NULL;
783 EXPR unit;
784 unit.mode.type = INTEGER;
785 unit.mode.len = 4;
786 fmt[0] = '\0';
787 fstr[0] = '\0';
788 fid[0] = '\0';
789 iorc[0] = '\0';
790 int_4 rc = scan (NULL);
791 if (EQUAL (proc, "read") || EQUAL (proc, "accept")) {
792 if (TOKEN ("*")) {
793 _srecordf (unit.str, "STDF_IN");
794 dform = form_formatted;
795 rc = scan (NULL);
796 } else if (rc == INT_NUMBER) { // FORTRAN II
797 _srecordf (unit.str, "STDF_IN");
798 bufcpy (fmt, curlex, RECLN);
799 dform = form_formatted;
800 rc = scan (NULL);
801 } else if (rc == TEXT) {
802 _srecordf (unit.str, "STDF_IN");
803 int_4 k = format_str (curlex);
804 _srecordf (fmt, "%d", k);
805 dform = form_formatted;
806 rc = scan (NULL);
807 } else {
808 io_specs (&unit, STDF_IN, fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
809 }
810 } else if (EQUAL (proc, "write") || EQUAL (proc, "print") || EQUAL (proc, "punch")) {
811 if (TOKEN ("*")) {
812 _srecordf (unit.str, "STDF_OUT");
813 dform = form_formatted;
814 rc = scan (NULL);
815 } else if (rc == INT_NUMBER) { // FORTRAN II
816 _srecordf (unit.str, "STDF_OUT");
817 bufcpy (fmt, curlex, RECLN);
818 dform = form_formatted;
819 rc = scan (NULL);
820 } else if (rc == TEXT) {
821 _srecordf (unit.str, "STDF_OUT");
822 int_4 k = format_str (curlex);
823 _srecordf (fmt, "%d", k);
824 dform = form_formatted;
825 rc = scan (NULL);
826 } else {
827 io_specs (&unit, STDF_OUT, fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
828 }
829 }
830 if (strlen (fmt) == 0 && dform != form_unformatted) {
831 form = STDFORMAT;
832 } else if (strlen (fmt) == 0 && dform == form_unformatted) {
833 form = UNFORMATTED;
834 } else {
835 form = FORMATTED;
836 }
837 // IO to a string implies UNIT=0.
838 if (unit.mode.type == CHARACTER) {
839 if (EQUAL (proc, "read")) {
840 _srecordf (str, "_ffile[0].unit = fmemopen (%s, %d, \"r\");\n", unit.str, unit.mode.len + 1);
841 } else if (EQUAL (proc, "accept")) {
842 _srecordf (str, "_ffile[0].unit = fmemopen (%s, %d, \"r\");\n", unit.str, unit.mode.len + 1);
843 } else if (EQUAL (proc, "write")) {
844 _srecordf (str, "_ffile[0].unit = fmemopen (%s, %d, \"w\");\n", unit.str, unit.mode.len + 1);
845 } else if (EQUAL (proc, "print")) {
846 _srecordf (str, "_ffile[0].unit = fmemopen (%s, %d, \"w\");\n", unit.str, unit.mode.len + 1);
847 } else if (EQUAL (proc, "punch")) {
848 _srecordf (str, "_ffile[0].unit = fmemopen (%s, %d, \"w\");\n", unit.str, unit.mode.len + 1);
849 }
850 code (nprocs, BODY, str);
851 }
852 // Runtime checks - can the file do this?
853 if (EQUAL (proc, "read")) {
854 _srecordf (str, "_fcheck (\"%s\", %s, action_read, %s);\n", stat_start, unum (&unit), dform);
855 } else if (EQUAL (proc, "accept")) {
856 _srecordf (str, "_fcheck (\"%s\", %s, action_read, %s);\n", stat_start, unum (&unit), dform);
857 } else if (EQUAL (proc, "write")) {
858 _srecordf (str, "_fcheck (\"%s\", %s, action_write, %s);\n", stat_start, unum (&unit), dform);
859 } else if (EQUAL (proc, "print")) {
860 _srecordf (str, "_fcheck (\"%s\", %s, action_write, %s);\n", stat_start, unum (&unit), dform);
861 } else if (EQUAL (proc, "punch")) {
862 _srecordf (str, "_fcheck (\"%s\", %s, action_write, %s);\n", stat_start, unum (&unit), dform);
863 }
864 code (nprocs, BODY, str);
865 if (form == FORMATTED) {
866 RECORD fcnt;
867 int_4 val;
868 _srecordf (fid, "__fcnt");
869 add_local (fid, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
870 _srecordf (iorc, "__rc");
871 add_local (iorc, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
872 _srecordf (fcnt, "%s = 0;\n", fid);
873 code (nprocs, BODY, fcnt);
874 if (isint_4 (fmt, &val)) {
875 _srecordf (fstr, "%s", edit_fmt (val));
876 } else {
877 MODE mode;
878 IDENT *idf = find_local (fmt, &mode);
879 if (idf == NULL) {
880 ERROR (2920, "undeclared format identifier", fmt);
881 } else if (mode.type == INTEGER) {
882 // Assigned FORMAT.
883 _srecordf (str, "switch (%s) {\n", CID (idf));
884 code (nprocs, BODY, str);
885 code (nprocs, BODY, "default:\n");
886 for (int_4 k = 0; k < nlabels; k++) {
887 LBL *L = &labels[k];
888 if (L->format) {
889 L->jumped++;
890 _srecordf (str, "case %d: __fmt_a = %s; break;\n", L->index, edit_fmt(L->num));
891 code (nprocs, BODY, str);
892 }
893 }
894 code (nprocs, BODY, "}\n");
895 strcpy (fstr, "__fmt_a");
896 } else if (mode.type == CHARACTER) {
897 _srecordf (str, "__fmt_a = _vif_jit (\"%s\", %s);\n", stat_start, CID (idf));
898 code (nprocs, BODY, str);
899 strcpy (fstr, "__fmt_a");
900 } else {
901 ERROR (2921, "format identifier mode error", qtype (&mode));
902 }
903 }
904 } else {
905 _srecordf (iorc, "__rc_%d", nloctmps++);
906 add_local (iorc, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
907 }
908 // Start-of-record.
909 if (form == FORMATTED) {
910 if (EQUAL (proc, "read")) {
911 io_text_items ("read", &unit, fstr, fid, iorc, endlbl, errlbl);
912 } else if (EQUAL (proc, "accept")) {
913 io_text_items ("read", &unit, fstr, fid, iorc, endlbl, errlbl);
914 } else if (EQUAL (proc, "write")) {
915 io_text_items ("write", &unit, fstr, fid, iorc, endlbl, errlbl);
916 } else if (EQUAL (proc, "print")) {
917 io_text_items ("write", &unit, fstr, fid, iorc, endlbl, errlbl);
918 } else if (EQUAL (proc, "punch")) {
919 io_text_items ("write", &unit, fstr, fid, iorc, endlbl, errlbl);
920 }
921 }
922 int_4 items = 0;
923 if (EQUAL (proc, "read")) {
924 io_list ("read", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
925 } else if (EQUAL (proc, "accept")) {
926 io_list ("read", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
927 } else if (EQUAL (proc, "write")) {
928 io_list ("write", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
929 } else if (EQUAL (proc, "print")) {
930 io_list ("write", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
931 } else if (EQUAL (proc, "punch")) {
932 io_list ("write", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
933 }
934 if (unit.mode.type == CHARACTER) {
935 // IO to a string implies UNIT=0.
936 code (nprocs, BODY, "_fclose (0);\n");
937 } else if (EQUAL (proc, "write") || EQUAL (proc, "print") || EQUAL (proc, "punch")) {
938 // End-of-record.
939 if (form != UNFORMATTED) {
940 _srecordf (str, "_write_eol (%s);\n", unum (&unit));
941 code (nprocs, BODY, str);
942 }
943 } else if (EQUAL (proc, "read") || EQUAL (proc, "accept")) {
944 // End-of-record.
945 if (form != UNFORMATTED) {
946 _srecordf (str, "_read_eol (%s);\n", unum (&unit));
947 code (nprocs, BODY, str);
948 }
949 }
950 //
951 save_iostat (iostat);
952 //
953 (void) rc;
954 }
|
© 2002-2024 J.M. van der Veer (jmvdveer@xs4all.nl)
|
