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-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 //! 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 != NO_TEXT) {
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 factor_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 (3001, 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 == NO_LABEL) {
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 == NO_LABEL) {
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 == NO_LABEL) {
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 (IS_ROW (reg->mode)) {
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, NO_MODE);
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 && IS_ROW (reg->mode)) {
198 code_row_len (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_row_len (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 && IS_ROW (reg.mode)) {
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 && IS_ROW (reg.mode)) {
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 (EXPECT_NONE)) != 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 (EXPECT_NONE);
376 if (rc == WORD) {
377 RECORD name;
378 RECCLR (name);
379 strcpy (name, curlex);
380 rc = scan (EXPECT_NONE);
381 if (TOKEN ("=")) {
382 (void) impl_decl (name, NO_MODE);
383 return TRUE;
384 } else {
385 UNSCAN;
386 }
387 }
388 }
389 }
390 (void) rc;
391 return FALSE;
392 }
393
394 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)
395 {
396 while (WITHIN) {
397 int_4 rc;
398 if (TOKEN (",")) {
399 rc = scan (EXPECT_NONE);
400 if (! WITHIN) {
401 SYNTAX (3002, prelex);
402 break;
403 }
404 if (TOKEN (",")) {
405 SYNTAX (3003, ",,");
406 continue;
407 }
408 } else {
409 rc = scan (EXPECT_NONE);
410 if (TOKEN (",")) {
411 continue;
412 }
413 }
414 if (! WITHIN) {
415 break;
416 }
417 if (TOKEN ("(")) {
418 SAVE_PRE;
419 // Quick lookahead.
420 int_4 loop = impl_do ();
421 // Restore.
422 RESTORE_POS;
423 rc = scan ("(");
424 // Decide.
425 if (loop) {
426 (*nest)++;
427 int_4 where = code (nprocs, BODY, NO_TEXT);
428 io_list (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, where, nest, items);
429 } else {
430 io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
431 rc = scan (EXPECT_NONE);
432 }
433 } else if (TOKEN (")")) {
434 // Expression closed by ')'
435 (*nest)--;
436 return;
437 } else if (rc == WORD) {
438 if (*nest == 0) {
439 io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
440 rc = scan (EXPECT_NONE);
441 } else {
442 SAVE_PRE;
443 rc = scan (EXPECT_NONE);
444 if (!TOKEN ("=")) {
445 RESTORE_POS;
446 rc = scan (EXPECT_NONE);
447 io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
448 rc = scan (EXPECT_NONE);
449 } else {
450 RECORD lid, loop;
451 EXPR from, to, by;
452 MODE mode;
453 IDENT *idf = impl_decl (prelex, &mode);
454 if (idf->arg || idf->alias != NULL) {
455 _srecordf (lid, "*%s", C_NAME (idf));
456 } else {
457 (void) idf_full_c_name (lid, idf);
458 }
459 rc = scan (EXPECT_NONE);
460 express (&from, idf->mode.type, idf->mode.len);
461 rc = scan (",");
462 rc = scan (EXPECT_NONE);
463 express (&to, idf->mode.type, idf->mode.len);
464 rc = scan (EXPECT_NONE);
465 if (TOKEN (",")) {
466 rc = scan (EXPECT_NONE);
467 express (&by, idf->mode.type, idf->mode.len);
468 _srecordf (loop, "for (%s = %s; %s <= %s; %s += %s) {\n",
469 lid, from.str, lid, to.str, lid, by.str);
470 rc = scan (EXPECT_NONE);
471 } else {
472 _srecordf (loop, "for (%s = %s; %s <= %s; %s++) {\n",
473 lid, from.str, lid, to.str, lid);
474 }
475 patch (lpatch, loop);
476 if (TOKEN (")")) {
477 // Implied DO loop closed by ')'.
478 (*nest)--;
479 code (nprocs, BODY, "}; // implied DO \n");
480 } else {
481 EXPECT (3004, ")");
482 }
483 return;
484 }
485 }
486 } else {
487 io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
488 rc = scan (EXPECT_NONE);
489 }
490 }
491 }
492
493 void io_unit (EXPR *unit, int_4 defunit)
494 {
495 // Reasonable default.
496 unit->mode.type = INTEGER;
497 unit->mode.len = 4;
498 //
499 if (TOKEN ("*")) {
500 _srecordf (unit->str, "%d", defunit);
501 } else if (TOKEN ("stdin")) {
502 _srecordf (unit->str, "STDF_IN");
503 } else if (TOKEN ("stdout")) {
504 _srecordf (unit->str, "STDF_OUT");
505 } else if (TOKEN ("stderr")) {
506 _srecordf (unit->str, "STDF_ERR");
507 } else {
508 EXPR reg;
509 express (®, NOTYPE, NOLEN);
510 if (reg.mode.type == INTEGER) {
511 if (reg.variant == EXPR_CONST) {
512 _srecordf (unit->str, "%s", reg.str);
513 int_4 val;
514 (void) isint_4 (unit->str, &val);
515 if (val < 1 || val > MAX_FILES - 1) {
516 ERROR (3005, "unit number out of range", unit->str);
517 }
518 } else {
519 RECORD str;
520 _srecordf (unit->str, "%s", edit_unit (nloctmps++));
521 add_local (unit->str, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
522 _srecordf (str, "%s = %s;\n", unit, reg.str);
523 code (nprocs, BODY, str);
524 }
525 } else if (reg.mode.type == CHARACTER) {
526 if (reg.variant == EXPR_CONST) {
527 ERROR (3006, "unit cannot be a denotation", unit->str);
528 } else {
529 _srecordf (unit->str, "%s", reg.str);
530 unit->mode = reg.mode;
531 }
532 } else {
533 ERROR (3007, "unit must be INTEGER or CHARACTER", NO_TEXT);
534 }
535 }
536 }
537
538 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)
539 {
540 int_4 rc, parm = 1;
541 unit->str[0] = '\0';
542 fmt[0] = '\0';
543 *form = form_unformatted;
544 *fn = NO_TEXT;
545 *action = action_default;
546 *disp = disp_old;
547 *end = NO_LABEL;
548 *err = NO_LABEL;
549 *iostat = NO_TEXT;
550 //
551 rc = scan (EXPECT_NONE);
552 while (!TOKEN (")") && rc != END_OF_MODULE) {
553 // ([UNIT], [FMT] [, FMT=n | FILE=expr | FORM=str | action=str | DISP=str | END=n | ERR=n])
554 if (TOKEN ("*") && parm == 2) {
555 *form = form_formatted;
556 } else if (rc == TEXT && parm == 2) {
557 int_4 k = format_str (curlex);
558 _srecordf (fmt, "%d", k);
559 *form = form_formatted;
560 } else if (TOKEN ("unit")) {
561 rc = scan ("=");
562 rc = scan (EXPECT_NONE);
563 io_unit (unit, defunit);
564 } else if (TOKEN ("file")) {
565 EXPR reg;
566 rc = scan ("=");
567 rc = scan (EXPECT_NONE);
568 if (express (®, CHARACTER, NOLEN)) {
569 *fn = f_stralloc (reg.str);
570 }
571 } else if (TOKEN ("form")) {
572 rc = scan ("=");
573 rc = scan (EXPECT_NONE);
574 if (TOKEN ("formatted")) {
575 *form = form_formatted;
576 } else if (TOKEN ("unformatted")) {
577 *form = form_unformatted;
578 } else {
579 SYNTAX (3008, "invalid FORM specification");
580 }
581 } else if (TOKEN ("action") || TOKEN ("access")) {
582 rc = scan ("=");
583 rc = scan (EXPECT_NONE);
584 if (TOKEN ("read")) {
585 *action = action_read;
586 } else if (TOKEN ("write")) {
587 *action = action_write;
588 } else if (TOKEN ("readwrite")) {
589 *action = action_readwrite;
590 } else {
591 SYNTAX (3009, "invalid ACCESS specification");
592 }
593 } else if (TOKEN ("disp") || TOKEN ("status")) {
594 // Straight from JCL :-)
595 rc = scan ("=");
596 rc = scan (EXPECT_NONE);
597 if (TOKEN ("\"old\"")) {
598 *disp = disp_old;
599 } else if (TOKEN ("\"new\"")) {
600 *disp = disp_new;
601 } else if (TOKEN ("\"keep\"")) {
602 *disp = disp_keep;
603 } else if (TOKEN ("\"delete\"")) {
604 *disp = disp_delete;
605 } else if (TOKEN ("\"unknown\"")) {
606 *disp = disp_new;
607 } else {
608 SYNTAX (3010, "invalid DISP specification");
609 }
610 } else if (TOKEN ("lrecl")) {
611 rc = scan ("=");
612 if ((rc = scan (EXPECT_NONE)) == INT_NUMBER) {
613 (void) isint_4 (curlex, lrecl);
614 } else {
615 EXPECT (3011, "record length");
616 }
617 } else if (TOKEN ("fmt")) {
618 rc = scan ("=");
619 rc = scan (EXPECT_LABEL);
620 if (TOKEN ("*")) {
621 fmt[0] = '\0';
622 *form = form_formatted;
623 } else if (rc == WORD || rc == LABEL) {
624 bufcpy (fmt, curlex, RECLN);
625 *form = form_formatted;
626 } else if (rc == TEXT) {
627 int_4 k = format_str (curlex);
628 _srecordf (fmt, "%d", k);
629 *form = form_formatted;
630 } else {
631 EXPECT (3012, "label or format string");
632 }
633 } else if (TOKEN ("end")) {
634 rc = scan ("=");
635 if ((rc = scan (EXPECT_LABEL)) == LABEL) {
636 if (((*end) = find_label (curlex)) == NO_LABEL) {
637 ERROR (3013, "no such label", curlex);
638 }
639 (*end)->jumped++;
640 } else {
641 EXPECT (3014, "label");
642 }
643 } else if (TOKEN ("err")) {
644 rc = scan ("=");
645 if ((rc = scan (EXPECT_LABEL)) == LABEL) {
646 if (((*err) = find_label (curlex)) == NO_LABEL) {
647 ERROR (3015, "no such label", curlex);
648 }
649 (*err)->jumped++;
650 } else {
651 EXPECT (3016, "label");
652 }
653 } else if (TOKEN ("iostat")) {
654 rc = scan ("=");
655 rc = scan (EXPECT_NONE);
656 if (rc != WORD) {
657 EXPECT (3017, "variable")
658 } else {
659 *iostat = f_stralloc (curlex);
660 }
661 } else if ((rc == WORD || rc == INT_NUMBER) && parm == 2) {
662 bufcpy (fmt, curlex, RECLN);
663 *form = form_formatted;
664 } else if (parm == 1) {
665 io_unit (unit, defunit);
666 } else {
667 SYNTAX (3018, curlex);
668 }
669 // Next item.
670 parm++;
671 rc = scan (EXPECT_NONE);
672 if (TOKEN (",")) {
673 rc = scan (EXPECT_NONE);
674 } else if (TOKEN (")")) {
675 ;
676 } else {
677 SYNTAX (3019, curlex);
678 }
679 }
680 }
681
682 void vif_close (void)
683 {
684 int_4 rc, lrecl = 0;
685 char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
686 RECORD str, fmt;
687 EXPR unit;
688 LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
689 RECCLR (fmt);
690 rc = scan (EXPECT_NONE);
691 io_specs (&unit, ERR, fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
692 _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
693 code (nprocs, BODY, str);
694 _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
695 code (nprocs, BODY, str);
696 _srecordf (str, "_funregister (\"%s\", %s);\n", stat_start, unum (&unit));
697 code (nprocs, BODY, str);
698 if (iostat != NO_TEXT) {
699 RECORD ios;
700 _srecordf (ios, "%s = errno;\n", iostat);
701 code (nprocs, BODY, ios);
702 } else {
703 code (nprocs, BODY, "if (errno != 0) {\n");
704 if (errlbl == NO_LABEL) {
705 _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
706 } else {
707 _srecordf (str, "goto _l%d;\n", errlbl->num);
708 }
709 code (nprocs, BODY, str);
710 code (nprocs, BODY, "}\n");
711 code (nprocs, BODY, "}\n");
712 }
713 (void) rc;
714 }
715
716 void vif_rewind (void)
717 {
718 int_4 rc, lrecl = 0;
719 char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
720 RECORD str, fmt;
721 EXPR unit;
722 LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
723 RECCLR (fmt);
724 rc = scan (EXPECT_NONE);
725 io_specs (&unit, ERR, fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
726 _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
727 code (nprocs, BODY, str);
728 _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
729 code (nprocs, BODY, str);
730 _srecordf (str, "rewind (_ffile[%s].unit);\n", unum (&unit));
731 code (nprocs, BODY, str);
732 if (iostat != NO_TEXT) {
733 RECORD ios;
734 _srecordf (ios, "%s = errno;\n", iostat);
735 code (nprocs, BODY, ios);
736 } else {
737 code (nprocs, BODY, "if (errno != 0) {\n");
738 if (errlbl == NO_LABEL) {
739 _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
740 } else {
741 _srecordf (str, "goto _l%d;\n", errlbl->num);
742 }
743 code (nprocs, BODY, str);
744 code (nprocs, BODY, "}\n");
745 code (nprocs, BODY, "}\n");
746 }
747 (void) rc;
748 }
749
750 void vif_open (void)
751 {
752 int_4 rc, lrecl = 0;
753 char *daction = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *ddisp = NO_TEXT, *iostat = NO_TEXT;
754 LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
755 RECORD str, fmt;
756 EXPR unit;
757 RECCLR (fmt);
758 rc = scan (EXPECT_NONE);
759 io_specs (&unit, ERR, fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
760 if (dfn != NO_TEXT) {
761 _srecordf (str, "_fregister (\"%s\", %s, %d, %s, %s, %s, %s);\n", stat_start, unum (&unit), lrecl, dfn, dform, daction, ddisp);
762 } else {
763 _srecordf (str, "_fregister (\"%s\", %s, %d, NULL, %s, %s, %s);\n", stat_start, unum (&unit), lrecl, dform, daction, ddisp);
764 }
765 code (nprocs, BODY, str);
766 if (iostat != NO_TEXT) {
767 RECORD ios;
768 _srecordf (ios, "%s = errno;\n", iostat);
769 code (nprocs, BODY, ios);
770 }
771 (void) rc;
772 }
773
774 void do_io (char *proc, int_4 *nest)
775 {
776 int_4 form = UNFORMATTED, lrecl = 0;
777 LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
778 RECORD fstr, fid, iorc, str, fmt;
779 char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
780 EXPR unit;
781 unit.mode.type = INTEGER;
782 unit.mode.len = 4;
783 fmt[0] = '\0';
784 fstr[0] = '\0';
785 fid[0] = '\0';
786 iorc[0] = '\0';
787 int_4 rc = scan (EXPECT_NONE);
788 if (EQUAL (proc, "read") || EQUAL (proc, "accept")) {
789 if (TOKEN ("*")) {
790 _srecordf (unit.str, "STDF_IN");
791 dform = form_formatted;
792 rc = scan (EXPECT_NONE);
793 } else if (rc == INT_NUMBER) { // FORTRAN II
794 _srecordf (unit.str, "STDF_IN");
795 bufcpy (fmt, curlex, RECLN);
796 dform = form_formatted;
797 rc = scan (EXPECT_NONE);
798 } else if (rc == TEXT) {
799 _srecordf (unit.str, "STDF_IN");
800 int_4 k = format_str (curlex);
801 _srecordf (fmt, "%d", k);
802 dform = form_formatted;
803 rc = scan (EXPECT_NONE);
804 } else {
805 io_specs (&unit, STDF_IN, fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
806 }
807 } else if (EQUAL (proc, "write") || EQUAL (proc, "print") || EQUAL (proc, "punch")) {
808 if (TOKEN ("*")) {
809 _srecordf (unit.str, "STDF_OUT");
810 dform = form_formatted;
811 rc = scan (EXPECT_NONE);
812 } else if (rc == INT_NUMBER) { // FORTRAN II
813 _srecordf (unit.str, "STDF_OUT");
814 bufcpy (fmt, curlex, RECLN);
815 dform = form_formatted;
816 rc = scan (EXPECT_NONE);
817 } else if (rc == TEXT) {
818 _srecordf (unit.str, "STDF_OUT");
819 int_4 k = format_str (curlex);
820 _srecordf (fmt, "%d", k);
821 dform = form_formatted;
822 rc = scan (EXPECT_NONE);
823 } else {
824 io_specs (&unit, STDF_OUT, fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
825 }
826 }
827 if (strlen (fmt) == 0 && dform != form_unformatted) {
828 form = STDFORMAT;
829 } else if (strlen (fmt) == 0 && dform == form_unformatted) {
830 form = UNFORMATTED;
831 } else {
832 form = FORMATTED;
833 }
834 // IO to a string implies UNIT=0.
835 if (unit.mode.type == CHARACTER) {
836 if (EQUAL (proc, "read")) {
837 _srecordf (str, "_ffile[0].unit = fmemopen (%s, %d, \"r\");\n", unit.str, unit.mode.len + 1);
838 } else if (EQUAL (proc, "accept")) {
839 _srecordf (str, "_ffile[0].unit = fmemopen (%s, %d, \"r\");\n", unit.str, unit.mode.len + 1);
840 } else if (EQUAL (proc, "write")) {
841 _srecordf (str, "_ffile[0].unit = fmemopen (%s, %d, \"w\");\n", unit.str, unit.mode.len + 1);
842 } else if (EQUAL (proc, "print")) {
843 _srecordf (str, "_ffile[0].unit = fmemopen (%s, %d, \"w\");\n", unit.str, unit.mode.len + 1);
844 } else if (EQUAL (proc, "punch")) {
845 _srecordf (str, "_ffile[0].unit = fmemopen (%s, %d, \"w\");\n", unit.str, unit.mode.len + 1);
846 }
847 code (nprocs, BODY, str);
848 }
849 // Runtime checks - can the file do this?
850 if (EQUAL (proc, "read")) {
851 _srecordf (str, "_fcheck (\"%s\", %s, action_read, %s);\n", stat_start, unum (&unit), dform);
852 } else if (EQUAL (proc, "accept")) {
853 _srecordf (str, "_fcheck (\"%s\", %s, action_read, %s);\n", stat_start, unum (&unit), dform);
854 } else if (EQUAL (proc, "write")) {
855 _srecordf (str, "_fcheck (\"%s\", %s, action_write, %s);\n", stat_start, unum (&unit), dform);
856 } else if (EQUAL (proc, "print")) {
857 _srecordf (str, "_fcheck (\"%s\", %s, action_write, %s);\n", stat_start, unum (&unit), dform);
858 } else if (EQUAL (proc, "punch")) {
859 _srecordf (str, "_fcheck (\"%s\", %s, action_write, %s);\n", stat_start, unum (&unit), dform);
860 }
861 code (nprocs, BODY, str);
862 if (form == FORMATTED) {
863 RECORD fcnt;
864 int_4 val;
865 _srecordf (fid, "__fcnt");
866 add_local (fid, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
867 _srecordf (iorc, "__rc");
868 add_local (iorc, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
869 _srecordf (fcnt, "%s = 0;\n", fid);
870 code (nprocs, BODY, fcnt);
871 if (isint_4 (fmt, &val)) {
872 _srecordf (fstr, "%s", edit_fmt (val));
873 } else {
874 MODE mode;
875 IDENT *idf = find_local (fmt, &mode);
876 if (idf == NO_IDENT) {
877 ERROR (3020, "undeclared format identifier", fmt);
878 } else if (mode.type == INTEGER) {
879 // Assigned FORMAT.
880 _srecordf (str, "switch (%s) {\n", C_NAME (idf));
881 code (nprocs, BODY, str);
882 code (nprocs, BODY, "default:\n");
883 for (int_4 k = 0; k < nlabels; k++) {
884 LBL *L = &labels[k];
885 if (L->format) {
886 L->jumped++;
887 _srecordf (str, "case %d: __fmt_a = %s; break;\n", L->index, edit_fmt(L->num));
888 code (nprocs, BODY, str);
889 }
890 }
891 code (nprocs, BODY, "}\n");
892 strcpy (fstr, "__fmt_a");
893 } else if (mode.type == CHARACTER) {
894 _srecordf (str, "__fmt_a = _vif_jit (\"%s\", %s);\n", stat_start, C_NAME (idf));
895 code (nprocs, BODY, str);
896 strcpy (fstr, "__fmt_a");
897 } else {
898 ERROR (3021, "format identifier mode error", qtype (&mode));
899 }
900 }
901 } else {
902 _srecordf (iorc, "__rc_%d", nloctmps++);
903 add_local (iorc, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
904 }
905 // Start-of-record.
906 if (form == FORMATTED) {
907 if (EQUAL (proc, "read")) {
908 io_text_items ("read", &unit, fstr, fid, iorc, endlbl, errlbl);
909 } else if (EQUAL (proc, "accept")) {
910 io_text_items ("read", &unit, fstr, fid, iorc, endlbl, errlbl);
911 } else if (EQUAL (proc, "write")) {
912 io_text_items ("write", &unit, fstr, fid, iorc, endlbl, errlbl);
913 } else if (EQUAL (proc, "print")) {
914 io_text_items ("write", &unit, fstr, fid, iorc, endlbl, errlbl);
915 } else if (EQUAL (proc, "punch")) {
916 io_text_items ("write", &unit, fstr, fid, iorc, endlbl, errlbl);
917 }
918 }
919 int_4 items = 0;
920 if (EQUAL (proc, "read")) {
921 io_list ("read", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
922 } else if (EQUAL (proc, "accept")) {
923 io_list ("read", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
924 } else if (EQUAL (proc, "write")) {
925 io_list ("write", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
926 } else if (EQUAL (proc, "print")) {
927 io_list ("write", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
928 } else if (EQUAL (proc, "punch")) {
929 io_list ("write", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
930 }
931 if (unit.mode.type == CHARACTER) {
932 // IO to a string implies UNIT=0.
933 code (nprocs, BODY, "_fclose (0);\n");
934 } else if (EQUAL (proc, "write") || EQUAL (proc, "print") || EQUAL (proc, "punch")) {
935 // End-of-record.
936 if (form != UNFORMATTED) {
937 _srecordf (str, "_write_eol (%s);\n", unum (&unit));
938 code (nprocs, BODY, str);
939 }
940 } else if (EQUAL (proc, "read") || EQUAL (proc, "accept")) {
941 // End-of-record.
942 if (form != UNFORMATTED) {
943 _srecordf (str, "_read_eol (%s);\n", unum (&unit));
944 code (nprocs, BODY, str);
945 }
946 }
947 //
948 save_iostat (iostat);
949 //
950 (void) rc;
951 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
