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 store_var (char *var, MODE *mode, char *val)
38 {
39 if (var != NO_TEXT) {
40 EXPR loc;
41 NEW_RECORD (nam);
42 _srecordf (nam, "%s", var);
43 RECCLR (loc.str);
44 factor_variable (&loc, NO_IDENT, NO_MODE, nam);
45 if (mode->type == CHARACTER) {
46 if ((loc.mode.type == mode->type) && (loc.mode.len >= mode->len)) {
47 NEW_RECORD (str);
48 _srecordf (str, "strcpy (%s, %s);\n", loc.str, val);
49 code (nprocs, BODY, str);
50 } else {
51 MODE_ERROR (3301, qtype (mode), qtype (&(loc.mode)));
52 }
53 } else {
54 if ((loc.mode.type == mode->type) && (loc.mode.len == mode->len)) {
55 NEW_RECORD (str);
56 _srecordf (str, "%s = %s;\n", loc.str, val);
57 code (nprocs, BODY, str);
58 } else {
59 MODE_ERROR (3302, qtype (mode), qtype (&(loc.mode)));
60 }
61 }
62 }
63 }
64
65 void store_iostat (char *iostat)
66 {
67 MODE mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
68 store_var (iostat, &mode, "errno");
69 }
70
71 void io_event (char *proc, EXPR *unit, char *iorc, LBL *endlbl, LBL *errlbl)
72 {
73 if (EQUAL (proc, "write")) {
74 NEW_RECORD (str);
75 if (errlbl == NO_LABEL) {
76 _srecordf (str, "_write_err (%s, %s, _ioerr_%s (\"%s\", %s));\n", iorc, unum (unit), proc, stat_start, unum (unit));
77 } else {
78 _srecordf (str, "_write_err (%s, %s, goto _l%d);\n", iorc, unum (unit), errlbl->num);
79 }
80 code (nprocs, BODY, str);
81 } else if (EQUAL (proc, "read")) {
82 NEW_RECORD (str1);
83 NEW_RECORD (str2);
84 NEW_RECORD (str);
85 if (endlbl == NO_LABEL) {
86 _srecordf (str1, "_ioend_%s (\"%s\", %s)", proc, stat_start, unum (unit));
87 } else {
88 _srecordf (str1, "goto _l%d", endlbl->num);
89 }
90 if (errlbl == NO_LABEL) {
91 _srecordf (str2, "_ioerr_%s (\"%s\", %s)", proc, stat_start, unum (unit));
92 } else {
93 _srecordf (str2, "goto _l%d", errlbl->num);
94 }
95 _srecordf (str, "_read_err (%s, %s, %s, %s);\n", iorc, unum (unit), str1, str2);
96 code (nprocs, BODY, str);
97 } else {
98 BUG ("io_event");
99 }
100 }
101
102 void io_parm (EXPR *reg, char *elem)
103 {
104 if (reg->variant == EXPR_VAR) {
105 if (IS_ROW (reg->mode)) {
106 _srecordf (elem, "%s", reg->str);
107 } else if (reg->str[0] == '*') {
108 _srecordf (elem, "%s", ®->str[1]);
109 } else if (reg->mode.type == CHARACTER) {
110 _srecordf (elem, "%s", reg->str);
111 } else {
112 (void) impl_decl (reg->str, NO_MODE);
113 _srecordf (elem, "&%s", reg->str);
114 }
115 } else if (reg->variant == EXPR_SLICE) {
116 _srecordf (elem, "&%s", reg->str);
117 } else {
118 NEW_RECORD (tmp);
119 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
120 if (reg->mode.type == CHARACTER) {
121 norm_mode (®->mode);
122 if (reg->mode.len == 0) {
123 add_local (tmp, reg->mode.type, MAX_STRLEN, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
124 _srecordf (elem, "strcpy (%s, %s);\n", tmp, reg->str);
125 } else {
126 add_local (tmp, reg->mode.type, reg->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
127 _srecordf (elem, "bufcpy (%s, %s, %d);\n", tmp, reg->str, reg->mode.len);
128 }
129 code (nprocs, BODY, elem);
130 _srecordf (elem, "%s", tmp);
131 } else {
132 add_local (tmp, reg->mode.type, reg->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
133 _srecordf (elem, "%s = %s;\n", tmp, reg->str);
134 code (nprocs, BODY, elem);
135 _srecordf (elem, "&%s", tmp);
136 }
137 }
138 }
139
140 void io_text_items (char *proc, EXPR *unit, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, logical_4 term)
141 {
142 NEW_RECORD (str);
143 if (EQUAL (proc, "write")) {
144 _srecordf (str, "while (%s[%s] != NULL && %s[%s] == FMT_TEXT) {\n", fstr, fid, fstr, fid);
145 code (nprocs, BODY, str);
146 if (term) {
147 _srecordf (str, "if (%s[%s + 2] == FMT_TERM) {\n", fstr, fid);
148 code (nprocs, BODY, str);
149 code (nprocs, BODY, "break;\n");
150 code (nprocs, BODY, "}\n");
151 }
152 _srecordf (str, "%s = _vif_printf (%s, %s[%s + 2], NULL, NOTYPE, 0);\n", iorc, unum (unit), fstr, fid);
153 code (nprocs, BODY, str);
154 io_event (proc, unit, iorc, endlbl, errlbl);
155 _srecordf (str, "%s += 3;\n", fid);
156 code (nprocs, BODY, str);
157 code (nprocs, BODY, "}\n");
158 } else if (EQUAL (proc, "read")) {
159 _srecordf (str, "while (%s[%s] != NULL && %s[%s] == FMT_TEXT) {\n", fstr, fid, fstr, fid);
160 code (nprocs, BODY, str);
161 _srecordf (str, "%s = _vif_scanf (%s, %s[%s + 1], NULL, NOTYPE, 0);\n", iorc, unum (unit), fstr, fid);
162 code (nprocs, BODY, str);
163 io_event (proc, unit, iorc, endlbl, errlbl);
164 _srecordf (str, "%s += 3;\n", fid);
165 code (nprocs, BODY, str);
166 code (nprocs, BODY, "}\n");
167 }
168 }
169
170 void io_format (char *proc, EXPR *unit, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, char *elem, char *type, int_4 len)
171 {
172 NEW_RECORD (str);
173 if (EQUAL (proc, "write")) {
174 _srecordf (str, "if (%s[%s] == NULL) {\n", fstr, fid);
175 code (nprocs, BODY, str);
176 _srecordf (str, "%s = 0;\n", fid);
177 code (nprocs, BODY, str);
178 _srecordf (str, "%s = fprintf (_ffile[%s].unit, \"\\n\");\n", iorc, unum (unit));
179 code (nprocs, BODY, str);
180 io_text_items (proc, unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
181 code (nprocs, BODY, "};\n");
182 _srecordf (str, "%s = _vif_printf (%s, %s[%s + 2], %s, %s, %d);\n", iorc, unum (unit), fstr, fid, elem, type, len);
183 code (nprocs, BODY, str);
184 io_event (proc, unit, iorc, endlbl, errlbl);
185 _srecordf (str, "%s += 3;\n", fid);
186 code (nprocs, BODY, str);
187 io_text_items (proc, unit, fstr, fid, iorc, endlbl, errlbl, TRUE);
188 } else if (EQUAL (proc, "read")) {
189 _srecordf (str, "if (%s[%s] == NULL) {\n", fstr, fid);
190 code (nprocs, BODY, str);
191 _srecordf (str, "%s = 0;\n", fid);
192 code (nprocs, BODY, str);
193 _srecordf (str, "_vif_scanf (%s, NULL, NULL, NOTYPE, 0);\n", unum (unit));
194 code (nprocs, BODY, str);
195 io_text_items (proc, unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
196 code (nprocs, BODY, "};\n");
197 _srecordf (str, "%s = _vif_scanf (%s, %s[%s + 1], %s, %s, %d);\n", iorc, unum (unit), fstr, fid, elem, type, len);
198 code (nprocs, BODY, str);
199 io_event (proc, unit, iorc, endlbl, errlbl);
200 _srecordf (str, "%s += 3;\n", fid);
201 code (nprocs, BODY, str);
202 io_text_items (proc, unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
203 }
204 }
205
206 void io_elemuf (char *proc, EXPR *unit, EXPR *reg, char *iorc, LBL *endlbl, LBL *errlbl, int_4 *items)
207 {
208 NEW_RECORD (str);
209 NEW_RECORD (elem);
210 io_parm (reg, elem);
211 if (EQUAL (proc, "write")) {
212 _srecordf (str, "%s = fwrite (%s", iorc, elem);
213 code (nprocs, BODY, str);
214 } else if (EQUAL (proc, "read")) {
215 _srecordf (str, "%s = fread (%s", iorc, elem);
216 code (nprocs, BODY, str);
217 } else {
218 BUG ("io_elemuf");
219 }
220 _srecordf (str, ", sizeof (%s), ", wtype (®->mode, NOARG, NOFUN));
221 code (nprocs, BODY, str);
222 if (reg->variant == EXPR_VAR && IS_ROW (reg->mode)) {
223 code_row_len (reg->idf);
224 } else {
225 code (nprocs, BODY, "1");
226 }
227 _srecordf (str, ", _ffile[%s].unit);\n", unum (unit));
228 code (nprocs, BODY, str);
229 io_event (proc, unit, iorc, endlbl, errlbl);
230 }
231
232 void io_elemstd (char *proc, EXPR *unit, EXPR *reg, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, int_4 *items)
233 {
234 NEW_RECORD (str);
235 NEW_RECORD (elem);
236 io_parm (reg, elem);
237 if (reg->mode.type == INTEGER) {
238 if (EQUAL (proc, "write")) {
239 _srecordf (str, "%s = _vif_printf (%s, \"%%d\", %s, INTEGER, %d);\n", iorc, unum (unit), elem, reg->mode.len);
240 } else if (EQUAL (proc, "read")) {
241 _srecordf (str, "%s = _vif_scanf (%s, \"%%d\", %s, INTEGER, %d);\n", iorc, unum (unit), elem, reg->mode.len);
242 }
243 } else if (reg->mode.type == LOGICAL) {
244 if (EQUAL (proc, "write")) {
245 _srecordf (str, "%s = _vif_printf (%s, \"%%c\", %s, LOGICAL, %d);\n", iorc, unum (unit), elem, reg->mode.len);
246 } else if (EQUAL (proc, "read")) {
247 _srecordf (str, "%s = _vif_scanf (%s, \"%%c\", %s, LOGICAL, %d);\n", iorc, unum (unit), elem, reg->mode.len);
248 }
249 } else if (reg->mode.type == REAL) {
250 if (EQUAL (proc, "write")) {
251 NEW_RECORD (fmt);
252 if (reg->mode.len == 32) {
253 _srecordf (fmt, "\"%%.%de\"", FLT256_DIG);
254 _srecordf (str, "%s = _vif_printf (%s, %s, %s, REAL, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
255 } else if (reg->mode.len == 16) {
256 _srecordf (fmt, "\"%%.%de\"", FLT128_DIG);
257 _srecordf (str, "%s = _vif_printf (%s, %s, %s, REAL, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
258 } else if (reg->mode.len == 8) {
259 _srecordf (fmt, "\"%%.%de\"", DBL_DIG);
260 _srecordf (str, "%s = _vif_printf (%s, %s, %s, REAL, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
261 } else if (reg->mode.len == 4) {
262 _srecordf (fmt, "\"%%.%de\"", FLT_DIG);
263 _srecordf (str, "%s = _vif_printf (%s, %s, %s, REAL, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
264 }
265 } else if (EQUAL (proc, "read")) {
266 _srecordf (str, "%s = _vif_scanf (%s, \"%%e\", %s, REAL, %d);\n", iorc, unum (unit), elem, reg->mode.len);
267 }
268 } else if (reg->mode.type == COMPLEX) {
269 if (EQUAL (proc, "write")) {
270 NEW_RECORD (fmt);
271 if (reg->mode.len == 8) {
272 _srecordf (fmt, "\"%%.%de\"", FLT_DIG);
273 } else if (reg->mode.len == 16) {
274 _srecordf (fmt, "\"%%.%de\"", DBL_DIG);
275 } else if (reg->mode.len == 32) {
276 _srecordf (fmt, "\"%%.%de\"", FLT128_DIG);
277 } else if (reg->mode.len == 64) {
278 _srecordf (fmt, "\"%%.%de\"", FLT256_DIG);
279 }
280 _srecordf (str, "%s = _vif_printf (%s, %s, %s, COMPLEX, %d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
281 code (nprocs, BODY, str);
282 io_event (proc, unit, iorc, endlbl, errlbl);
283 _srecordf (str, "%s = _vif_printf (%s, \" \", NULL, NOTYPE, 0);\n", iorc, unum (unit));
284 code (nprocs, BODY, str);
285 io_event (proc, unit, iorc, endlbl, errlbl);
286 _srecordf (str, "%s = _vif_printf (%s, %s, %s, COMPLEX, -%d);\n", iorc, unum (unit), fmt, elem, reg->mode.len);
287 } else if (EQUAL (proc, "read")) {
288 _srecordf (str, "%s = _vif_scanf (%s, \"%%e\", %s, COMPLEX, %d);\n", iorc, unum (unit), elem, reg->mode.len);
289 code (nprocs, BODY, str);
290 io_event (proc, unit, iorc, endlbl, errlbl);
291 _srecordf (str, "%s = _vif_scanf (%s, \"%%e\", %s, COMPLEX, -%d);\n", iorc, unum (unit), elem, reg->mode.len);
292 }
293 } else if (reg->mode.type == CHARACTER) {
294 if (EQUAL (proc, "write")) {
295 // _srecordf (str, "%s = _vif_printf (%s, \"%%-%ds\", %s, CHARACTER, %d);\n", iorc, unum (unit), reg->mode.len, elem, reg->mode.len);
296 _srecordf (str, "%s = _vif_printf (%s, \"%%s\", %s, CHARACTER, %d);\n", iorc, unum (unit), elem, reg->mode.len);
297 } else if (EQUAL (proc, "read")) {
298 // _srecordf (str, "%s = _vif_scanf (%s, \"%%%ds\", %s, CHARACTER, %d);\n", iorc, unum (unit), reg->mode.len, elem, reg->mode.len);
299 _srecordf (str, "%s = _vif_scanf (%s, \"%%s\", %s, CHARACTER, %d);\n", iorc, unum (unit), elem, reg->mode.len);
300 }
301 }
302 code (nprocs, BODY, str);
303 io_event (proc, unit, iorc, endlbl, errlbl);
304 (*items) ++;
305 }
306
307 void io_elemf (char *proc, EXPR *unit, EXPR *reg, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, int_4 *items)
308 {
309 NEW_RECORD (elem);
310 io_parm (reg, elem);
311 if (reg->mode.type == INTEGER) {
312 io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "INTEGER", reg->mode.len);
313 (*items) ++;
314 } else if (reg->mode.type == LOGICAL) {
315 io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "LOGICAL", reg->mode.len);
316 (*items) ++;
317 } else if (reg->mode.type == REAL) {
318 io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "REAL", reg->mode.len);
319 (*items) ++;
320 } else if (reg->mode.type == COMPLEX) {
321 io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "COMPLEX", reg->mode.len);
322 io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "COMPLEX", -reg->mode.len);
323 (*items) ++;
324 } else if (reg->mode.type == CHARACTER) {
325 io_format (proc, unit, fstr, fid, iorc, endlbl, errlbl, elem, "CHARACTER", reg->mode.len);
326 (*items) ++;
327 }
328 }
329
330 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)
331 {
332 NEW_RECORD (str); NEW_RECORD (tmpa); NEW_RECORD (tmpk);
333 EXPR elem;
334 IDENT *ptr;
335 _srecordf (tmpa, "_arr_%d", nloctmps++);
336 ptr = add_local (tmpa, reg->mode.type, reg->mode.len, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
337 ptr->alias = reg->idf;
338 _srecordf (tmpk, "_k_%d", nloctmps++);
339 add_local (tmpk, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
340 _srecordf (str, "for (%s = %s %s, %s = 0; %s < ", tmpa, ptr_to_array (ptr, NOCONST, CAST, ACTUAL), reg->str, tmpk, tmpk);
341 code (nprocs, BODY, str);
342 code_row_len (reg->idf);
343 _srecordf (str, "; %s++, %s++) {\n", tmpa, tmpk);
344 code (nprocs, BODY, str);
345 memcpy (&elem, reg, sizeof (EXPR));
346 elem.mode.dim = 0;
347 if (EQUAL (proc, "read")) {
348 _srecordf (elem.str, "%s", tmpa);
349 } else if (EQUAL (proc, "write")) {
350 _srecordf (elem.str, "*%s", tmpa);
351 } else {
352 BUG ("io_array");
353 }
354 if (form == STDFORMAT) {
355 io_elemstd (proc, unit, &elem, fstr, fid, iorc, endlbl, errlbl, items);
356 } else if (form == FORMATTED) {
357 io_elemf (proc, unit, &elem, fstr, fid, iorc, endlbl, errlbl, items);
358 }
359 code (nprocs, BODY, "}\n");
360 }
361
362 void io_elem (char *proc, EXPR *unit, int_4 form, char *fstr, char *fid, char *iorc, LBL *endlbl, LBL *errlbl, int_4 *items)
363 {
364 EXPR reg;
365 macro_depth = 0;
366 express (®, NOTYPE, 0);
367 if (form == UNFORMATTED) {
368 io_elemuf (proc, unit, ®, iorc, endlbl, errlbl, items);
369 } else if (form == STDFORMAT) {
370 if (reg.variant == EXPR_VAR && IS_ROW (reg.mode)) {
371 io_array (proc, unit, ®, form, fstr, fid, iorc, endlbl, errlbl, items);
372 } else {
373 io_elemstd (proc, unit, ®, fstr, fid, iorc, endlbl, errlbl, items);
374 }
375 } else if (form == FORMATTED) {
376 if (reg.variant == EXPR_VAR && IS_ROW (reg.mode)) {
377 io_array (proc, unit, ®, form, fstr, fid, iorc, endlbl, errlbl, items);
378 } else {
379 io_elemf (proc, unit, ®, fstr, fid, iorc, endlbl, errlbl, items);
380 }
381 } else {
382 BUG ("IO formatting unspecified");
383 }
384 }
385
386 int_4 impl_do (void)
387 {
388 // Quick check whether (...) in a list is an implied DO loop.
389 int_4 rc, nest = 1;
390 while ((rc = scan (EXPECT_NONE)) != END_OF_LINE) {
391 if (TOKEN ("(")) {
392 nest++;
393 } else if (TOKEN (")")) {
394 nest--;
395 if (nest == 0) {
396 return FALSE;
397 }
398 } else if (nest == 1 && TOKEN (",")) {
399 // Trigger is the sequence ", I =" in outer nest.
400 rc = scan (EXPECT_NONE);
401 if (rc == WORD) {
402 NEW_RECORD (name);
403 RECCPY (name, curlex);
404 rc = scan (EXPECT_NONE);
405 if (TOKEN ("=")) {
406 (void) impl_decl (name, NO_MODE);
407 return TRUE;
408 } else {
409 UNSCAN;
410 }
411 }
412 }
413 }
414 (void) rc;
415 return FALSE;
416 }
417
418 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)
419 {
420 while (WITHIN) {
421 int_4 rc;
422 if (TOKEN (",")) {
423 rc = scan (EXPECT_NONE);
424 if (! WITHIN) {
425 SYNTAX (3303, prelex);
426 break;
427 }
428 if (TOKEN (",")) {
429 SYNTAX (3304, ",,");
430 continue;
431 }
432 } else {
433 rc = scan (EXPECT_NONE);
434 if (TOKEN (",")) {
435 continue;
436 }
437 }
438 if (! WITHIN) {
439 break;
440 }
441 if (TOKEN ("(")) {
442 SAVE_POS (1);
443 // Quick lookahead.
444 int_4 loop = impl_do ();
445 // Restore.
446 RESTORE_POS (1);
447 UNSCAN;
448 rc = scan ("(");
449 // Decide.
450 if (loop) {
451 (*nest)++;
452 int_4 where = code (nprocs, BODY, NO_TEXT);
453 io_list (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, where, nest, items);
454 } else {
455 io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
456 rc = scan (EXPECT_NONE);
457 }
458 } else if (TOKEN (")")) {
459 // Expression closed by ')'
460 (*nest)--;
461 return;
462 } else if (rc == WORD) {
463 if (*nest == 0) {
464 io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
465 rc = scan (EXPECT_NONE);
466 } else {
467 SAVE_POS (2);
468 rc = scan (EXPECT_NONE);
469 if (!TOKEN ("=")) {
470 RESTORE_POS (2);
471 UNSCAN;
472 rc = scan (EXPECT_NONE);
473 io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
474 rc = scan (EXPECT_NONE);
475 } else {
476 NEW_RECORD (lid); NEW_RECORD (loop);
477 EXPR from, to, by;
478 MODE mode;
479 IDENT *idf = impl_decl (prelex, &mode);
480 if (idf->arg || idf->alias != NULL) {
481 _srecordf (lid, "*%s", C_NAME (idf));
482 } else {
483 (void) idf_full_c_name (lid, idf);
484 }
485 rc = scan (EXPECT_NONE);
486 express (&from, idf->mode.type, idf->mode.len);
487 rc = scan (",");
488 rc = scan (EXPECT_NONE);
489 express (&to, idf->mode.type, idf->mode.len);
490 rc = scan (EXPECT_NONE);
491 if (TOKEN (",")) {
492 rc = scan (EXPECT_NONE);
493 express (&by, idf->mode.type, idf->mode.len);
494 _srecordf (loop, "for (%s = %s; %s <= %s; %s += %s) {\n",
495 lid, from.str, lid, to.str, lid, by.str);
496 rc = scan (EXPECT_NONE);
497 } else {
498 _srecordf (loop, "for (%s = %s; %s <= %s; %s++) {\n",
499 lid, from.str, lid, to.str, lid);
500 }
501 patch (lpatch, loop);
502 if (TOKEN (")")) {
503 // Implied DO loop closed by ')'.
504 (*nest)--;
505 code (nprocs, BODY, "}; // implied DO \n");
506 } else {
507 EXPECT (3305, ")");
508 }
509 return;
510 }
511 }
512 } else {
513 io_elem (proc, unit, form, fstr, fid, iorc, endlbl, errlbl, items);
514 rc = scan (EXPECT_NONE);
515 }
516 }
517 }
518
519 void io_unit (EXPR *unit, int_4 defunit)
520 {
521 // Reasonable default.
522 unit->mode.type = INTEGER;
523 unit->mode.len = 4;
524 //
525 if (TOKEN ("*")) {
526 _srecordf (unit->str, "%d", defunit);
527 } else if (TOKEN ("stdin")) {
528 _srecordf (unit->str, "STDF_IN");
529 } else if (TOKEN ("stdout")) {
530 _srecordf (unit->str, "STDF_OUT");
531 } else if (TOKEN ("stderr")) {
532 _srecordf (unit->str, "STDF_ERR");
533 } else {
534 EXPR reg;
535 macro_depth = 0;
536 express (®, NOTYPE, NOLEN);
537 if (reg.mode.type == INTEGER) {
538 if (reg.variant == EXPR_CONST) {
539 _srecordf (unit->str, "%s", reg.str);
540 int_4 val;
541 (void) is_int4 (unit->str, &val);
542 if (val < 1 || val > MAX_FTN_FILES - 1) {
543 ERROR (3306, "unit number out of range", unit->str);
544 }
545 } else {
546 NEW_RECORD (str);
547 _srecordf (unit->str, "%s", edit_unit (nloctmps++));
548 add_local (unit->str, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
549 _srecordf (str, "%s = %s;\n", unit, reg.str);
550 code (nprocs, BODY, str);
551 }
552 } else if (reg.mode.type == CHARACTER) {
553 (*unit) = reg;
554 } else {
555 ERROR (3307, "unit must be INTEGER or CHARACTER", NO_TEXT);
556 }
557 }
558 }
559
560 // static void io_specs (char *proc, EXPR *unit, int_4 defunit, EXPR *rec, EXPR *fmt, char **fn, char **form, char **action, int_4 *lrecl, char **disp, LBL **end, LBL **err, char **iostat)
561 static void io_specs (char *proc, EXPR *unit, int_4 defunit, EXPR *rec, EXPR *fmt, char **fn, char **form, char **action, int_4 *lrecl, char **disp, LBL **end, LBL **err, char **iostat)
562 {
563 int_4 rc, parm = 1;
564 RECCLR (unit->str);
565 RECCLR (rec->str);
566 RECCLR (fmt->str);
567 *action = action_default;
568 *disp = disp_old;
569 *end = NO_LABEL;
570 *err = NO_LABEL;
571 *fn = NO_TEXT;
572 *form = form_unformatted;
573 *iostat = NO_TEXT;
574 rec->str[0] = '\0';
575 // We accept that only a unit specification follows.
576 if (curret == INT_NUMBER || curret == WORD) {
577 io_unit (unit, defunit);
578 return;
579 }
580 if (TOKEN ("(")) {
581 rc = scan (EXPECT_NONE);
582 } else {
583 EXPECT (3308, "(");
584 return;
585 }
586 //
587 while (!TOKEN (")") && rc != END_OF_MODULE) {
588 // ([UNIT], [FMT] [, FMT=n | FILE=expr | FORM=str | action=str | DISP=str | END=n | ERR=n])
589 if (TOKEN ("unit") && lookahead ("=")) {
590 rc = scan ("=");
591 rc = scan (EXPECT_NONE);
592 io_unit (unit, defunit);
593 } else if (TOKEN ("rec") && lookahead ("=")) {
594 rc = scan ("=");
595 rc = scan (EXPECT_NONE);
596 macro_depth = 0;
597 express (rec, INTEGER, 4);
598 } else if (TOKEN ("file") && lookahead ("=")) {
599 EXPR reg;
600 rc = scan ("=");
601 rc = scan (EXPECT_NONE);
602 macro_depth = 0;
603 if (express (®, CHARACTER, NOLEN)) {
604 *fn = f_stralloc (reg.str);
605 }
606 } else if (TOKEN ("form") && lookahead ("=")) {
607 rc = scan ("=");
608 rc = scan (EXPECT_NONE);
609 if (MATCH ("formatted")) {
610 *form = form_formatted;
611 } else if (MATCH ("unformatted")) {
612 *form = form_unformatted;
613 } else {
614 SYNTAX (3309, "invalid FORM specification");
615 }
616 } else if ((TOKEN ("action") || TOKEN ("access")) && lookahead ("=")) {
617 rc = scan ("=");
618 rc = scan (EXPECT_NONE);
619 if (MATCH ("read")) {
620 *action = action_read;
621 } else if (MATCH ("write")) {
622 *action = action_write;
623 } else if (MATCH ("readwrite")) {
624 *action = action_readwrite;
625 } else if (MATCH ("direct")) {
626 *action = action_readwrite;
627 } else {
628 SYNTAX (3310, "invalid ACCESS specification");
629 }
630 } else if ((TOKEN ("disp") || TOKEN ("status")) && lookahead ("=")) {
631 // Straight from JCL :-)
632 rc = scan ("=");
633 rc = scan (EXPECT_NONE);
634 if (MATCH ("old")) {
635 *disp = disp_old;
636 } else if (MATCH ("new")) {
637 *disp = disp_new;
638 } else if (MATCH ("keep")) {
639 *disp = disp_keep;
640 } else if (MATCH ("delete")) {
641 *disp = disp_delete;
642 } else if (MATCH ("unknown")) {
643 *disp = disp_new;
644 } else {
645 SYNTAX (3311, "invalid DISP specification");
646 }
647 } else if ((TOKEN ("lrecl") || TOKEN ("recl")) && lookahead ("=")) {
648 rc = scan ("=");
649 rc = scan (EXPECT_NONE);
650 macro_depth = 0;
651 express (rec, INTEGER, 4);
652 } else if (TOKEN ("fmt") && lookahead ("=")) {
653 rc = scan ("=");
654 rc = scan (EXPECT_NONE);
655 if (TOKEN ("*")) {
656 *form = form_formatted;
657 } else if (rc == INT_NUMBER) {
658 bufcpy (fmt->str, curlex, RECLN);
659 fmt->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
660 *form = form_formatted;
661 } else if (rc == WORD) {
662 macro_depth = 0;
663 express (fmt, NOTYPE, NOLEN);
664 *form = form_formatted;
665 } else if (rc == TEXT) {
666 int_4 k = format_str (curlex);
667 _srecordf (fmt->str, "%d", k);
668 fmt->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
669 *form = form_formatted;
670 } else {
671 EXPECT (3312, "label or format string");
672 }
673 } else if (TOKEN ("end") && lookahead ("=")) {
674 rc = scan ("=");
675 if ((rc = scan (EXPECT_LABEL)) == LABEL) {
676 if (((*end) = find_label (curlex)) == NO_LABEL) {
677 ERROR (3313, "no such label", curlex);
678 }
679 (*end)->jumped++;
680 } else {
681 EXPECT (3314, "label");
682 }
683 } else if (TOKEN ("err") && lookahead ("=")) {
684 rc = scan ("=");
685 if ((rc = scan (EXPECT_LABEL)) == LABEL) {
686 if (((*err) = find_label (curlex)) == NO_LABEL) {
687 ERROR (3315, "no such label", curlex);
688 }
689 (*err)->jumped++;
690 } else {
691 EXPECT (3316, "label");
692 }
693 } else if (TOKEN ("iostat") && lookahead ("=")) {
694 rc = scan ("=");
695 rc = scan (EXPECT_NONE);
696 if (rc != WORD) {
697 EXPECT (3317, "variable")
698 } else {
699 (void) impl_decl (curlex, NO_MODE);
700 *iostat = f_stralloc (curlex);
701 }
702 } else {
703 if (EQUAL (proc, "encode") || EQUAL (proc, "decode")) {
704 if (parm == 1 && rc == INT_NUMBER) {
705 (void) is_int4 (curlex, lrecl);
706 } else if (parm == 2 && TOKEN ("*")) {
707 ;
708 } else if (parm == 2 && rc == WORD) {
709 macro_depth = 0;
710 express (fmt, NOTYPE, NOLEN);
711 *form = form_formatted;
712 } else if (parm == 2 && rc == TEXT) {
713 int_4 k = format_str (curlex);
714 _srecordf (fmt->str, "%d", k);
715 fmt->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
716 } else if (parm == 2 && rc == INT_NUMBER) {
717 bufcpy (fmt->str, curlex, RECLN);
718 fmt->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
719 } else if (parm == 3) {
720 io_unit (unit, defunit);
721 } else {
722 SYNTAX (3318, curlex);
723 }
724 } else {
725 if (parm == 1) {
726 io_unit (unit, defunit);
727 } else if (parm == 2 && TOKEN ("*")) {
728 *form = form_formatted;
729 } else if (parm == 2 && rc == WORD) {
730 macro_depth = 0;
731 express (fmt, NOTYPE, NOLEN);
732 *form = form_formatted;
733 } else if (parm == 2 && rc == TEXT) {
734 int_4 k = format_str (curlex);
735 _srecordf (fmt->str, "%d", k);
736 fmt->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
737 *form = form_formatted;
738 } else if (parm == 2 && rc == INT_NUMBER) {
739 bufcpy (fmt->str, curlex, RECLN);
740 fmt->mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
741 *form = form_formatted;
742 } else {
743 SYNTAX (3319, curlex);
744 }
745 }
746 }
747 // Next item.
748 parm++;
749 rc = scan (EXPECT_NONE);
750 if (TOKEN (",")) {
751 rc = scan (EXPECT_NONE);
752 } else if (TOKEN (")")) {
753 ;
754 } else {
755 SYNTAX (3320, curlex);
756 }
757 }
758 }
759
760 void vif_close (void)
761 {
762 int_4 rc, lrecl = 0;
763 char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
764 EXPR unit, rec, fmt;
765 LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
766 NEW_RECORD (str);
767 rc = scan (EXPECT_NONE);
768 io_specs ("close", &unit, ERR, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
769 _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
770 code (nprocs, BODY, str);
771 _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
772 code (nprocs, BODY, str);
773 _srecordf (str, "_funregister (\"%s\", %s);\n", stat_start, unum (&unit));
774 code (nprocs, BODY, str);
775 if (iostat != NO_TEXT) {
776 NEW_RECORD (ios);
777 _srecordf (ios, "%s_ = errno;\n", iostat);
778 code (nprocs, BODY, ios);
779 }
780 code (nprocs, BODY, "if (errno != 0) {\n");
781 if (errlbl == NO_LABEL) {
782 _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
783 } else {
784 _srecordf (str, "goto _l%d;\n", errlbl->num);
785 }
786 code (nprocs, BODY, str);
787 code (nprocs, BODY, "}\n");
788 code (nprocs, BODY, "}\n");
789 (void) rc;
790 }
791
792 void vif_endfile (void)
793 {
794 int_4 rc, lrecl = 0;
795 char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
796 EXPR unit, rec, fmt;
797 LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
798 NEW_RECORD (str);
799 rc = scan (EXPECT_NONE);
800 io_specs ("endfile", &unit, ERR, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
801 _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
802 code (nprocs, BODY, str);
803 _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
804 code (nprocs, BODY, str);
805 _srecordf (str, "fprintf (_ffile[%s].unit, \"%%c\", EOF);\n", unum (&unit));
806 code (nprocs, BODY, str);
807 if (iostat != NO_TEXT) {
808 NEW_RECORD (ios);
809 _srecordf (ios, "%s_ = errno;\n", iostat);
810 code (nprocs, BODY, ios);
811 }
812 code (nprocs, BODY, "if (errno != 0) {\n");
813 if (errlbl == NO_LABEL) {
814 _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
815 } else {
816 _srecordf (str, "goto _l%d;\n", errlbl->num);
817 }
818 code (nprocs, BODY, str);
819 code (nprocs, BODY, "}\n");
820 code (nprocs, BODY, "}\n");
821 (void) rc;
822 }
823
824 void vif_backspace (void)
825 {
826 int_4 rc, lrecl = 0;
827 char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
828 EXPR unit, rec, fmt;
829 LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
830 NEW_RECORD (str);
831 rc = scan (EXPECT_NONE);
832 io_specs ("backspace", &unit, ERR, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
833 _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
834 code (nprocs, BODY, str);
835 _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
836 code (nprocs, BODY, str);
837 _srecordf (str, "_backspace (\"%s\", %s);\n", stat_start, unum (&unit));
838 code (nprocs, BODY, str);
839 if (iostat != NO_TEXT) {
840 NEW_RECORD (ios);
841 _srecordf (ios, "%s_ = errno;\n", iostat);
842 code (nprocs, BODY, ios);
843 }
844 code (nprocs, BODY, "if (errno != 0) {\n");
845 if (errlbl == NO_LABEL) {
846 _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
847 } else {
848 _srecordf (str, "goto _l%d;\n", errlbl->num);
849 }
850 code (nprocs, BODY, str);
851 code (nprocs, BODY, "}\n");
852 code (nprocs, BODY, "}\n");
853 (void) rc;
854 }
855
856 void vif_rewind (void)
857 {
858 int_4 rc, lrecl = 0;
859 char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
860 EXPR unit, rec, fmt;
861 LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
862 NEW_RECORD (str);
863 rc = scan (EXPECT_NONE);
864 io_specs ("rewind", &unit, ERR, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
865 _srecordf (str, "_fcheck (\"%s\", %s, NULL, NULL);\n", stat_start, unum (&unit));
866 code (nprocs, BODY, str);
867 _srecordf (str, "if (_ffile[%s].unit != NULL) {\n", unum (&unit));
868 code (nprocs, BODY, str);
869 _srecordf (str, "_rewind (\"%s\", %s);\n", stat_start, unum (&unit));
870 code (nprocs, BODY, str);
871 if (iostat != NO_TEXT) {
872 NEW_RECORD (ios);
873 _srecordf (ios, "%s_ = errno;\n", iostat);
874 code (nprocs, BODY, ios);
875 }
876 code (nprocs, BODY, "if (errno != 0) {\n");
877 if (errlbl == NO_LABEL) {
878 _srecordf (str, "_ioerr (\"%s\", %s);\n", stat_start, unum (&unit));
879 } else {
880 _srecordf (str, "goto _l%d;\n", errlbl->num);
881 }
882 code (nprocs, BODY, str);
883 code (nprocs, BODY, "}\n");
884 code (nprocs, BODY, "}\n");
885 (void) rc;
886 }
887
888 void vif_open (void)
889 {
890 int_4 rc, lrecl = 0;
891 char *daction = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *ddisp = NO_TEXT, *iostat = NO_TEXT;
892 LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
893 EXPR unit, rec, fmt;
894 NEW_RECORD (str);
895 rc = scan (EXPECT_NONE);
896 io_specs ("open", &unit, ERR, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
897 if (dfn != NO_TEXT) {
898 _srecordf (str, "_fregister (\"%s\", %s, %d, %s, %s, %s, %s);\n", stat_start, unum (&unit), lrecl, dfn, dform, daction, ddisp);
899 } else {
900 _srecordf (str, "_fregister (\"%s\", %s, %d, NULL, %s, %s, %s);\n", stat_start, unum (&unit), lrecl, dform, daction, ddisp);
901 }
902 code (nprocs, BODY, str);
903 if (iostat != NO_TEXT) {
904 NEW_RECORD (ios);
905 _srecordf (ios, "%s_ = errno;\n", iostat);
906 code (nprocs, BODY, ios);
907 }
908 (void) rc;
909 }
910
911 void io_open_internal (EXPR *unit, char *acc)
912 {
913 if (unit->mode.type != CHARACTER) {
914 ERROR (3321, "unit type must be CHARACTER", unit->str);
915 } else if (unit->variant == EXPR_CONST) {
916 ERROR (3322, "unit must be CHARACTER variable", unit->str);
917 } else {
918 int N = unit->mode.len, M = 1;
919 if (unit->idf->mode.dim == 0) {
920 ;
921 } else {
922 NEW_RECORD (len);
923 compute_row_size (len, unit->idf);
924 if (! is_int4 (len, &M)) {
925 ERROR (3323, "size must be integer constant", len);
926 }
927 if (M > 1) {
928 N *= M;
929 }
930 }
931 NEW_RECORD (str);
932 _srecordf (str, "_ffile[0].buff = _ffile[0].rewind = (char *) (%s);\n", unit->str);
933 code (nprocs, BODY, str);
934 _srecordf (str, "_ffile[0].lrecl = %d;\n", unit->mode.len);
935 code (nprocs, BODY, str);
936 _srecordf (str, "_ffile[0].record = 0;\n");
937 code (nprocs, BODY, str);
938 _srecordf (str, "_ffile[0].records = %d;\n", M);
939 code (nprocs, BODY, str);
940 _srecordf (str, "_ffile[0].unit = fmemopen (%s, %d, \"%s\");\n", unit->str, N, acc);
941 code (nprocs, BODY, str);
942 _srecordf (str, "_ffile[0].buff_init = FALSE;\n");
943 code (nprocs, BODY, str);
944 }
945 }
946
947 void do_io (char *proc, int_4 *nest)
948 {
949 int_4 form = UNFORMATTED, lrecl = 0;
950 LBL *endlbl = NO_LABEL, *errlbl = NO_LABEL;
951 NEW_RECORD (fstr);
952 NEW_RECORD (fid);
953 NEW_RECORD (iorc);
954 NEW_RECORD (str);
955 char *daction = NO_TEXT, *ddisp = NO_TEXT, *dfn = NO_TEXT, *dform = NO_TEXT, *iostat = NO_TEXT;
956 EXPR unit, rec, fmt;
957 RECCLR (fmt.str);
958 unit.mode.type = INTEGER;
959 unit.mode.len = 4;
960 fstr[0] = '\0';
961 fid[0] = '\0';
962 iorc[0] = '\0';
963 rec.str[0] = '\0';
964 int_4 rc = scan (EXPECT_NONE);
965 if (EQUAL (proc, "read") || EQUAL (proc, "accept")) {
966 if (TOKEN ("*")) {
967 _srecordf (unit.str, "STDF_IN");
968 dform = form_formatted;
969 rc = scan (EXPECT_NONE);
970 } else if (rc == INT_NUMBER) { // FORTRAN II
971 _srecordf (unit.str, "STDF_IN");
972 bufcpy (fmt.str, curlex, RECLN);
973 fmt.mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
974 dform = form_formatted;
975 rc = scan (EXPECT_NONE);
976 } else if (rc == TEXT) {
977 _srecordf (unit.str, "STDF_IN");
978 int_4 k = format_str (curlex);
979 _srecordf (fmt.str, "%d", k);
980 fmt.mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
981 dform = form_formatted;
982 rc = scan (EXPECT_NONE);
983 } else {
984 io_specs (proc, &unit, STDF_IN, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
985 }
986 } else if (EQUAL (proc, "write") || EQUAL (proc, "print") || EQUAL (proc, "punch")) {
987 if (TOKEN ("*")) {
988 _srecordf (unit.str, "STDF_OUT");
989 dform = form_formatted;
990 rc = scan (EXPECT_NONE);
991 } else if (rc == INT_NUMBER) { // FORTRAN II
992 _srecordf (unit.str, "STDF_OUT");
993 bufcpy (fmt.str, curlex, RECLN);
994 fmt.mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
995 dform = form_formatted;
996 rc = scan (EXPECT_NONE);
997 } else if (rc == TEXT) {
998 _srecordf (unit.str, "STDF_OUT");
999 int_4 k = format_str (curlex);
1000 _srecordf (fmt.str, "%d", k);
1001 fmt.mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
1002 dform = form_formatted;
1003 rc = scan (EXPECT_NONE);
1004 } else {
1005 io_specs (proc, &unit, STDF_OUT, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
1006 }
1007 } else if (EQUAL (proc, "encode") || EQUAL (proc, "decode")) {
1008 io_specs (proc, &unit, STDF_OUT, &rec, &fmt, &dfn, &dform, &daction, &lrecl, &ddisp, &endlbl, &errlbl, &iostat);
1009 ddisp = disp_old;
1010 dfn = NO_TEXT;
1011 iostat = NO_TEXT;
1012 dform = form_formatted;
1013 if (EQUAL (proc, "encode")) {
1014 proc = "write";
1015 daction = action_write;
1016 } else if (EQUAL (proc, "decode")) {
1017 proc = "read";
1018 daction = action_read;
1019 }
1020 }
1021 if (strlen (fmt.str) == 0 && dform != form_unformatted) {
1022 form = STDFORMAT;
1023 } else if (strlen (fmt.str) == 0 && dform == form_unformatted) {
1024 form = UNFORMATTED;
1025 } else {
1026 form = FORMATTED;
1027 }
1028 // IO to a string implies UNIT=0.
1029 if (unit.mode.type == CHARACTER) {
1030 if (EQUAL (proc, "read")) {
1031 io_open_internal (&unit, "r");
1032 } else if (EQUAL (proc, "accept")) {
1033 io_open_internal (&unit, "r");
1034 } else if (EQUAL (proc, "write")) {
1035 io_open_internal (&unit, "w");
1036 } else if (EQUAL (proc, "print")) {
1037 io_open_internal (&unit, "w");
1038 } else if (EQUAL (proc, "punch")) {
1039 io_open_internal (&unit, "w");
1040 }
1041 }
1042 // Runtime checks - can the file do this?
1043 if (EQUAL (proc, "read")) {
1044 _srecordf (str, "_fcheck (\"%s\", %s, action_read, %s);\n", stat_start, unum (&unit), dform);
1045 } else if (EQUAL (proc, "accept")) {
1046 _srecordf (str, "_fcheck (\"%s\", %s, action_read, %s);\n", stat_start, unum (&unit), dform);
1047 } else if (EQUAL (proc, "write")) {
1048 _srecordf (str, "_fcheck (\"%s\", %s, action_write, %s);\n", stat_start, unum (&unit), dform);
1049 } else if (EQUAL (proc, "print")) {
1050 _srecordf (str, "_fcheck (\"%s\", %s, action_write, %s);\n", stat_start, unum (&unit), dform);
1051 } else if (EQUAL (proc, "punch")) {
1052 _srecordf (str, "_fcheck (\"%s\", %s, action_write, %s);\n", stat_start, unum (&unit), dform);
1053 }
1054 code (nprocs, BODY, str);
1055 // Set record.
1056 if (strlen (rec.str) > 0) {
1057 _srecordf (str, "_set_record (\"%s\", %s, %s);\n", stat_start, unum (&unit), rec.str);
1058 code (nprocs, BODY, str);
1059 }
1060 // Formats.
1061 if (form == FORMATTED) {
1062 NEW_RECORD (fcnt);
1063 int_4 val;
1064 _srecordf (fid, "__fcnt");
1065 add_local (fid, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
1066 _srecordf (iorc, "__rc");
1067 add_local (iorc, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
1068 _srecordf (fcnt, "%s = 0;\n", fid);
1069 code (nprocs, BODY, fcnt);
1070 if (is_int4 (fmt.str, &val)) {
1071 _srecordf (fstr, "%s", edit_fmt (val));
1072 } else {
1073 if (fmt.mode.type == INTEGER) {
1074 // Assigned FORMAT.
1075 _srecordf (str, "switch (%s) {\n", fmt.str);
1076 code (nprocs, BODY, str);
1077 code (nprocs, BODY, "default:\n");
1078 for (int_4 k = 0; k < nlabels; k++) {
1079 LBL *L = &labels[k];
1080 if (L->format) {
1081 L->jumped++;
1082 _srecordf (str, "case %d: __fmt_a = %s; break;\n", L->index, edit_fmt(L->num));
1083 code (nprocs, BODY, str);
1084 }
1085 }
1086 code (nprocs, BODY, "}\n");
1087 RECCPY (fstr, "__fmt_a");
1088 } else if (fmt.mode.type == CHARACTER) {
1089 _srecordf (str, "__fmt_a = _vif_jit (\"%s\", %s);\n", stat_start, fmt.str);
1090 code (nprocs, BODY, str);
1091 RECCPY (fstr, "__fmt_a");
1092 } else {
1093 ERROR (3324, "format identifier mode error", qtype (&fmt.mode));
1094 }
1095 }
1096 } else {
1097 _srecordf (iorc, "__rc_%d", nloctmps++);
1098 add_local (iorc, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
1099 }
1100 // Start-of-record.
1101 if (form == FORMATTED) {
1102 if (EQUAL (proc, "read")) {
1103 io_text_items ("read", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
1104 } else if (EQUAL (proc, "accept")) {
1105 io_text_items ("read", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
1106 } else if (EQUAL (proc, "write")) {
1107 io_text_items ("write", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
1108 } else if (EQUAL (proc, "print")) {
1109 io_text_items ("write", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
1110 } else if (EQUAL (proc, "punch")) {
1111 io_text_items ("write", &unit, fstr, fid, iorc, endlbl, errlbl, FALSE);
1112 }
1113 }
1114 int_4 items = 0;
1115 if (EQUAL (proc, "read")) {
1116 io_list ("read", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
1117 } else if (EQUAL (proc, "accept")) {
1118 io_list ("read", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
1119 } else if (EQUAL (proc, "write")) {
1120 io_list ("write", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
1121 } else if (EQUAL (proc, "print")) {
1122 io_list ("write", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
1123 } else if (EQUAL (proc, "punch")) {
1124 io_list ("write", &unit, form, fstr, fid, iorc, endlbl, errlbl, ERR, nest, &items);
1125 }
1126 if (unit.mode.type == CHARACTER) {
1127 // IO to a string implies UNIT=0.
1128 // code (nprocs, BODY, "_fclose (0);\n");
1129 } else if (EQUAL (proc, "write") || EQUAL (proc, "print") || EQUAL (proc, "punch")) {
1130 // End-of-record.
1131 if (form != UNFORMATTED) {
1132 _srecordf (str, "_write_eol (%s);\n", unum (&unit));
1133 code (nprocs, BODY, str);
1134 }
1135 } else if (EQUAL (proc, "read") || EQUAL (proc, "accept")) {
1136 // End-of-record.
1137 if (form != UNFORMATTED) {
1138 _srecordf (str, "_read_eol (%s);\n", unum (&unit));
1139 code (nprocs, BODY, str);
1140 }
1141 }
1142 //
1143 store_iostat (iostat);
1144 //
1145 (void) rc;
1146 }
1147
1148 logical_4 inquire_elem (char **var, char *token)
1149 {
1150 if (TOKEN (token) && lookahead ("=")) {
1151 int_4 rc = scan ("=");
1152 rc = scan (EXPECT_NONE);
1153 if (rc != WORD) {
1154 EXPECT (3325, "variable")
1155 return FALSE;
1156 } else {
1157 (void) impl_decl (curlex, NO_MODE);
1158 (*var) = f_stralloc (curlex);
1159 return TRUE;
1160 }
1161 }
1162 return FALSE;
1163 }
1164
1165 void inquire_yes_no (char * var, char *field, char *yes, char *no)
1166 {
1167 if (var != NO_TEXT) {
1168 NEW_RECORD (str);
1169 MODE mode = (MODE) {.type = CHARACTER, .len = 8, .dim = 0};
1170 if (yes == NO_TEXT) {
1171 _srecordf (str, "if (_f_->%s) {\n", field);
1172 } else {
1173 _srecordf (str, "if (_f_->%s == %s) {\n", field, yes);
1174 }
1175 code (nprocs, BODY, str);
1176 store_var (var, &mode, "\"YES\"");
1177 if (no != NO_TEXT) {
1178 _srecordf (str, "} else if (_f_->%s == %s) {\n", field, no);
1179 code (nprocs, BODY, str);
1180 store_var (var, &mode, "\"NO\"");
1181 code (nprocs, BODY, "} else {\n");
1182 store_var (var, &mode, "\"UNKNOWN\"");
1183 } else {
1184 code (nprocs, BODY, "} else {\n");
1185 store_var (var, &mode, "\"NO\"");
1186 }
1187 code (nprocs, BODY, "};\n");
1188 }
1189 }
1190
1191 void vif_inquire (void)
1192 {
1193 char
1194 *disp = NO_TEXT,
1195 *exist = NO_TEXT,
1196 *fn = NO_TEXT,
1197 *formatted = NO_TEXT,
1198 *iostat = NO_TEXT,
1199 *name = NO_TEXT,
1200 *opened = NO_TEXT,
1201 *read = NO_TEXT,
1202 *readwrite = NO_TEXT,
1203 *recl = NO_TEXT,
1204 *stream = NO_TEXT,
1205 *unformatted = NO_TEXT,
1206 *write = NO_TEXT;
1207 LBL *errlbl = NO_LABEL;
1208 EXPR unit;
1209 RECCLR (&(unit.str));
1210 //
1211 int_4 rc = scan (EXPECT_NONE);
1212 if (TOKEN ("(")) {
1213 rc = scan (EXPECT_NONE);
1214 } else {
1215 EXPECT (3326, "(");
1216 return;
1217 }
1218 int_4 N = 0;
1219 while (!TOKEN (")") && rc != END_OF_MODULE) {
1220 if (TOKEN ("unit") && lookahead ("=")) {
1221 rc = scan ("=");
1222 rc = scan (EXPECT_NONE);
1223 io_unit (&unit, 0);
1224 } else if (TOKEN ("file") && lookahead ("=")) {
1225 EXPR reg;
1226 rc = scan ("=");
1227 rc = scan (EXPECT_NONE);
1228 macro_depth = 0;
1229 if (express (®, CHARACTER, NOLEN)) {
1230 fn = f_stralloc (reg.str);
1231 }
1232 } else if (TOKEN ("err") && lookahead ("=")) {
1233 // ERR=label
1234 rc = scan ("=");
1235 if ((rc = scan (EXPECT_LABEL)) == LABEL) {
1236 if ((errlbl = find_label (curlex)) == NO_LABEL) {
1237 ERROR (3327, "no such label", curlex);
1238 }
1239 errlbl->jumped++;
1240 } else {
1241 EXPECT (3328, "label");
1242 }
1243 } else if (inquire_elem (&iostat, "iostat")) {
1244 N++;
1245 } else if (inquire_elem (&exist, "exist")) {
1246 N++;
1247 } else if (inquire_elem (&name, "name")) {
1248 N++;
1249 } else if (inquire_elem (&opened, "opened")) {
1250 N++;
1251 } else if (inquire_elem (&disp, "disp")) {
1252 N++;
1253 } else if (inquire_elem (&read, "read")) {
1254 N++;
1255 } else if (inquire_elem (&write, "write")) {
1256 N++;
1257 } else if (inquire_elem (&readwrite, "readwrite")) {
1258 N++;
1259 } else if (inquire_elem (&formatted, "formatted")) {
1260 N++;
1261 } else if (inquire_elem (&unformatted, "unformatted")) {
1262 N++;
1263 } else if (inquire_elem (&recl, "recl")) {
1264 N++;
1265 } else if (inquire_elem (&stream, "stream")) {
1266 N++;
1267 } else {
1268 SYNTAX (3329, curlex);
1269 return;
1270 }
1271 rc = scan (EXPECT_NONE);
1272 if (TOKEN (",")) {
1273 rc = scan (EXPECT_NONE);
1274 } else if (TOKEN (")")) {
1275 ;
1276 } else {
1277 SYNTAX (3330, curlex);
1278 }
1279 }
1280 if (N == 0) {
1281 return;
1282 }
1283 // Generate code.
1284 code (nprocs, BODY, "{\n");
1285 if (errlbl != NO_LABEL) {
1286 code (nprocs, BODY, "errno = 0;\n");
1287 }
1288 NEW_RECORD (str);
1289 if (fn != NO_TEXT) {
1290 if (strlen (unit.str) > 0) {
1291 ERROR (3331, "file specified twice", NO_TEXT);
1292 } else if (exist != NO_TEXT) {
1293 MODE mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
1294 _srecordf (str, "(access (%s, F_OK) == 0)", fn);
1295 store_var (exist, &mode, str);
1296 }
1297 if (name != NO_TEXT) {
1298 MODE mode = (MODE) {.type = CHARACTER, .len = 255, .dim = 0};
1299 store_var (name, &mode, fn);
1300 }
1301 } else if (strlen (unit.str) == 0) {
1302 ERROR (3332, "no file specified", NO_TEXT);
1303 } else {
1304 _srecordf (str, "FTN_FILE *_f_ = _get_ftn_file (\"%s\", %s);\n", stat_start, unum (&unit));
1305 code (nprocs, BODY, str);
1306 if (exist != NO_TEXT) {
1307 MODE mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
1308 code (nprocs, BODY, "if (_f_->name != NULL) {\n");
1309 store_var (exist, &mode, "(access (_f_->name, F_OK) == 0)");
1310 code (nprocs, BODY, "};\n");
1311 }
1312 if (name != NO_TEXT) {
1313 MODE mode = (MODE) {.type = CHARACTER, .len = 255, .dim = 0};
1314 code (nprocs, BODY, "if (_f_->name == NULL) {\n");
1315 store_var (name, &mode, "\"\"");
1316 code (nprocs, BODY, "} else {\n");
1317 store_var (name, &mode, "_f_->name");
1318 code (nprocs, BODY, "};\n");
1319 }
1320 if (disp != NO_TEXT) {
1321 MODE mode = (MODE) {.type = CHARACTER, .len = 8, .dim = 0};
1322 code (nprocs, BODY, "if (_f_->disp == NULL) {\n");
1323 store_var (disp, &mode, "\"UNKNOWN\"");
1324 code (nprocs, BODY, "} else {\n");
1325 store_var (name, &mode, "_f_->disp");
1326 code (nprocs, BODY, "};\n");
1327 }
1328 if (opened != NO_TEXT) {
1329 MODE mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
1330 store_var (opened, &mode, "(_f_->unit != NO_FILE)");
1331 }
1332 if (recl != NO_TEXT) {
1333 MODE mode = (MODE) {.type = INTEGER, .len = 4, .dim = 0};
1334 store_var (opened, &mode, "_f_->recl");
1335 }
1336 inquire_yes_no (stream, "in_stream", NO_TEXT, NO_TEXT);
1337 inquire_yes_no (read, "action", "action_read", NO_TEXT);
1338 inquire_yes_no (write, "action", "action_write", NO_TEXT);
1339 inquire_yes_no (readwrite, "action", "action_readwrite", NO_TEXT);
1340 inquire_yes_no (formatted, "form", "form_formatted", "form_unformatted");
1341 inquire_yes_no (unformatted, "form", "unform_formatted", "form_formatted");
1342 store_iostat (iostat);
1343 if (errlbl != NO_LABEL) {
1344 code (nprocs, BODY, "if (errno != 0) {\n");
1345 _srecordf (str, "goto _l%d;\n", errlbl->num);
1346 code (nprocs, BODY, "};\n");
1347 }
1348 }
1349 code (nprocs, BODY, "};\n");
1350 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
