Mercurial > hg > CbC > CbC_gcc
comparison gcc/fortran/io.c @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
1 /* Deal with I/O statements & related stuff. | |
2 Copyright (C) 2000-2017 Free Software Foundation, Inc. | |
3 Contributed by Andy Vaught | |
4 | |
5 This file is part of GCC. | |
6 | |
7 GCC is free software; you can redistribute it and/or modify it under | |
8 the terms of the GNU General Public License as published by the Free | |
9 Software Foundation; either version 3, or (at your option) any later | |
10 version. | |
11 | |
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY | |
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
15 for more details. | |
16 | |
17 You should have received a copy of the GNU General Public License | |
18 along with GCC; see the file COPYING3. If not see | |
19 <http://www.gnu.org/licenses/>. */ | |
20 | |
21 #include "config.h" | |
22 #include "system.h" | |
23 #include "coretypes.h" | |
24 #include "options.h" | |
25 #include "gfortran.h" | |
26 #include "match.h" | |
27 #include "parse.h" | |
28 | |
29 gfc_st_label | |
30 format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL, | |
31 0, {NULL, NULL}, NULL}; | |
32 | |
33 typedef struct | |
34 { | |
35 const char *name, *spec, *value; | |
36 bt type; | |
37 } | |
38 io_tag; | |
39 | |
40 static const io_tag | |
41 tag_readonly = {"READONLY", " readonly", NULL, BT_UNKNOWN }, | |
42 tag_shared = {"SHARE", " shared", NULL, BT_UNKNOWN }, | |
43 tag_noshared = {"SHARE", " noshared", NULL, BT_UNKNOWN }, | |
44 tag_e_share = {"SHARE", " share =", " %e", BT_CHARACTER }, | |
45 tag_v_share = {"SHARE", " share =", " %v", BT_CHARACTER }, | |
46 tag_cc = {"CARRIAGECONTROL", " carriagecontrol =", " %e", | |
47 BT_CHARACTER }, | |
48 tag_v_cc = {"CARRIAGECONTROL", " carriagecontrol =", " %v", | |
49 BT_CHARACTER }, | |
50 tag_file = {"FILE", " file =", " %e", BT_CHARACTER }, | |
51 tag_status = {"STATUS", " status =", " %e", BT_CHARACTER}, | |
52 tag_e_access = {"ACCESS", " access =", " %e", BT_CHARACTER}, | |
53 tag_e_form = {"FORM", " form =", " %e", BT_CHARACTER}, | |
54 tag_e_recl = {"RECL", " recl =", " %e", BT_INTEGER}, | |
55 tag_e_blank = {"BLANK", " blank =", " %e", BT_CHARACTER}, | |
56 tag_e_position = {"POSITION", " position =", " %e", BT_CHARACTER}, | |
57 tag_e_action = {"ACTION", " action =", " %e", BT_CHARACTER}, | |
58 tag_e_delim = {"DELIM", " delim =", " %e", BT_CHARACTER}, | |
59 tag_e_pad = {"PAD", " pad =", " %e", BT_CHARACTER}, | |
60 tag_e_decimal = {"DECIMAL", " decimal =", " %e", BT_CHARACTER}, | |
61 tag_e_encoding = {"ENCODING", " encoding =", " %e", BT_CHARACTER}, | |
62 tag_e_async = {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER}, | |
63 tag_e_round = {"ROUND", " round =", " %e", BT_CHARACTER}, | |
64 tag_e_sign = {"SIGN", " sign =", " %e", BT_CHARACTER}, | |
65 tag_unit = {"UNIT", " unit =", " %e", BT_INTEGER}, | |
66 tag_advance = {"ADVANCE", " advance =", " %e", BT_CHARACTER}, | |
67 tag_rec = {"REC", " rec =", " %e", BT_INTEGER}, | |
68 tag_spos = {"POSITION", " pos =", " %e", BT_INTEGER}, | |
69 tag_format = {"FORMAT", NULL, NULL, BT_CHARACTER}, | |
70 tag_iomsg = {"IOMSG", " iomsg =", " %e", BT_CHARACTER}, | |
71 tag_iostat = {"IOSTAT", " iostat =", " %v", BT_INTEGER}, | |
72 tag_size = {"SIZE", " size =", " %v", BT_INTEGER}, | |
73 tag_exist = {"EXIST", " exist =", " %v", BT_LOGICAL}, | |
74 tag_opened = {"OPENED", " opened =", " %v", BT_LOGICAL}, | |
75 tag_named = {"NAMED", " named =", " %v", BT_LOGICAL}, | |
76 tag_name = {"NAME", " name =", " %v", BT_CHARACTER}, | |
77 tag_number = {"NUMBER", " number =", " %v", BT_INTEGER}, | |
78 tag_s_access = {"ACCESS", " access =", " %v", BT_CHARACTER}, | |
79 tag_sequential = {"SEQUENTIAL", " sequential =", " %v", BT_CHARACTER}, | |
80 tag_direct = {"DIRECT", " direct =", " %v", BT_CHARACTER}, | |
81 tag_s_form = {"FORM", " form =", " %v", BT_CHARACTER}, | |
82 tag_formatted = {"FORMATTED", " formatted =", " %v", BT_CHARACTER}, | |
83 tag_unformatted = {"UNFORMATTED", " unformatted =", " %v", BT_CHARACTER}, | |
84 tag_s_recl = {"RECL", " recl =", " %v", BT_INTEGER}, | |
85 tag_nextrec = {"NEXTREC", " nextrec =", " %v", BT_INTEGER}, | |
86 tag_s_blank = {"BLANK", " blank =", " %v", BT_CHARACTER}, | |
87 tag_s_position = {"POSITION", " position =", " %v", BT_CHARACTER}, | |
88 tag_s_action = {"ACTION", " action =", " %v", BT_CHARACTER}, | |
89 tag_read = {"READ", " read =", " %v", BT_CHARACTER}, | |
90 tag_write = {"WRITE", " write =", " %v", BT_CHARACTER}, | |
91 tag_readwrite = {"READWRITE", " readwrite =", " %v", BT_CHARACTER}, | |
92 tag_s_delim = {"DELIM", " delim =", " %v", BT_CHARACTER}, | |
93 tag_s_pad = {"PAD", " pad =", " %v", BT_CHARACTER}, | |
94 tag_s_decimal = {"DECIMAL", " decimal =", " %v", BT_CHARACTER}, | |
95 tag_s_encoding = {"ENCODING", " encoding =", " %v", BT_CHARACTER}, | |
96 tag_s_async = {"ASYNCHRONOUS", " asynchronous =", " %v", BT_CHARACTER}, | |
97 tag_s_round = {"ROUND", " round =", " %v", BT_CHARACTER}, | |
98 tag_s_sign = {"SIGN", " sign =", " %v", BT_CHARACTER}, | |
99 tag_iolength = {"IOLENGTH", " iolength =", " %v", BT_INTEGER}, | |
100 tag_convert = {"CONVERT", " convert =", " %e", BT_CHARACTER}, | |
101 tag_strm_out = {"POS", " pos =", " %v", BT_INTEGER}, | |
102 tag_err = {"ERR", " err =", " %l", BT_UNKNOWN}, | |
103 tag_end = {"END", " end =", " %l", BT_UNKNOWN}, | |
104 tag_eor = {"EOR", " eor =", " %l", BT_UNKNOWN}, | |
105 tag_id = {"ID", " id =", " %v", BT_INTEGER}, | |
106 tag_pending = {"PENDING", " pending =", " %v", BT_LOGICAL}, | |
107 tag_newunit = {"NEWUNIT", " newunit =", " %v", BT_INTEGER}, | |
108 tag_s_iqstream = {"STREAM", " stream =", " %v", BT_CHARACTER}; | |
109 | |
110 static gfc_dt *current_dt; | |
111 | |
112 #define RESOLVE_TAG(x, y) if (!resolve_tag (x, y)) return false; | |
113 | |
114 /* Are we currently processing an asynchronous I/O statement? */ | |
115 | |
116 bool async_io_dt; | |
117 | |
118 /**************** Fortran 95 FORMAT parser *****************/ | |
119 | |
120 /* FORMAT tokens returned by format_lex(). */ | |
121 enum format_token | |
122 { | |
123 FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD, | |
124 FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN, | |
125 FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F, | |
126 FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, | |
127 FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC, | |
128 FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT | |
129 }; | |
130 | |
131 /* Local variables for checking format strings. The saved_token is | |
132 used to back up by a single format token during the parsing | |
133 process. */ | |
134 static gfc_char_t *format_string; | |
135 static int format_string_pos; | |
136 static int format_length, use_last_char; | |
137 static char error_element; | |
138 static locus format_locus; | |
139 | |
140 static format_token saved_token; | |
141 | |
142 static enum | |
143 { MODE_STRING, MODE_FORMAT, MODE_COPY } | |
144 mode; | |
145 | |
146 | |
147 /* Return the next character in the format string. */ | |
148 | |
149 static char | |
150 next_char (gfc_instring in_string) | |
151 { | |
152 static gfc_char_t c; | |
153 | |
154 if (use_last_char) | |
155 { | |
156 use_last_char = 0; | |
157 return c; | |
158 } | |
159 | |
160 format_length++; | |
161 | |
162 if (mode == MODE_STRING) | |
163 c = *format_string++; | |
164 else | |
165 { | |
166 c = gfc_next_char_literal (in_string); | |
167 if (c == '\n') | |
168 c = '\0'; | |
169 } | |
170 | |
171 if (flag_backslash && c == '\\') | |
172 { | |
173 locus old_locus = gfc_current_locus; | |
174 | |
175 if (gfc_match_special_char (&c) == MATCH_NO) | |
176 gfc_current_locus = old_locus; | |
177 | |
178 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings) | |
179 gfc_warning (0, "Extension: backslash character at %C"); | |
180 } | |
181 | |
182 if (mode == MODE_COPY) | |
183 *format_string++ = c; | |
184 | |
185 if (mode != MODE_STRING) | |
186 format_locus = gfc_current_locus; | |
187 | |
188 format_string_pos++; | |
189 | |
190 c = gfc_wide_toupper (c); | |
191 return c; | |
192 } | |
193 | |
194 | |
195 /* Back up one character position. Only works once. */ | |
196 | |
197 static void | |
198 unget_char (void) | |
199 { | |
200 use_last_char = 1; | |
201 } | |
202 | |
203 /* Eat up the spaces and return a character. */ | |
204 | |
205 static char | |
206 next_char_not_space () | |
207 { | |
208 char c; | |
209 do | |
210 { | |
211 error_element = c = next_char (NONSTRING); | |
212 if (c == '\t') | |
213 gfc_warning (OPT_Wtabs, "Nonconforming tab character in format at %C"); | |
214 } | |
215 while (gfc_is_whitespace (c)); | |
216 return c; | |
217 } | |
218 | |
219 static int value = 0; | |
220 | |
221 /* Simple lexical analyzer for getting the next token in a FORMAT | |
222 statement. */ | |
223 | |
224 static format_token | |
225 format_lex (void) | |
226 { | |
227 format_token token; | |
228 char c, delim; | |
229 int zflag; | |
230 int negative_flag; | |
231 | |
232 if (saved_token != FMT_NONE) | |
233 { | |
234 token = saved_token; | |
235 saved_token = FMT_NONE; | |
236 return token; | |
237 } | |
238 | |
239 c = next_char_not_space (); | |
240 | |
241 negative_flag = 0; | |
242 switch (c) | |
243 { | |
244 case '-': | |
245 negative_flag = 1; | |
246 /* Falls through. */ | |
247 | |
248 case '+': | |
249 c = next_char_not_space (); | |
250 if (!ISDIGIT (c)) | |
251 { | |
252 token = FMT_UNKNOWN; | |
253 break; | |
254 } | |
255 | |
256 value = c - '0'; | |
257 | |
258 do | |
259 { | |
260 c = next_char_not_space (); | |
261 if (ISDIGIT (c)) | |
262 value = 10 * value + c - '0'; | |
263 } | |
264 while (ISDIGIT (c)); | |
265 | |
266 unget_char (); | |
267 | |
268 if (negative_flag) | |
269 value = -value; | |
270 | |
271 token = FMT_SIGNED_INT; | |
272 break; | |
273 | |
274 case '0': | |
275 case '1': | |
276 case '2': | |
277 case '3': | |
278 case '4': | |
279 case '5': | |
280 case '6': | |
281 case '7': | |
282 case '8': | |
283 case '9': | |
284 zflag = (c == '0'); | |
285 | |
286 value = c - '0'; | |
287 | |
288 do | |
289 { | |
290 c = next_char_not_space (); | |
291 if (ISDIGIT (c)) | |
292 { | |
293 value = 10 * value + c - '0'; | |
294 if (c != '0') | |
295 zflag = 0; | |
296 } | |
297 } | |
298 while (ISDIGIT (c)); | |
299 | |
300 unget_char (); | |
301 token = zflag ? FMT_ZERO : FMT_POSINT; | |
302 break; | |
303 | |
304 case '.': | |
305 token = FMT_PERIOD; | |
306 break; | |
307 | |
308 case ',': | |
309 token = FMT_COMMA; | |
310 break; | |
311 | |
312 case ':': | |
313 token = FMT_COLON; | |
314 break; | |
315 | |
316 case '/': | |
317 token = FMT_SLASH; | |
318 break; | |
319 | |
320 case '$': | |
321 token = FMT_DOLLAR; | |
322 break; | |
323 | |
324 case 'T': | |
325 c = next_char_not_space (); | |
326 switch (c) | |
327 { | |
328 case 'L': | |
329 token = FMT_TL; | |
330 break; | |
331 case 'R': | |
332 token = FMT_TR; | |
333 break; | |
334 default: | |
335 token = FMT_T; | |
336 unget_char (); | |
337 } | |
338 break; | |
339 | |
340 case '(': | |
341 token = FMT_LPAREN; | |
342 break; | |
343 | |
344 case ')': | |
345 token = FMT_RPAREN; | |
346 break; | |
347 | |
348 case 'X': | |
349 token = FMT_X; | |
350 break; | |
351 | |
352 case 'S': | |
353 c = next_char_not_space (); | |
354 if (c != 'P' && c != 'S') | |
355 unget_char (); | |
356 | |
357 token = FMT_SIGN; | |
358 break; | |
359 | |
360 case 'B': | |
361 c = next_char_not_space (); | |
362 if (c == 'N' || c == 'Z') | |
363 token = FMT_BLANK; | |
364 else | |
365 { | |
366 unget_char (); | |
367 token = FMT_IBOZ; | |
368 } | |
369 | |
370 break; | |
371 | |
372 case '\'': | |
373 case '"': | |
374 delim = c; | |
375 | |
376 value = 0; | |
377 | |
378 for (;;) | |
379 { | |
380 c = next_char (INSTRING_WARN); | |
381 if (c == '\0') | |
382 { | |
383 token = FMT_END; | |
384 break; | |
385 } | |
386 | |
387 if (c == delim) | |
388 { | |
389 c = next_char (NONSTRING); | |
390 | |
391 if (c == '\0') | |
392 { | |
393 token = FMT_END; | |
394 break; | |
395 } | |
396 | |
397 if (c != delim) | |
398 { | |
399 unget_char (); | |
400 token = FMT_CHAR; | |
401 break; | |
402 } | |
403 } | |
404 value++; | |
405 } | |
406 break; | |
407 | |
408 case 'P': | |
409 token = FMT_P; | |
410 break; | |
411 | |
412 case 'I': | |
413 case 'O': | |
414 case 'Z': | |
415 token = FMT_IBOZ; | |
416 break; | |
417 | |
418 case 'F': | |
419 token = FMT_F; | |
420 break; | |
421 | |
422 case 'E': | |
423 c = next_char_not_space (); | |
424 if (c == 'N' ) | |
425 token = FMT_EN; | |
426 else if (c == 'S') | |
427 token = FMT_ES; | |
428 else | |
429 { | |
430 token = FMT_E; | |
431 unget_char (); | |
432 } | |
433 | |
434 break; | |
435 | |
436 case 'G': | |
437 token = FMT_G; | |
438 break; | |
439 | |
440 case 'H': | |
441 token = FMT_H; | |
442 break; | |
443 | |
444 case 'L': | |
445 token = FMT_L; | |
446 break; | |
447 | |
448 case 'A': | |
449 token = FMT_A; | |
450 break; | |
451 | |
452 case 'D': | |
453 c = next_char_not_space (); | |
454 if (c == 'P') | |
455 { | |
456 if (!gfc_notify_std (GFC_STD_F2003, "DP format " | |
457 "specifier not allowed at %C")) | |
458 return FMT_ERROR; | |
459 token = FMT_DP; | |
460 } | |
461 else if (c == 'C') | |
462 { | |
463 if (!gfc_notify_std (GFC_STD_F2003, "DC format " | |
464 "specifier not allowed at %C")) | |
465 return FMT_ERROR; | |
466 token = FMT_DC; | |
467 } | |
468 else if (c == 'T') | |
469 { | |
470 if (!gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DT format " | |
471 "specifier not allowed at %C")) | |
472 return FMT_ERROR; | |
473 token = FMT_DT; | |
474 c = next_char_not_space (); | |
475 if (c == '\'' || c == '"') | |
476 { | |
477 delim = c; | |
478 value = 0; | |
479 | |
480 for (;;) | |
481 { | |
482 c = next_char (INSTRING_WARN); | |
483 if (c == '\0') | |
484 { | |
485 token = FMT_END; | |
486 break; | |
487 } | |
488 | |
489 if (c == delim) | |
490 { | |
491 c = next_char (NONSTRING); | |
492 if (c == '\0') | |
493 { | |
494 token = FMT_END; | |
495 break; | |
496 } | |
497 if (c == '/') | |
498 { | |
499 token = FMT_SLASH; | |
500 break; | |
501 } | |
502 if (c == delim) | |
503 continue; | |
504 unget_char (); | |
505 break; | |
506 } | |
507 } | |
508 } | |
509 else if (c == '/') | |
510 { | |
511 token = FMT_SLASH; | |
512 break; | |
513 } | |
514 else | |
515 unget_char (); | |
516 } | |
517 else | |
518 { | |
519 token = FMT_D; | |
520 unget_char (); | |
521 } | |
522 break; | |
523 | |
524 case 'R': | |
525 c = next_char_not_space (); | |
526 switch (c) | |
527 { | |
528 case 'C': | |
529 token = FMT_RC; | |
530 break; | |
531 case 'D': | |
532 token = FMT_RD; | |
533 break; | |
534 case 'N': | |
535 token = FMT_RN; | |
536 break; | |
537 case 'P': | |
538 token = FMT_RP; | |
539 break; | |
540 case 'U': | |
541 token = FMT_RU; | |
542 break; | |
543 case 'Z': | |
544 token = FMT_RZ; | |
545 break; | |
546 default: | |
547 token = FMT_UNKNOWN; | |
548 unget_char (); | |
549 break; | |
550 } | |
551 break; | |
552 | |
553 case '\0': | |
554 token = FMT_END; | |
555 break; | |
556 | |
557 case '*': | |
558 token = FMT_STAR; | |
559 break; | |
560 | |
561 default: | |
562 token = FMT_UNKNOWN; | |
563 break; | |
564 } | |
565 | |
566 return token; | |
567 } | |
568 | |
569 | |
570 static const char * | |
571 token_to_string (format_token t) | |
572 { | |
573 switch (t) | |
574 { | |
575 case FMT_D: | |
576 return "D"; | |
577 case FMT_G: | |
578 return "G"; | |
579 case FMT_E: | |
580 return "E"; | |
581 case FMT_EN: | |
582 return "EN"; | |
583 case FMT_ES: | |
584 return "ES"; | |
585 default: | |
586 return ""; | |
587 } | |
588 } | |
589 | |
590 /* Check a format statement. The format string, either from a FORMAT | |
591 statement or a constant in an I/O statement has already been parsed | |
592 by itself, and we are checking it for validity. The dual origin | |
593 means that the warning message is a little less than great. */ | |
594 | |
595 static bool | |
596 check_format (bool is_input) | |
597 { | |
598 const char *posint_required = _("Positive width required"); | |
599 const char *nonneg_required = _("Nonnegative width required"); | |
600 const char *unexpected_element = _("Unexpected element %qc in format " | |
601 "string at %L"); | |
602 const char *unexpected_end = _("Unexpected end of format string"); | |
603 const char *zero_width = _("Zero width in format descriptor"); | |
604 | |
605 const char *error = NULL; | |
606 format_token t, u; | |
607 int level; | |
608 int repeat; | |
609 bool rv; | |
610 | |
611 use_last_char = 0; | |
612 saved_token = FMT_NONE; | |
613 level = 0; | |
614 repeat = 0; | |
615 rv = true; | |
616 format_string_pos = 0; | |
617 | |
618 t = format_lex (); | |
619 if (t == FMT_ERROR) | |
620 goto fail; | |
621 if (t != FMT_LPAREN) | |
622 { | |
623 error = _("Missing leading left parenthesis"); | |
624 goto syntax; | |
625 } | |
626 | |
627 t = format_lex (); | |
628 if (t == FMT_ERROR) | |
629 goto fail; | |
630 if (t == FMT_RPAREN) | |
631 goto finished; /* Empty format is legal */ | |
632 saved_token = t; | |
633 | |
634 format_item: | |
635 /* In this state, the next thing has to be a format item. */ | |
636 t = format_lex (); | |
637 if (t == FMT_ERROR) | |
638 goto fail; | |
639 format_item_1: | |
640 switch (t) | |
641 { | |
642 case FMT_STAR: | |
643 repeat = -1; | |
644 t = format_lex (); | |
645 if (t == FMT_ERROR) | |
646 goto fail; | |
647 if (t == FMT_LPAREN) | |
648 { | |
649 level++; | |
650 goto format_item; | |
651 } | |
652 error = _("Left parenthesis required after %<*%>"); | |
653 goto syntax; | |
654 | |
655 case FMT_POSINT: | |
656 repeat = value; | |
657 t = format_lex (); | |
658 if (t == FMT_ERROR) | |
659 goto fail; | |
660 if (t == FMT_LPAREN) | |
661 { | |
662 level++; | |
663 goto format_item; | |
664 } | |
665 | |
666 if (t == FMT_SLASH) | |
667 goto optional_comma; | |
668 | |
669 goto data_desc; | |
670 | |
671 case FMT_LPAREN: | |
672 level++; | |
673 goto format_item; | |
674 | |
675 case FMT_SIGNED_INT: | |
676 case FMT_ZERO: | |
677 /* Signed integer can only precede a P format. */ | |
678 t = format_lex (); | |
679 if (t == FMT_ERROR) | |
680 goto fail; | |
681 if (t != FMT_P) | |
682 { | |
683 error = _("Expected P edit descriptor"); | |
684 goto syntax; | |
685 } | |
686 | |
687 goto data_desc; | |
688 | |
689 case FMT_P: | |
690 /* P requires a prior number. */ | |
691 error = _("P descriptor requires leading scale factor"); | |
692 goto syntax; | |
693 | |
694 case FMT_X: | |
695 /* X requires a prior number if we're being pedantic. */ | |
696 if (mode != MODE_FORMAT) | |
697 format_locus.nextc += format_string_pos; | |
698 if (!gfc_notify_std (GFC_STD_GNU, "X descriptor requires leading " | |
699 "space count at %L", &format_locus)) | |
700 return false; | |
701 goto between_desc; | |
702 | |
703 case FMT_SIGN: | |
704 case FMT_BLANK: | |
705 case FMT_DP: | |
706 case FMT_DC: | |
707 case FMT_RC: | |
708 case FMT_RD: | |
709 case FMT_RN: | |
710 case FMT_RP: | |
711 case FMT_RU: | |
712 case FMT_RZ: | |
713 goto between_desc; | |
714 | |
715 case FMT_CHAR: | |
716 goto extension_optional_comma; | |
717 | |
718 case FMT_COLON: | |
719 case FMT_SLASH: | |
720 goto optional_comma; | |
721 | |
722 case FMT_DOLLAR: | |
723 t = format_lex (); | |
724 if (t == FMT_ERROR) | |
725 goto fail; | |
726 | |
727 if (!gfc_notify_std (GFC_STD_GNU, "$ descriptor at %L", &format_locus)) | |
728 return false; | |
729 if (t != FMT_RPAREN || level > 0) | |
730 { | |
731 gfc_warning (0, "$ should be the last specifier in format at %L", | |
732 &format_locus); | |
733 goto optional_comma_1; | |
734 } | |
735 | |
736 goto finished; | |
737 | |
738 case FMT_T: | |
739 case FMT_TL: | |
740 case FMT_TR: | |
741 case FMT_IBOZ: | |
742 case FMT_F: | |
743 case FMT_E: | |
744 case FMT_EN: | |
745 case FMT_ES: | |
746 case FMT_G: | |
747 case FMT_L: | |
748 case FMT_A: | |
749 case FMT_D: | |
750 case FMT_H: | |
751 case FMT_DT: | |
752 goto data_desc; | |
753 | |
754 case FMT_END: | |
755 error = unexpected_end; | |
756 goto syntax; | |
757 | |
758 default: | |
759 error = unexpected_element; | |
760 goto syntax; | |
761 } | |
762 | |
763 data_desc: | |
764 /* In this state, t must currently be a data descriptor. | |
765 Deal with things that can/must follow the descriptor. */ | |
766 switch (t) | |
767 { | |
768 case FMT_SIGN: | |
769 case FMT_BLANK: | |
770 case FMT_DP: | |
771 case FMT_DC: | |
772 case FMT_X: | |
773 break; | |
774 | |
775 case FMT_P: | |
776 /* No comma after P allowed only for F, E, EN, ES, D, or G. | |
777 10.1.1 (1). */ | |
778 t = format_lex (); | |
779 if (t == FMT_ERROR) | |
780 goto fail; | |
781 if (!(gfc_option.allow_std & GFC_STD_F2003) && t != FMT_COMMA | |
782 && t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES | |
783 && t != FMT_D && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH) | |
784 { | |
785 error = _("Comma required after P descriptor"); | |
786 goto syntax; | |
787 } | |
788 if (t != FMT_COMMA) | |
789 { | |
790 if (t == FMT_POSINT) | |
791 { | |
792 t = format_lex (); | |
793 if (t == FMT_ERROR) | |
794 goto fail; | |
795 } | |
796 if (t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES && t != FMT_D | |
797 && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH) | |
798 { | |
799 error = _("Comma required after P descriptor"); | |
800 goto syntax; | |
801 } | |
802 } | |
803 | |
804 saved_token = t; | |
805 goto optional_comma; | |
806 | |
807 case FMT_T: | |
808 case FMT_TL: | |
809 case FMT_TR: | |
810 t = format_lex (); | |
811 if (t != FMT_POSINT) | |
812 { | |
813 error = _("Positive width required with T descriptor"); | |
814 goto syntax; | |
815 } | |
816 break; | |
817 | |
818 case FMT_L: | |
819 t = format_lex (); | |
820 if (t == FMT_ERROR) | |
821 goto fail; | |
822 if (t == FMT_POSINT) | |
823 break; | |
824 if (mode != MODE_FORMAT) | |
825 format_locus.nextc += format_string_pos; | |
826 if (t == FMT_ZERO) | |
827 { | |
828 switch (gfc_notification_std (GFC_STD_GNU)) | |
829 { | |
830 case WARNING: | |
831 gfc_warning (0, "Extension: Zero width after L " | |
832 "descriptor at %L", &format_locus); | |
833 break; | |
834 case ERROR: | |
835 gfc_error ("Extension: Zero width after L " | |
836 "descriptor at %L", &format_locus); | |
837 goto fail; | |
838 case SILENT: | |
839 break; | |
840 default: | |
841 gcc_unreachable (); | |
842 } | |
843 } | |
844 else | |
845 { | |
846 saved_token = t; | |
847 gfc_notify_std (GFC_STD_GNU, "Missing positive width after " | |
848 "L descriptor at %L", &format_locus); | |
849 } | |
850 break; | |
851 | |
852 case FMT_A: | |
853 t = format_lex (); | |
854 if (t == FMT_ERROR) | |
855 goto fail; | |
856 if (t == FMT_ZERO) | |
857 { | |
858 error = zero_width; | |
859 goto syntax; | |
860 } | |
861 if (t != FMT_POSINT) | |
862 saved_token = t; | |
863 break; | |
864 | |
865 case FMT_D: | |
866 case FMT_E: | |
867 case FMT_G: | |
868 case FMT_EN: | |
869 case FMT_ES: | |
870 u = format_lex (); | |
871 if (t == FMT_G && u == FMT_ZERO) | |
872 { | |
873 if (is_input) | |
874 { | |
875 error = zero_width; | |
876 goto syntax; | |
877 } | |
878 if (!gfc_notify_std (GFC_STD_F2008, "%<G0%> in format at %L", | |
879 &format_locus)) | |
880 return false; | |
881 u = format_lex (); | |
882 if (u != FMT_PERIOD) | |
883 { | |
884 saved_token = u; | |
885 break; | |
886 } | |
887 u = format_lex (); | |
888 if (u != FMT_POSINT) | |
889 { | |
890 error = posint_required; | |
891 goto syntax; | |
892 } | |
893 u = format_lex (); | |
894 if (u == FMT_E) | |
895 { | |
896 error = _("E specifier not allowed with g0 descriptor"); | |
897 goto syntax; | |
898 } | |
899 saved_token = u; | |
900 break; | |
901 } | |
902 | |
903 if (u != FMT_POSINT) | |
904 { | |
905 format_locus.nextc += format_string_pos; | |
906 gfc_error ("Positive width required in format " | |
907 "specifier %s at %L", token_to_string (t), | |
908 &format_locus); | |
909 saved_token = u; | |
910 goto fail; | |
911 } | |
912 | |
913 u = format_lex (); | |
914 if (u == FMT_ERROR) | |
915 goto fail; | |
916 if (u != FMT_PERIOD) | |
917 { | |
918 /* Warn if -std=legacy, otherwise error. */ | |
919 format_locus.nextc += format_string_pos; | |
920 if (gfc_option.warn_std != 0) | |
921 { | |
922 gfc_error ("Period required in format " | |
923 "specifier %s at %L", token_to_string (t), | |
924 &format_locus); | |
925 saved_token = u; | |
926 goto fail; | |
927 } | |
928 else | |
929 gfc_warning (0, "Period required in format " | |
930 "specifier %s at %L", token_to_string (t), | |
931 &format_locus); | |
932 /* If we go to finished, we need to unwind this | |
933 before the next round. */ | |
934 format_locus.nextc -= format_string_pos; | |
935 saved_token = u; | |
936 break; | |
937 } | |
938 | |
939 u = format_lex (); | |
940 if (u == FMT_ERROR) | |
941 goto fail; | |
942 if (u != FMT_ZERO && u != FMT_POSINT) | |
943 { | |
944 error = nonneg_required; | |
945 goto syntax; | |
946 } | |
947 | |
948 if (t == FMT_D) | |
949 break; | |
950 | |
951 /* Look for optional exponent. */ | |
952 u = format_lex (); | |
953 if (u == FMT_ERROR) | |
954 goto fail; | |
955 if (u != FMT_E) | |
956 { | |
957 saved_token = u; | |
958 } | |
959 else | |
960 { | |
961 u = format_lex (); | |
962 if (u == FMT_ERROR) | |
963 goto fail; | |
964 if (u != FMT_POSINT) | |
965 { | |
966 error = _("Positive exponent width required"); | |
967 goto syntax; | |
968 } | |
969 } | |
970 | |
971 break; | |
972 | |
973 case FMT_DT: | |
974 t = format_lex (); | |
975 if (t == FMT_ERROR) | |
976 goto fail; | |
977 switch (t) | |
978 { | |
979 case FMT_RPAREN: | |
980 level--; | |
981 if (level < 0) | |
982 goto finished; | |
983 goto between_desc; | |
984 | |
985 case FMT_COMMA: | |
986 goto format_item; | |
987 | |
988 case FMT_LPAREN: | |
989 | |
990 dtio_vlist: | |
991 t = format_lex (); | |
992 if (t == FMT_ERROR) | |
993 goto fail; | |
994 | |
995 if (t != FMT_POSINT) | |
996 { | |
997 error = posint_required; | |
998 goto syntax; | |
999 } | |
1000 | |
1001 t = format_lex (); | |
1002 if (t == FMT_ERROR) | |
1003 goto fail; | |
1004 | |
1005 if (t == FMT_COMMA) | |
1006 goto dtio_vlist; | |
1007 if (t != FMT_RPAREN) | |
1008 { | |
1009 error = _("Right parenthesis expected at %C"); | |
1010 goto syntax; | |
1011 } | |
1012 goto between_desc; | |
1013 | |
1014 default: | |
1015 error = unexpected_element; | |
1016 goto syntax; | |
1017 } | |
1018 break; | |
1019 | |
1020 case FMT_F: | |
1021 t = format_lex (); | |
1022 if (t == FMT_ERROR) | |
1023 goto fail; | |
1024 if (t != FMT_ZERO && t != FMT_POSINT) | |
1025 { | |
1026 error = nonneg_required; | |
1027 goto syntax; | |
1028 } | |
1029 else if (is_input && t == FMT_ZERO) | |
1030 { | |
1031 error = posint_required; | |
1032 goto syntax; | |
1033 } | |
1034 | |
1035 t = format_lex (); | |
1036 if (t == FMT_ERROR) | |
1037 goto fail; | |
1038 if (t != FMT_PERIOD) | |
1039 { | |
1040 /* Warn if -std=legacy, otherwise error. */ | |
1041 if (gfc_option.warn_std != 0) | |
1042 { | |
1043 error = _("Period required in format specifier"); | |
1044 goto syntax; | |
1045 } | |
1046 if (mode != MODE_FORMAT) | |
1047 format_locus.nextc += format_string_pos; | |
1048 gfc_warning (0, "Period required in format specifier at %L", | |
1049 &format_locus); | |
1050 saved_token = t; | |
1051 break; | |
1052 } | |
1053 | |
1054 t = format_lex (); | |
1055 if (t == FMT_ERROR) | |
1056 goto fail; | |
1057 if (t != FMT_ZERO && t != FMT_POSINT) | |
1058 { | |
1059 error = nonneg_required; | |
1060 goto syntax; | |
1061 } | |
1062 | |
1063 break; | |
1064 | |
1065 case FMT_H: | |
1066 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings) | |
1067 { | |
1068 if (mode != MODE_FORMAT) | |
1069 format_locus.nextc += format_string_pos; | |
1070 gfc_warning (0, "The H format specifier at %L is" | |
1071 " a Fortran 95 deleted feature", &format_locus); | |
1072 } | |
1073 if (mode == MODE_STRING) | |
1074 { | |
1075 format_string += value; | |
1076 format_length -= value; | |
1077 format_string_pos += repeat; | |
1078 } | |
1079 else | |
1080 { | |
1081 while (repeat >0) | |
1082 { | |
1083 next_char (INSTRING_WARN); | |
1084 repeat -- ; | |
1085 } | |
1086 } | |
1087 break; | |
1088 | |
1089 case FMT_IBOZ: | |
1090 t = format_lex (); | |
1091 if (t == FMT_ERROR) | |
1092 goto fail; | |
1093 if (t != FMT_ZERO && t != FMT_POSINT) | |
1094 { | |
1095 error = nonneg_required; | |
1096 goto syntax; | |
1097 } | |
1098 else if (is_input && t == FMT_ZERO) | |
1099 { | |
1100 error = posint_required; | |
1101 goto syntax; | |
1102 } | |
1103 | |
1104 t = format_lex (); | |
1105 if (t == FMT_ERROR) | |
1106 goto fail; | |
1107 if (t != FMT_PERIOD) | |
1108 { | |
1109 saved_token = t; | |
1110 } | |
1111 else | |
1112 { | |
1113 t = format_lex (); | |
1114 if (t == FMT_ERROR) | |
1115 goto fail; | |
1116 if (t != FMT_ZERO && t != FMT_POSINT) | |
1117 { | |
1118 error = nonneg_required; | |
1119 goto syntax; | |
1120 } | |
1121 } | |
1122 | |
1123 break; | |
1124 | |
1125 default: | |
1126 error = unexpected_element; | |
1127 goto syntax; | |
1128 } | |
1129 | |
1130 between_desc: | |
1131 /* Between a descriptor and what comes next. */ | |
1132 t = format_lex (); | |
1133 if (t == FMT_ERROR) | |
1134 goto fail; | |
1135 switch (t) | |
1136 { | |
1137 | |
1138 case FMT_COMMA: | |
1139 goto format_item; | |
1140 | |
1141 case FMT_RPAREN: | |
1142 level--; | |
1143 if (level < 0) | |
1144 goto finished; | |
1145 goto between_desc; | |
1146 | |
1147 case FMT_COLON: | |
1148 case FMT_SLASH: | |
1149 goto optional_comma; | |
1150 | |
1151 case FMT_END: | |
1152 error = unexpected_end; | |
1153 goto syntax; | |
1154 | |
1155 default: | |
1156 if (mode != MODE_FORMAT) | |
1157 format_locus.nextc += format_string_pos - 1; | |
1158 if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus)) | |
1159 return false; | |
1160 /* If we do not actually return a failure, we need to unwind this | |
1161 before the next round. */ | |
1162 if (mode != MODE_FORMAT) | |
1163 format_locus.nextc -= format_string_pos; | |
1164 goto format_item_1; | |
1165 } | |
1166 | |
1167 optional_comma: | |
1168 /* Optional comma is a weird between state where we've just finished | |
1169 reading a colon, slash, dollar or P descriptor. */ | |
1170 t = format_lex (); | |
1171 if (t == FMT_ERROR) | |
1172 goto fail; | |
1173 optional_comma_1: | |
1174 switch (t) | |
1175 { | |
1176 case FMT_COMMA: | |
1177 break; | |
1178 | |
1179 case FMT_RPAREN: | |
1180 level--; | |
1181 if (level < 0) | |
1182 goto finished; | |
1183 goto between_desc; | |
1184 | |
1185 default: | |
1186 /* Assume that we have another format item. */ | |
1187 saved_token = t; | |
1188 break; | |
1189 } | |
1190 | |
1191 goto format_item; | |
1192 | |
1193 extension_optional_comma: | |
1194 /* As a GNU extension, permit a missing comma after a string literal. */ | |
1195 t = format_lex (); | |
1196 if (t == FMT_ERROR) | |
1197 goto fail; | |
1198 switch (t) | |
1199 { | |
1200 case FMT_COMMA: | |
1201 break; | |
1202 | |
1203 case FMT_RPAREN: | |
1204 level--; | |
1205 if (level < 0) | |
1206 goto finished; | |
1207 goto between_desc; | |
1208 | |
1209 case FMT_COLON: | |
1210 case FMT_SLASH: | |
1211 goto optional_comma; | |
1212 | |
1213 case FMT_END: | |
1214 error = unexpected_end; | |
1215 goto syntax; | |
1216 | |
1217 default: | |
1218 if (mode != MODE_FORMAT) | |
1219 format_locus.nextc += format_string_pos; | |
1220 if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus)) | |
1221 return false; | |
1222 /* If we do not actually return a failure, we need to unwind this | |
1223 before the next round. */ | |
1224 if (mode != MODE_FORMAT) | |
1225 format_locus.nextc -= format_string_pos; | |
1226 saved_token = t; | |
1227 break; | |
1228 } | |
1229 | |
1230 goto format_item; | |
1231 | |
1232 syntax: | |
1233 if (mode != MODE_FORMAT) | |
1234 format_locus.nextc += format_string_pos; | |
1235 if (error == unexpected_element) | |
1236 gfc_error (error, error_element, &format_locus); | |
1237 else | |
1238 gfc_error ("%s in format string at %L", error, &format_locus); | |
1239 fail: | |
1240 rv = false; | |
1241 | |
1242 finished: | |
1243 return rv; | |
1244 } | |
1245 | |
1246 | |
1247 /* Given an expression node that is a constant string, see if it looks | |
1248 like a format string. */ | |
1249 | |
1250 static bool | |
1251 check_format_string (gfc_expr *e, bool is_input) | |
1252 { | |
1253 bool rv; | |
1254 int i; | |
1255 if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) | |
1256 return true; | |
1257 | |
1258 mode = MODE_STRING; | |
1259 format_string = e->value.character.string; | |
1260 | |
1261 /* More elaborate measures are needed to show where a problem is within a | |
1262 format string that has been calculated, but that's probably not worth the | |
1263 effort. */ | |
1264 format_locus = e->where; | |
1265 rv = check_format (is_input); | |
1266 /* check for extraneous characters at the end of an otherwise valid format | |
1267 string, like '(A10,I3)F5' | |
1268 start at the end and move back to the last character processed, | |
1269 spaces are OK */ | |
1270 if (rv && e->value.character.length > format_string_pos) | |
1271 for (i=e->value.character.length-1;i>format_string_pos-1;i--) | |
1272 if (e->value.character.string[i] != ' ') | |
1273 { | |
1274 format_locus.nextc += format_length + 1; | |
1275 gfc_warning (0, | |
1276 "Extraneous characters in format at %L", &format_locus); | |
1277 break; | |
1278 } | |
1279 return rv; | |
1280 } | |
1281 | |
1282 | |
1283 /************ Fortran I/O statement matchers *************/ | |
1284 | |
1285 /* Match a FORMAT statement. This amounts to actually parsing the | |
1286 format descriptors in order to correctly locate the end of the | |
1287 format string. */ | |
1288 | |
1289 match | |
1290 gfc_match_format (void) | |
1291 { | |
1292 gfc_expr *e; | |
1293 locus start; | |
1294 | |
1295 if (gfc_current_ns->proc_name | |
1296 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE) | |
1297 { | |
1298 gfc_error ("Format statement in module main block at %C"); | |
1299 return MATCH_ERROR; | |
1300 } | |
1301 | |
1302 /* Before parsing the rest of a FORMAT statement, check F2008:c1206. */ | |
1303 if ((gfc_current_state () == COMP_FUNCTION | |
1304 || gfc_current_state () == COMP_SUBROUTINE) | |
1305 && gfc_state_stack->previous->state == COMP_INTERFACE) | |
1306 { | |
1307 gfc_error ("FORMAT statement at %C cannot appear within an INTERFACE"); | |
1308 return MATCH_ERROR; | |
1309 } | |
1310 | |
1311 if (gfc_statement_label == NULL) | |
1312 { | |
1313 gfc_error ("Missing format label at %C"); | |
1314 return MATCH_ERROR; | |
1315 } | |
1316 gfc_gobble_whitespace (); | |
1317 | |
1318 mode = MODE_FORMAT; | |
1319 format_length = 0; | |
1320 | |
1321 start = gfc_current_locus; | |
1322 | |
1323 if (!check_format (false)) | |
1324 return MATCH_ERROR; | |
1325 | |
1326 if (gfc_match_eos () != MATCH_YES) | |
1327 { | |
1328 gfc_syntax_error (ST_FORMAT); | |
1329 return MATCH_ERROR; | |
1330 } | |
1331 | |
1332 /* The label doesn't get created until after the statement is done | |
1333 being matched, so we have to leave the string for later. */ | |
1334 | |
1335 gfc_current_locus = start; /* Back to the beginning */ | |
1336 | |
1337 new_st.loc = start; | |
1338 new_st.op = EXEC_NOP; | |
1339 | |
1340 e = gfc_get_character_expr (gfc_default_character_kind, &start, | |
1341 NULL, format_length); | |
1342 format_string = e->value.character.string; | |
1343 gfc_statement_label->format = e; | |
1344 | |
1345 mode = MODE_COPY; | |
1346 check_format (false); /* Guaranteed to succeed */ | |
1347 gfc_match_eos (); /* Guaranteed to succeed */ | |
1348 | |
1349 return MATCH_YES; | |
1350 } | |
1351 | |
1352 | |
1353 /* Check for a CHARACTER variable. The check for scalar is done in | |
1354 resolve_tag. */ | |
1355 | |
1356 static bool | |
1357 check_char_variable (gfc_expr *e) | |
1358 { | |
1359 if (e->expr_type != EXPR_VARIABLE || e->ts.type != BT_CHARACTER) | |
1360 { | |
1361 gfc_error("IOMSG must be a scalar-default-char-variable at %L", &e->where); | |
1362 return false; | |
1363 } | |
1364 return true; | |
1365 } | |
1366 | |
1367 | |
1368 static bool | |
1369 is_char_type (const char *name, gfc_expr *e) | |
1370 { | |
1371 gfc_resolve_expr (e); | |
1372 | |
1373 if (e->ts.type != BT_CHARACTER) | |
1374 { | |
1375 gfc_error ("%s requires a scalar-default-char-expr at %L", | |
1376 name, &e->where); | |
1377 return false; | |
1378 } | |
1379 return true; | |
1380 } | |
1381 | |
1382 | |
1383 /* Match an expression I/O tag of some sort. */ | |
1384 | |
1385 static match | |
1386 match_etag (const io_tag *tag, gfc_expr **v) | |
1387 { | |
1388 gfc_expr *result; | |
1389 match m; | |
1390 | |
1391 m = gfc_match (tag->spec); | |
1392 if (m != MATCH_YES) | |
1393 return m; | |
1394 | |
1395 m = gfc_match (tag->value, &result); | |
1396 if (m != MATCH_YES) | |
1397 { | |
1398 gfc_error ("Invalid value for %s specification at %C", tag->name); | |
1399 return MATCH_ERROR; | |
1400 } | |
1401 | |
1402 if (*v != NULL) | |
1403 { | |
1404 gfc_error ("Duplicate %s specification at %C", tag->name); | |
1405 gfc_free_expr (result); | |
1406 return MATCH_ERROR; | |
1407 } | |
1408 | |
1409 *v = result; | |
1410 return MATCH_YES; | |
1411 } | |
1412 | |
1413 | |
1414 /* Match a variable I/O tag of some sort. */ | |
1415 | |
1416 static match | |
1417 match_vtag (const io_tag *tag, gfc_expr **v) | |
1418 { | |
1419 gfc_expr *result; | |
1420 match m; | |
1421 | |
1422 m = gfc_match (tag->spec); | |
1423 if (m != MATCH_YES) | |
1424 return m; | |
1425 | |
1426 m = gfc_match (tag->value, &result); | |
1427 if (m != MATCH_YES) | |
1428 { | |
1429 gfc_error ("Invalid value for %s specification at %C", tag->name); | |
1430 return MATCH_ERROR; | |
1431 } | |
1432 | |
1433 if (*v != NULL) | |
1434 { | |
1435 gfc_error ("Duplicate %s specification at %C", tag->name); | |
1436 gfc_free_expr (result); | |
1437 return MATCH_ERROR; | |
1438 } | |
1439 | |
1440 if (result->symtree->n.sym->attr.intent == INTENT_IN) | |
1441 { | |
1442 gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag->name); | |
1443 gfc_free_expr (result); | |
1444 return MATCH_ERROR; | |
1445 } | |
1446 | |
1447 bool impure = gfc_impure_variable (result->symtree->n.sym); | |
1448 if (impure && gfc_pure (NULL)) | |
1449 { | |
1450 gfc_error ("Variable %s cannot be assigned in PURE procedure at %C", | |
1451 tag->name); | |
1452 gfc_free_expr (result); | |
1453 return MATCH_ERROR; | |
1454 } | |
1455 | |
1456 if (impure) | |
1457 gfc_unset_implicit_pure (NULL); | |
1458 | |
1459 *v = result; | |
1460 return MATCH_YES; | |
1461 } | |
1462 | |
1463 | |
1464 /* Match I/O tags that cause variables to become redefined. */ | |
1465 | |
1466 static match | |
1467 match_out_tag (const io_tag *tag, gfc_expr **result) | |
1468 { | |
1469 match m; | |
1470 | |
1471 m = match_vtag (tag, result); | |
1472 if (m == MATCH_YES) | |
1473 gfc_check_do_variable ((*result)->symtree); | |
1474 | |
1475 return m; | |
1476 } | |
1477 | |
1478 | |
1479 /* Match a label I/O tag. */ | |
1480 | |
1481 static match | |
1482 match_ltag (const io_tag *tag, gfc_st_label ** label) | |
1483 { | |
1484 match m; | |
1485 gfc_st_label *old; | |
1486 | |
1487 old = *label; | |
1488 m = gfc_match (tag->spec); | |
1489 if (m != MATCH_YES) | |
1490 return m; | |
1491 | |
1492 m = gfc_match (tag->value, label); | |
1493 if (m != MATCH_YES) | |
1494 { | |
1495 gfc_error ("Invalid value for %s specification at %C", tag->name); | |
1496 return MATCH_ERROR; | |
1497 } | |
1498 | |
1499 if (old) | |
1500 { | |
1501 gfc_error ("Duplicate %s label specification at %C", tag->name); | |
1502 return MATCH_ERROR; | |
1503 } | |
1504 | |
1505 if (!gfc_reference_st_label (*label, ST_LABEL_TARGET)) | |
1506 return MATCH_ERROR; | |
1507 | |
1508 return m; | |
1509 } | |
1510 | |
1511 | |
1512 /* Match a tag using match_etag, but only if -fdec is enabled. */ | |
1513 static match | |
1514 match_dec_etag (const io_tag *tag, gfc_expr **e) | |
1515 { | |
1516 match m = match_etag (tag, e); | |
1517 if (flag_dec && m != MATCH_NO) | |
1518 return m; | |
1519 else if (m != MATCH_NO) | |
1520 { | |
1521 gfc_error ("%s at %C is a DEC extension, enable with " | |
1522 "%<-fdec%>", tag->name); | |
1523 return MATCH_ERROR; | |
1524 } | |
1525 return m; | |
1526 } | |
1527 | |
1528 | |
1529 /* Match a tag using match_vtag, but only if -fdec is enabled. */ | |
1530 static match | |
1531 match_dec_vtag (const io_tag *tag, gfc_expr **e) | |
1532 { | |
1533 match m = match_vtag(tag, e); | |
1534 if (flag_dec && m != MATCH_NO) | |
1535 return m; | |
1536 else if (m != MATCH_NO) | |
1537 { | |
1538 gfc_error ("%s at %C is a DEC extension, enable with " | |
1539 "%<-fdec%>", tag->name); | |
1540 return MATCH_ERROR; | |
1541 } | |
1542 return m; | |
1543 } | |
1544 | |
1545 | |
1546 /* Match a DEC I/O flag tag - a tag with no expression such as READONLY. */ | |
1547 | |
1548 static match | |
1549 match_dec_ftag (const io_tag *tag, gfc_open *o) | |
1550 { | |
1551 match m; | |
1552 | |
1553 m = gfc_match (tag->spec); | |
1554 if (m != MATCH_YES) | |
1555 return m; | |
1556 | |
1557 if (!flag_dec) | |
1558 { | |
1559 gfc_error ("%s at %C is a DEC extension, enable with " | |
1560 "%<-fdec%>", tag->name); | |
1561 return MATCH_ERROR; | |
1562 } | |
1563 | |
1564 /* Just set the READONLY flag, which we use at runtime to avoid delete on | |
1565 close. */ | |
1566 if (tag == &tag_readonly) | |
1567 { | |
1568 o->readonly |= 1; | |
1569 return MATCH_YES; | |
1570 } | |
1571 | |
1572 /* Interpret SHARED as SHARE='DENYNONE' (read lock). */ | |
1573 else if (tag == &tag_shared) | |
1574 { | |
1575 if (o->share != NULL) | |
1576 { | |
1577 gfc_error ("Duplicate %s specification at %C", tag->name); | |
1578 return MATCH_ERROR; | |
1579 } | |
1580 o->share = gfc_get_character_expr (gfc_default_character_kind, | |
1581 &gfc_current_locus, "denynone", 8); | |
1582 return MATCH_YES; | |
1583 } | |
1584 | |
1585 /* Interpret NOSHARED as SHARE='DENYRW' (exclusive lock). */ | |
1586 else if (tag == &tag_noshared) | |
1587 { | |
1588 if (o->share != NULL) | |
1589 { | |
1590 gfc_error ("Duplicate %s specification at %C", tag->name); | |
1591 return MATCH_ERROR; | |
1592 } | |
1593 o->share = gfc_get_character_expr (gfc_default_character_kind, | |
1594 &gfc_current_locus, "denyrw", 6); | |
1595 return MATCH_YES; | |
1596 } | |
1597 | |
1598 /* We handle all DEC tags above. */ | |
1599 gcc_unreachable (); | |
1600 } | |
1601 | |
1602 | |
1603 /* Resolution of the FORMAT tag, to be called from resolve_tag. */ | |
1604 | |
1605 static bool | |
1606 resolve_tag_format (const gfc_expr *e) | |
1607 { | |
1608 if (e->expr_type == EXPR_CONSTANT | |
1609 && (e->ts.type != BT_CHARACTER | |
1610 || e->ts.kind != gfc_default_character_kind)) | |
1611 { | |
1612 gfc_error ("Constant expression in FORMAT tag at %L must be " | |
1613 "of type default CHARACTER", &e->where); | |
1614 return false; | |
1615 } | |
1616 | |
1617 /* If e's rank is zero and e is not an element of an array, it should be | |
1618 of integer or character type. The integer variable should be | |
1619 ASSIGNED. */ | |
1620 if (e->rank == 0 | |
1621 && (e->expr_type != EXPR_VARIABLE | |
1622 || e->symtree == NULL | |
1623 || e->symtree->n.sym->as == NULL | |
1624 || e->symtree->n.sym->as->rank == 0)) | |
1625 { | |
1626 if ((e->ts.type != BT_CHARACTER | |
1627 || e->ts.kind != gfc_default_character_kind) | |
1628 && e->ts.type != BT_INTEGER) | |
1629 { | |
1630 gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER " | |
1631 "or of INTEGER", &e->where); | |
1632 return false; | |
1633 } | |
1634 else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE) | |
1635 { | |
1636 if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGNED variable in " | |
1637 "FORMAT tag at %L", &e->where)) | |
1638 return false; | |
1639 if (e->symtree->n.sym->attr.assign != 1) | |
1640 { | |
1641 gfc_error ("Variable %qs at %L has not been assigned a " | |
1642 "format label", e->symtree->n.sym->name, &e->where); | |
1643 return false; | |
1644 } | |
1645 } | |
1646 else if (e->ts.type == BT_INTEGER) | |
1647 { | |
1648 gfc_error ("Scalar %qs in FORMAT tag at %L is not an ASSIGNED " | |
1649 "variable", gfc_basic_typename (e->ts.type), &e->where); | |
1650 return false; | |
1651 } | |
1652 | |
1653 return true; | |
1654 } | |
1655 | |
1656 /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY. | |
1657 It may be assigned an Hollerith constant. */ | |
1658 if (e->ts.type != BT_CHARACTER) | |
1659 { | |
1660 if (!gfc_notify_std (GFC_STD_LEGACY, "Non-character in FORMAT tag " | |
1661 "at %L", &e->where)) | |
1662 return false; | |
1663 | |
1664 if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE) | |
1665 { | |
1666 gfc_error ("Non-character assumed shape array element in FORMAT" | |
1667 " tag at %L", &e->where); | |
1668 return false; | |
1669 } | |
1670 | |
1671 if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE) | |
1672 { | |
1673 gfc_error ("Non-character assumed size array element in FORMAT" | |
1674 " tag at %L", &e->where); | |
1675 return false; | |
1676 } | |
1677 | |
1678 if (e->rank == 0 && e->symtree->n.sym->attr.pointer) | |
1679 { | |
1680 gfc_error ("Non-character pointer array element in FORMAT tag at %L", | |
1681 &e->where); | |
1682 return false; | |
1683 } | |
1684 } | |
1685 | |
1686 return true; | |
1687 } | |
1688 | |
1689 | |
1690 /* Do expression resolution and type-checking on an expression tag. */ | |
1691 | |
1692 static bool | |
1693 resolve_tag (const io_tag *tag, gfc_expr *e) | |
1694 { | |
1695 if (e == NULL) | |
1696 return true; | |
1697 | |
1698 if (!gfc_resolve_expr (e)) | |
1699 return false; | |
1700 | |
1701 if (tag == &tag_format) | |
1702 return resolve_tag_format (e); | |
1703 | |
1704 if (e->ts.type != tag->type) | |
1705 { | |
1706 gfc_error ("%s tag at %L must be of type %s", tag->name, | |
1707 &e->where, gfc_basic_typename (tag->type)); | |
1708 return false; | |
1709 } | |
1710 | |
1711 if (e->ts.type == BT_CHARACTER && e->ts.kind != gfc_default_character_kind) | |
1712 { | |
1713 gfc_error ("%s tag at %L must be a character string of default kind", | |
1714 tag->name, &e->where); | |
1715 return false; | |
1716 } | |
1717 | |
1718 if (e->rank != 0) | |
1719 { | |
1720 gfc_error ("%s tag at %L must be scalar", tag->name, &e->where); | |
1721 return false; | |
1722 } | |
1723 | |
1724 if (tag == &tag_iomsg) | |
1725 { | |
1726 if (!gfc_notify_std (GFC_STD_F2003, "IOMSG tag at %L", &e->where)) | |
1727 return false; | |
1728 } | |
1729 | |
1730 if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength | |
1731 || tag == &tag_number || tag == &tag_nextrec || tag == &tag_s_recl) | |
1732 && e->ts.kind != gfc_default_integer_kind) | |
1733 { | |
1734 if (!gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default " | |
1735 "INTEGER in %s tag at %L", tag->name, &e->where)) | |
1736 return false; | |
1737 } | |
1738 | |
1739 if (e->ts.kind != gfc_default_logical_kind && | |
1740 (tag == &tag_exist || tag == &tag_named || tag == &tag_opened | |
1741 || tag == &tag_pending)) | |
1742 { | |
1743 if (!gfc_notify_std (GFC_STD_F2008, "Non-default LOGICAL kind " | |
1744 "in %s tag at %L", tag->name, &e->where)) | |
1745 return false; | |
1746 } | |
1747 | |
1748 if (tag == &tag_newunit) | |
1749 { | |
1750 if (!gfc_notify_std (GFC_STD_F2008, "NEWUNIT specifier at %L", | |
1751 &e->where)) | |
1752 return false; | |
1753 } | |
1754 | |
1755 /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */ | |
1756 if (tag == &tag_newunit || tag == &tag_iostat | |
1757 || tag == &tag_size || tag == &tag_iomsg) | |
1758 { | |
1759 char context[64]; | |
1760 | |
1761 sprintf (context, _("%s tag"), tag->name); | |
1762 if (!gfc_check_vardef_context (e, false, false, false, context)) | |
1763 return false; | |
1764 } | |
1765 | |
1766 if (tag == &tag_convert) | |
1767 { | |
1768 if (!gfc_notify_std (GFC_STD_GNU, "CONVERT tag at %L", &e->where)) | |
1769 return false; | |
1770 } | |
1771 | |
1772 return true; | |
1773 } | |
1774 | |
1775 | |
1776 /* Match a single tag of an OPEN statement. */ | |
1777 | |
1778 static match | |
1779 match_open_element (gfc_open *open) | |
1780 { | |
1781 match m; | |
1782 | |
1783 m = match_etag (&tag_e_async, &open->asynchronous); | |
1784 if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", open->asynchronous)) | |
1785 return MATCH_ERROR; | |
1786 if (m != MATCH_NO) | |
1787 return m; | |
1788 m = match_etag (&tag_unit, &open->unit); | |
1789 if (m != MATCH_NO) | |
1790 return m; | |
1791 m = match_etag (&tag_iomsg, &open->iomsg); | |
1792 if (m == MATCH_YES && !check_char_variable (open->iomsg)) | |
1793 return MATCH_ERROR; | |
1794 if (m != MATCH_NO) | |
1795 return m; | |
1796 m = match_out_tag (&tag_iostat, &open->iostat); | |
1797 if (m != MATCH_NO) | |
1798 return m; | |
1799 m = match_etag (&tag_file, &open->file); | |
1800 if (m != MATCH_NO) | |
1801 return m; | |
1802 m = match_etag (&tag_status, &open->status); | |
1803 if (m != MATCH_NO) | |
1804 return m; | |
1805 m = match_etag (&tag_e_access, &open->access); | |
1806 if (m != MATCH_NO) | |
1807 return m; | |
1808 m = match_etag (&tag_e_form, &open->form); | |
1809 if (m != MATCH_NO) | |
1810 return m; | |
1811 m = match_etag (&tag_e_recl, &open->recl); | |
1812 if (m != MATCH_NO) | |
1813 return m; | |
1814 m = match_etag (&tag_e_blank, &open->blank); | |
1815 if (m != MATCH_NO) | |
1816 return m; | |
1817 m = match_etag (&tag_e_position, &open->position); | |
1818 if (m != MATCH_NO) | |
1819 return m; | |
1820 m = match_etag (&tag_e_action, &open->action); | |
1821 if (m != MATCH_NO) | |
1822 return m; | |
1823 m = match_etag (&tag_e_delim, &open->delim); | |
1824 if (m != MATCH_NO) | |
1825 return m; | |
1826 m = match_etag (&tag_e_pad, &open->pad); | |
1827 if (m != MATCH_NO) | |
1828 return m; | |
1829 m = match_etag (&tag_e_decimal, &open->decimal); | |
1830 if (m != MATCH_NO) | |
1831 return m; | |
1832 m = match_etag (&tag_e_encoding, &open->encoding); | |
1833 if (m != MATCH_NO) | |
1834 return m; | |
1835 m = match_etag (&tag_e_round, &open->round); | |
1836 if (m != MATCH_NO) | |
1837 return m; | |
1838 m = match_etag (&tag_e_sign, &open->sign); | |
1839 if (m != MATCH_NO) | |
1840 return m; | |
1841 m = match_ltag (&tag_err, &open->err); | |
1842 if (m != MATCH_NO) | |
1843 return m; | |
1844 m = match_etag (&tag_convert, &open->convert); | |
1845 if (m != MATCH_NO) | |
1846 return m; | |
1847 m = match_out_tag (&tag_newunit, &open->newunit); | |
1848 if (m != MATCH_NO) | |
1849 return m; | |
1850 | |
1851 /* The following are extensions enabled with -fdec. */ | |
1852 m = match_dec_etag (&tag_e_share, &open->share); | |
1853 if (m != MATCH_NO) | |
1854 return m; | |
1855 m = match_dec_etag (&tag_cc, &open->cc); | |
1856 if (m != MATCH_NO) | |
1857 return m; | |
1858 m = match_dec_ftag (&tag_readonly, open); | |
1859 if (m != MATCH_NO) | |
1860 return m; | |
1861 m = match_dec_ftag (&tag_shared, open); | |
1862 if (m != MATCH_NO) | |
1863 return m; | |
1864 m = match_dec_ftag (&tag_noshared, open); | |
1865 if (m != MATCH_NO) | |
1866 return m; | |
1867 | |
1868 return MATCH_NO; | |
1869 } | |
1870 | |
1871 | |
1872 /* Free the gfc_open structure and all the expressions it contains. */ | |
1873 | |
1874 void | |
1875 gfc_free_open (gfc_open *open) | |
1876 { | |
1877 if (open == NULL) | |
1878 return; | |
1879 | |
1880 gfc_free_expr (open->unit); | |
1881 gfc_free_expr (open->iomsg); | |
1882 gfc_free_expr (open->iostat); | |
1883 gfc_free_expr (open->file); | |
1884 gfc_free_expr (open->status); | |
1885 gfc_free_expr (open->access); | |
1886 gfc_free_expr (open->form); | |
1887 gfc_free_expr (open->recl); | |
1888 gfc_free_expr (open->blank); | |
1889 gfc_free_expr (open->position); | |
1890 gfc_free_expr (open->action); | |
1891 gfc_free_expr (open->delim); | |
1892 gfc_free_expr (open->pad); | |
1893 gfc_free_expr (open->decimal); | |
1894 gfc_free_expr (open->encoding); | |
1895 gfc_free_expr (open->round); | |
1896 gfc_free_expr (open->sign); | |
1897 gfc_free_expr (open->convert); | |
1898 gfc_free_expr (open->asynchronous); | |
1899 gfc_free_expr (open->newunit); | |
1900 gfc_free_expr (open->share); | |
1901 gfc_free_expr (open->cc); | |
1902 free (open); | |
1903 } | |
1904 | |
1905 | |
1906 /* Resolve everything in a gfc_open structure. */ | |
1907 | |
1908 bool | |
1909 gfc_resolve_open (gfc_open *open) | |
1910 { | |
1911 | |
1912 RESOLVE_TAG (&tag_unit, open->unit); | |
1913 RESOLVE_TAG (&tag_iomsg, open->iomsg); | |
1914 RESOLVE_TAG (&tag_iostat, open->iostat); | |
1915 RESOLVE_TAG (&tag_file, open->file); | |
1916 RESOLVE_TAG (&tag_status, open->status); | |
1917 RESOLVE_TAG (&tag_e_access, open->access); | |
1918 RESOLVE_TAG (&tag_e_form, open->form); | |
1919 RESOLVE_TAG (&tag_e_recl, open->recl); | |
1920 RESOLVE_TAG (&tag_e_blank, open->blank); | |
1921 RESOLVE_TAG (&tag_e_position, open->position); | |
1922 RESOLVE_TAG (&tag_e_action, open->action); | |
1923 RESOLVE_TAG (&tag_e_delim, open->delim); | |
1924 RESOLVE_TAG (&tag_e_pad, open->pad); | |
1925 RESOLVE_TAG (&tag_e_decimal, open->decimal); | |
1926 RESOLVE_TAG (&tag_e_encoding, open->encoding); | |
1927 RESOLVE_TAG (&tag_e_async, open->asynchronous); | |
1928 RESOLVE_TAG (&tag_e_round, open->round); | |
1929 RESOLVE_TAG (&tag_e_sign, open->sign); | |
1930 RESOLVE_TAG (&tag_convert, open->convert); | |
1931 RESOLVE_TAG (&tag_newunit, open->newunit); | |
1932 RESOLVE_TAG (&tag_e_share, open->share); | |
1933 RESOLVE_TAG (&tag_cc, open->cc); | |
1934 | |
1935 if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET)) | |
1936 return false; | |
1937 | |
1938 return true; | |
1939 } | |
1940 | |
1941 | |
1942 /* Check if a given value for a SPECIFIER is either in the list of values | |
1943 allowed in F95 or F2003, issuing an error message and returning a zero | |
1944 value if it is not allowed. */ | |
1945 | |
1946 static int | |
1947 compare_to_allowed_values (const char *specifier, const char *allowed[], | |
1948 const char *allowed_f2003[], | |
1949 const char *allowed_gnu[], gfc_char_t *value, | |
1950 const char *statement, bool warn, | |
1951 int *num = NULL); | |
1952 | |
1953 | |
1954 static int | |
1955 compare_to_allowed_values (const char *specifier, const char *allowed[], | |
1956 const char *allowed_f2003[], | |
1957 const char *allowed_gnu[], gfc_char_t *value, | |
1958 const char *statement, bool warn, int *num) | |
1959 { | |
1960 int i; | |
1961 unsigned int len; | |
1962 | |
1963 len = gfc_wide_strlen (value); | |
1964 if (len > 0) | |
1965 { | |
1966 for (len--; len > 0; len--) | |
1967 if (value[len] != ' ') | |
1968 break; | |
1969 len++; | |
1970 } | |
1971 | |
1972 for (i = 0; allowed[i]; i++) | |
1973 if (len == strlen (allowed[i]) | |
1974 && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0) | |
1975 { | |
1976 if (num) | |
1977 *num = i; | |
1978 return 1; | |
1979 } | |
1980 | |
1981 for (i = 0; allowed_f2003 && allowed_f2003[i]; i++) | |
1982 if (len == strlen (allowed_f2003[i]) | |
1983 && gfc_wide_strncasecmp (value, allowed_f2003[i], | |
1984 strlen (allowed_f2003[i])) == 0) | |
1985 { | |
1986 notification n = gfc_notification_std (GFC_STD_F2003); | |
1987 | |
1988 if (n == WARNING || (warn && n == ERROR)) | |
1989 { | |
1990 gfc_warning (0, "Fortran 2003: %s specifier in %s statement at %C " | |
1991 "has value %qs", specifier, statement, | |
1992 allowed_f2003[i]); | |
1993 return 1; | |
1994 } | |
1995 else | |
1996 if (n == ERROR) | |
1997 { | |
1998 gfc_notify_std (GFC_STD_F2003, "%s specifier in " | |
1999 "%s statement at %C has value %qs", specifier, | |
2000 statement, allowed_f2003[i]); | |
2001 return 0; | |
2002 } | |
2003 | |
2004 /* n == SILENT */ | |
2005 return 1; | |
2006 } | |
2007 | |
2008 for (i = 0; allowed_gnu && allowed_gnu[i]; i++) | |
2009 if (len == strlen (allowed_gnu[i]) | |
2010 && gfc_wide_strncasecmp (value, allowed_gnu[i], | |
2011 strlen (allowed_gnu[i])) == 0) | |
2012 { | |
2013 notification n = gfc_notification_std (GFC_STD_GNU); | |
2014 | |
2015 if (n == WARNING || (warn && n == ERROR)) | |
2016 { | |
2017 gfc_warning (0, "Extension: %s specifier in %s statement at %C " | |
2018 "has value %qs", specifier, statement, | |
2019 allowed_gnu[i]); | |
2020 return 1; | |
2021 } | |
2022 else | |
2023 if (n == ERROR) | |
2024 { | |
2025 gfc_notify_std (GFC_STD_GNU, "%s specifier in " | |
2026 "%s statement at %C has value %qs", specifier, | |
2027 statement, allowed_gnu[i]); | |
2028 return 0; | |
2029 } | |
2030 | |
2031 /* n == SILENT */ | |
2032 return 1; | |
2033 } | |
2034 | |
2035 if (warn) | |
2036 { | |
2037 char *s = gfc_widechar_to_char (value, -1); | |
2038 gfc_warning (0, | |
2039 "%s specifier in %s statement at %C has invalid value %qs", | |
2040 specifier, statement, s); | |
2041 free (s); | |
2042 return 1; | |
2043 } | |
2044 else | |
2045 { | |
2046 char *s = gfc_widechar_to_char (value, -1); | |
2047 gfc_error ("%s specifier in %s statement at %C has invalid value %qs", | |
2048 specifier, statement, s); | |
2049 free (s); | |
2050 return 0; | |
2051 } | |
2052 } | |
2053 | |
2054 | |
2055 /* Match an OPEN statement. */ | |
2056 | |
2057 match | |
2058 gfc_match_open (void) | |
2059 { | |
2060 gfc_open *open; | |
2061 match m; | |
2062 bool warn; | |
2063 | |
2064 m = gfc_match_char ('('); | |
2065 if (m == MATCH_NO) | |
2066 return m; | |
2067 | |
2068 open = XCNEW (gfc_open); | |
2069 | |
2070 m = match_open_element (open); | |
2071 | |
2072 if (m == MATCH_ERROR) | |
2073 goto cleanup; | |
2074 if (m == MATCH_NO) | |
2075 { | |
2076 m = gfc_match_expr (&open->unit); | |
2077 if (m == MATCH_ERROR) | |
2078 goto cleanup; | |
2079 } | |
2080 | |
2081 for (;;) | |
2082 { | |
2083 if (gfc_match_char (')') == MATCH_YES) | |
2084 break; | |
2085 if (gfc_match_char (',') != MATCH_YES) | |
2086 goto syntax; | |
2087 | |
2088 m = match_open_element (open); | |
2089 if (m == MATCH_ERROR) | |
2090 goto cleanup; | |
2091 if (m == MATCH_NO) | |
2092 goto syntax; | |
2093 } | |
2094 | |
2095 if (gfc_match_eos () == MATCH_NO) | |
2096 goto syntax; | |
2097 | |
2098 if (gfc_pure (NULL)) | |
2099 { | |
2100 gfc_error ("OPEN statement not allowed in PURE procedure at %C"); | |
2101 goto cleanup; | |
2102 } | |
2103 | |
2104 gfc_unset_implicit_pure (NULL); | |
2105 | |
2106 warn = (open->err || open->iostat) ? true : false; | |
2107 | |
2108 /* Checks on NEWUNIT specifier. */ | |
2109 if (open->newunit) | |
2110 { | |
2111 if (open->unit) | |
2112 { | |
2113 gfc_error ("UNIT specifier not allowed with NEWUNIT at %C"); | |
2114 goto cleanup; | |
2115 } | |
2116 | |
2117 if (!open->file && open->status) | |
2118 { | |
2119 if (open->status->expr_type == EXPR_CONSTANT | |
2120 && gfc_wide_strncasecmp (open->status->value.character.string, | |
2121 "scratch", 7) != 0) | |
2122 { | |
2123 gfc_error ("NEWUNIT specifier must have FILE= " | |
2124 "or STATUS='scratch' at %C"); | |
2125 goto cleanup; | |
2126 } | |
2127 } | |
2128 } | |
2129 else if (!open->unit) | |
2130 { | |
2131 gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified"); | |
2132 goto cleanup; | |
2133 } | |
2134 | |
2135 /* Checks on the ACCESS specifier. */ | |
2136 if (open->access && open->access->expr_type == EXPR_CONSTANT) | |
2137 { | |
2138 static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL }; | |
2139 static const char *access_f2003[] = { "STREAM", NULL }; | |
2140 static const char *access_gnu[] = { "APPEND", NULL }; | |
2141 | |
2142 if (!is_char_type ("ACCESS", open->access)) | |
2143 goto cleanup; | |
2144 | |
2145 if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003, | |
2146 access_gnu, | |
2147 open->access->value.character.string, | |
2148 "OPEN", warn)) | |
2149 goto cleanup; | |
2150 } | |
2151 | |
2152 /* Checks on the ACTION specifier. */ | |
2153 if (open->action && open->action->expr_type == EXPR_CONSTANT) | |
2154 { | |
2155 gfc_char_t *str = open->action->value.character.string; | |
2156 static const char *action[] = { "READ", "WRITE", "READWRITE", NULL }; | |
2157 | |
2158 if (!is_char_type ("ACTION", open->action)) | |
2159 goto cleanup; | |
2160 | |
2161 if (!compare_to_allowed_values ("ACTION", action, NULL, NULL, | |
2162 str, "OPEN", warn)) | |
2163 goto cleanup; | |
2164 | |
2165 /* With READONLY, only allow ACTION='READ'. */ | |
2166 if (open->readonly && (gfc_wide_strlen (str) != 4 | |
2167 || gfc_wide_strncasecmp (str, "READ", 4) != 0)) | |
2168 { | |
2169 gfc_error ("ACTION type conflicts with READONLY specifier at %C"); | |
2170 goto cleanup; | |
2171 } | |
2172 } | |
2173 /* If we see READONLY and no ACTION, set ACTION='READ'. */ | |
2174 else if (open->readonly && open->action == NULL) | |
2175 { | |
2176 open->action = gfc_get_character_expr (gfc_default_character_kind, | |
2177 &gfc_current_locus, "read", 4); | |
2178 } | |
2179 | |
2180 /* Checks on the ASYNCHRONOUS specifier. */ | |
2181 if (open->asynchronous) | |
2182 { | |
2183 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %C " | |
2184 "not allowed in Fortran 95")) | |
2185 goto cleanup; | |
2186 | |
2187 if (!is_char_type ("ASYNCHRONOUS", open->asynchronous)) | |
2188 goto cleanup; | |
2189 | |
2190 if (open->asynchronous->expr_type == EXPR_CONSTANT) | |
2191 { | |
2192 static const char * asynchronous[] = { "YES", "NO", NULL }; | |
2193 | |
2194 if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous, | |
2195 NULL, NULL, open->asynchronous->value.character.string, | |
2196 "OPEN", warn)) | |
2197 goto cleanup; | |
2198 } | |
2199 } | |
2200 | |
2201 /* Checks on the BLANK specifier. */ | |
2202 if (open->blank) | |
2203 { | |
2204 if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C " | |
2205 "not allowed in Fortran 95")) | |
2206 goto cleanup; | |
2207 | |
2208 if (!is_char_type ("BLANK", open->blank)) | |
2209 goto cleanup; | |
2210 | |
2211 if (open->blank->expr_type == EXPR_CONSTANT) | |
2212 { | |
2213 static const char *blank[] = { "ZERO", "NULL", NULL }; | |
2214 | |
2215 if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, | |
2216 open->blank->value.character.string, | |
2217 "OPEN", warn)) | |
2218 goto cleanup; | |
2219 } | |
2220 } | |
2221 | |
2222 /* Checks on the CARRIAGECONTROL specifier. */ | |
2223 if (open->cc) | |
2224 { | |
2225 if (!is_char_type ("CARRIAGECONTROL", open->cc)) | |
2226 goto cleanup; | |
2227 | |
2228 if (open->cc->expr_type == EXPR_CONSTANT) | |
2229 { | |
2230 static const char *cc[] = { "LIST", "FORTRAN", "NONE", NULL }; | |
2231 if (!compare_to_allowed_values ("CARRIAGECONTROL", cc, NULL, NULL, | |
2232 open->cc->value.character.string, | |
2233 "OPEN", warn)) | |
2234 goto cleanup; | |
2235 } | |
2236 } | |
2237 | |
2238 /* Checks on the DECIMAL specifier. */ | |
2239 if (open->decimal) | |
2240 { | |
2241 if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C " | |
2242 "not allowed in Fortran 95")) | |
2243 goto cleanup; | |
2244 | |
2245 if (!is_char_type ("DECIMAL", open->decimal)) | |
2246 goto cleanup; | |
2247 | |
2248 if (open->decimal->expr_type == EXPR_CONSTANT) | |
2249 { | |
2250 static const char * decimal[] = { "COMMA", "POINT", NULL }; | |
2251 | |
2252 if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, | |
2253 open->decimal->value.character.string, | |
2254 "OPEN", warn)) | |
2255 goto cleanup; | |
2256 } | |
2257 } | |
2258 | |
2259 /* Checks on the DELIM specifier. */ | |
2260 if (open->delim) | |
2261 { | |
2262 if (open->delim->expr_type == EXPR_CONSTANT) | |
2263 { | |
2264 static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; | |
2265 | |
2266 if (!is_char_type ("DELIM", open->delim)) | |
2267 goto cleanup; | |
2268 | |
2269 if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, | |
2270 open->delim->value.character.string, | |
2271 "OPEN", warn)) | |
2272 goto cleanup; | |
2273 } | |
2274 } | |
2275 | |
2276 /* Checks on the ENCODING specifier. */ | |
2277 if (open->encoding) | |
2278 { | |
2279 if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %C " | |
2280 "not allowed in Fortran 95")) | |
2281 goto cleanup; | |
2282 | |
2283 if (!is_char_type ("ENCODING", open->encoding)) | |
2284 goto cleanup; | |
2285 | |
2286 if (open->encoding->expr_type == EXPR_CONSTANT) | |
2287 { | |
2288 static const char * encoding[] = { "DEFAULT", "UTF-8", NULL }; | |
2289 | |
2290 if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL, | |
2291 open->encoding->value.character.string, | |
2292 "OPEN", warn)) | |
2293 goto cleanup; | |
2294 } | |
2295 } | |
2296 | |
2297 /* Checks on the FORM specifier. */ | |
2298 if (open->form && open->form->expr_type == EXPR_CONSTANT) | |
2299 { | |
2300 static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL }; | |
2301 | |
2302 if (!is_char_type ("FORM", open->form)) | |
2303 goto cleanup; | |
2304 | |
2305 if (!compare_to_allowed_values ("FORM", form, NULL, NULL, | |
2306 open->form->value.character.string, | |
2307 "OPEN", warn)) | |
2308 goto cleanup; | |
2309 } | |
2310 | |
2311 /* Checks on the PAD specifier. */ | |
2312 if (open->pad && open->pad->expr_type == EXPR_CONSTANT) | |
2313 { | |
2314 static const char *pad[] = { "YES", "NO", NULL }; | |
2315 | |
2316 if (!is_char_type ("PAD", open->pad)) | |
2317 goto cleanup; | |
2318 | |
2319 if (!compare_to_allowed_values ("PAD", pad, NULL, NULL, | |
2320 open->pad->value.character.string, | |
2321 "OPEN", warn)) | |
2322 goto cleanup; | |
2323 } | |
2324 | |
2325 /* Checks on the POSITION specifier. */ | |
2326 if (open->position && open->position->expr_type == EXPR_CONSTANT) | |
2327 { | |
2328 static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL }; | |
2329 | |
2330 if (!is_char_type ("POSITION", open->position)) | |
2331 goto cleanup; | |
2332 | |
2333 if (!compare_to_allowed_values ("POSITION", position, NULL, NULL, | |
2334 open->position->value.character.string, | |
2335 "OPEN", warn)) | |
2336 goto cleanup; | |
2337 } | |
2338 | |
2339 /* Checks on the ROUND specifier. */ | |
2340 if (open->round) | |
2341 { | |
2342 if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C " | |
2343 "not allowed in Fortran 95")) | |
2344 goto cleanup; | |
2345 | |
2346 if (!is_char_type ("ROUND", open->round)) | |
2347 goto cleanup; | |
2348 | |
2349 if (open->round->expr_type == EXPR_CONSTANT) | |
2350 { | |
2351 static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST", | |
2352 "COMPATIBLE", "PROCESSOR_DEFINED", | |
2353 NULL }; | |
2354 | |
2355 if (!compare_to_allowed_values ("ROUND", round, NULL, NULL, | |
2356 open->round->value.character.string, | |
2357 "OPEN", warn)) | |
2358 goto cleanup; | |
2359 } | |
2360 } | |
2361 | |
2362 /* Checks on the SHARE specifier. */ | |
2363 if (open->share) | |
2364 { | |
2365 if (!is_char_type ("SHARE", open->share)) | |
2366 goto cleanup; | |
2367 | |
2368 if (open->share->expr_type == EXPR_CONSTANT) | |
2369 { | |
2370 static const char *share[] = { "DENYNONE", "DENYRW", NULL }; | |
2371 if (!compare_to_allowed_values ("SHARE", share, NULL, NULL, | |
2372 open->share->value.character.string, | |
2373 "OPEN", warn)) | |
2374 goto cleanup; | |
2375 } | |
2376 } | |
2377 | |
2378 /* Checks on the SIGN specifier. */ | |
2379 if (open->sign) | |
2380 { | |
2381 if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %C " | |
2382 "not allowed in Fortran 95")) | |
2383 goto cleanup; | |
2384 | |
2385 if (!is_char_type ("SIGN", open->sign)) | |
2386 goto cleanup; | |
2387 | |
2388 if (open->sign->expr_type == EXPR_CONSTANT) | |
2389 { | |
2390 static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED", | |
2391 NULL }; | |
2392 | |
2393 if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL, | |
2394 open->sign->value.character.string, | |
2395 "OPEN", warn)) | |
2396 goto cleanup; | |
2397 } | |
2398 } | |
2399 | |
2400 #define warn_or_error(...) \ | |
2401 { \ | |
2402 if (warn) \ | |
2403 gfc_warning (0, __VA_ARGS__); \ | |
2404 else \ | |
2405 { \ | |
2406 gfc_error (__VA_ARGS__); \ | |
2407 goto cleanup; \ | |
2408 } \ | |
2409 } | |
2410 | |
2411 /* Checks on the RECL specifier. */ | |
2412 if (open->recl && open->recl->expr_type == EXPR_CONSTANT | |
2413 && open->recl->ts.type == BT_INTEGER | |
2414 && mpz_sgn (open->recl->value.integer) != 1) | |
2415 { | |
2416 warn_or_error ("RECL in OPEN statement at %C must be positive"); | |
2417 } | |
2418 | |
2419 /* Checks on the STATUS specifier. */ | |
2420 if (open->status && open->status->expr_type == EXPR_CONSTANT) | |
2421 { | |
2422 static const char *status[] = { "OLD", "NEW", "SCRATCH", | |
2423 "REPLACE", "UNKNOWN", NULL }; | |
2424 | |
2425 if (!is_char_type ("STATUS", open->status)) | |
2426 goto cleanup; | |
2427 | |
2428 if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, | |
2429 open->status->value.character.string, | |
2430 "OPEN", warn)) | |
2431 goto cleanup; | |
2432 | |
2433 /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE, | |
2434 the FILE= specifier shall appear. */ | |
2435 if (open->file == NULL | |
2436 && (gfc_wide_strncasecmp (open->status->value.character.string, | |
2437 "replace", 7) == 0 | |
2438 || gfc_wide_strncasecmp (open->status->value.character.string, | |
2439 "new", 3) == 0)) | |
2440 { | |
2441 char *s = gfc_widechar_to_char (open->status->value.character.string, | |
2442 -1); | |
2443 warn_or_error ("The STATUS specified in OPEN statement at %C is " | |
2444 "%qs and no FILE specifier is present", s); | |
2445 free (s); | |
2446 } | |
2447 | |
2448 /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH, | |
2449 the FILE= specifier shall not appear. */ | |
2450 if (gfc_wide_strncasecmp (open->status->value.character.string, | |
2451 "scratch", 7) == 0 && open->file) | |
2452 { | |
2453 warn_or_error ("The STATUS specified in OPEN statement at %C " | |
2454 "cannot have the value SCRATCH if a FILE specifier " | |
2455 "is present"); | |
2456 } | |
2457 } | |
2458 | |
2459 /* Things that are not allowed for unformatted I/O. */ | |
2460 if (open->form && open->form->expr_type == EXPR_CONSTANT | |
2461 && (open->delim || open->decimal || open->encoding || open->round | |
2462 || open->sign || open->pad || open->blank) | |
2463 && gfc_wide_strncasecmp (open->form->value.character.string, | |
2464 "unformatted", 11) == 0) | |
2465 { | |
2466 const char *spec = (open->delim ? "DELIM " | |
2467 : (open->pad ? "PAD " : open->blank | |
2468 ? "BLANK " : "")); | |
2469 | |
2470 warn_or_error ("%s specifier at %C not allowed in OPEN statement for " | |
2471 "unformatted I/O", spec); | |
2472 } | |
2473 | |
2474 if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT | |
2475 && gfc_wide_strncasecmp (open->access->value.character.string, | |
2476 "stream", 6) == 0) | |
2477 { | |
2478 warn_or_error ("RECL specifier not allowed in OPEN statement at %C for " | |
2479 "stream I/O"); | |
2480 } | |
2481 | |
2482 if (open->position | |
2483 && open->access && open->access->expr_type == EXPR_CONSTANT | |
2484 && !(gfc_wide_strncasecmp (open->access->value.character.string, | |
2485 "sequential", 10) == 0 | |
2486 || gfc_wide_strncasecmp (open->access->value.character.string, | |
2487 "stream", 6) == 0 | |
2488 || gfc_wide_strncasecmp (open->access->value.character.string, | |
2489 "append", 6) == 0)) | |
2490 { | |
2491 warn_or_error ("POSITION specifier in OPEN statement at %C only allowed " | |
2492 "for stream or sequential ACCESS"); | |
2493 } | |
2494 | |
2495 #undef warn_or_error | |
2496 | |
2497 new_st.op = EXEC_OPEN; | |
2498 new_st.ext.open = open; | |
2499 return MATCH_YES; | |
2500 | |
2501 syntax: | |
2502 gfc_syntax_error (ST_OPEN); | |
2503 | |
2504 cleanup: | |
2505 gfc_free_open (open); | |
2506 return MATCH_ERROR; | |
2507 } | |
2508 | |
2509 | |
2510 /* Free a gfc_close structure an all its expressions. */ | |
2511 | |
2512 void | |
2513 gfc_free_close (gfc_close *close) | |
2514 { | |
2515 if (close == NULL) | |
2516 return; | |
2517 | |
2518 gfc_free_expr (close->unit); | |
2519 gfc_free_expr (close->iomsg); | |
2520 gfc_free_expr (close->iostat); | |
2521 gfc_free_expr (close->status); | |
2522 free (close); | |
2523 } | |
2524 | |
2525 | |
2526 /* Match elements of a CLOSE statement. */ | |
2527 | |
2528 static match | |
2529 match_close_element (gfc_close *close) | |
2530 { | |
2531 match m; | |
2532 | |
2533 m = match_etag (&tag_unit, &close->unit); | |
2534 if (m != MATCH_NO) | |
2535 return m; | |
2536 m = match_etag (&tag_status, &close->status); | |
2537 if (m != MATCH_NO) | |
2538 return m; | |
2539 m = match_etag (&tag_iomsg, &close->iomsg); | |
2540 if (m == MATCH_YES && !check_char_variable (close->iomsg)) | |
2541 return MATCH_ERROR; | |
2542 if (m != MATCH_NO) | |
2543 return m; | |
2544 m = match_out_tag (&tag_iostat, &close->iostat); | |
2545 if (m != MATCH_NO) | |
2546 return m; | |
2547 m = match_ltag (&tag_err, &close->err); | |
2548 if (m != MATCH_NO) | |
2549 return m; | |
2550 | |
2551 return MATCH_NO; | |
2552 } | |
2553 | |
2554 | |
2555 /* Match a CLOSE statement. */ | |
2556 | |
2557 match | |
2558 gfc_match_close (void) | |
2559 { | |
2560 gfc_close *close; | |
2561 match m; | |
2562 bool warn; | |
2563 | |
2564 m = gfc_match_char ('('); | |
2565 if (m == MATCH_NO) | |
2566 return m; | |
2567 | |
2568 close = XCNEW (gfc_close); | |
2569 | |
2570 m = match_close_element (close); | |
2571 | |
2572 if (m == MATCH_ERROR) | |
2573 goto cleanup; | |
2574 if (m == MATCH_NO) | |
2575 { | |
2576 m = gfc_match_expr (&close->unit); | |
2577 if (m == MATCH_NO) | |
2578 goto syntax; | |
2579 if (m == MATCH_ERROR) | |
2580 goto cleanup; | |
2581 } | |
2582 | |
2583 for (;;) | |
2584 { | |
2585 if (gfc_match_char (')') == MATCH_YES) | |
2586 break; | |
2587 if (gfc_match_char (',') != MATCH_YES) | |
2588 goto syntax; | |
2589 | |
2590 m = match_close_element (close); | |
2591 if (m == MATCH_ERROR) | |
2592 goto cleanup; | |
2593 if (m == MATCH_NO) | |
2594 goto syntax; | |
2595 } | |
2596 | |
2597 if (gfc_match_eos () == MATCH_NO) | |
2598 goto syntax; | |
2599 | |
2600 if (gfc_pure (NULL)) | |
2601 { | |
2602 gfc_error ("CLOSE statement not allowed in PURE procedure at %C"); | |
2603 goto cleanup; | |
2604 } | |
2605 | |
2606 gfc_unset_implicit_pure (NULL); | |
2607 | |
2608 warn = (close->iostat || close->err) ? true : false; | |
2609 | |
2610 /* Checks on the STATUS specifier. */ | |
2611 if (close->status && close->status->expr_type == EXPR_CONSTANT) | |
2612 { | |
2613 static const char *status[] = { "KEEP", "DELETE", NULL }; | |
2614 | |
2615 if (!is_char_type ("STATUS", close->status)) | |
2616 goto cleanup; | |
2617 | |
2618 if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, | |
2619 close->status->value.character.string, | |
2620 "CLOSE", warn)) | |
2621 goto cleanup; | |
2622 } | |
2623 | |
2624 new_st.op = EXEC_CLOSE; | |
2625 new_st.ext.close = close; | |
2626 return MATCH_YES; | |
2627 | |
2628 syntax: | |
2629 gfc_syntax_error (ST_CLOSE); | |
2630 | |
2631 cleanup: | |
2632 gfc_free_close (close); | |
2633 return MATCH_ERROR; | |
2634 } | |
2635 | |
2636 | |
2637 /* Resolve everything in a gfc_close structure. */ | |
2638 | |
2639 bool | |
2640 gfc_resolve_close (gfc_close *close) | |
2641 { | |
2642 RESOLVE_TAG (&tag_unit, close->unit); | |
2643 RESOLVE_TAG (&tag_iomsg, close->iomsg); | |
2644 RESOLVE_TAG (&tag_iostat, close->iostat); | |
2645 RESOLVE_TAG (&tag_status, close->status); | |
2646 | |
2647 if (!gfc_reference_st_label (close->err, ST_LABEL_TARGET)) | |
2648 return false; | |
2649 | |
2650 if (close->unit == NULL) | |
2651 { | |
2652 /* Find a locus from one of the arguments to close, when UNIT is | |
2653 not specified. */ | |
2654 locus loc = gfc_current_locus; | |
2655 if (close->status) | |
2656 loc = close->status->where; | |
2657 else if (close->iostat) | |
2658 loc = close->iostat->where; | |
2659 else if (close->iomsg) | |
2660 loc = close->iomsg->where; | |
2661 else if (close->err) | |
2662 loc = close->err->where; | |
2663 | |
2664 gfc_error ("CLOSE statement at %L requires a UNIT number", &loc); | |
2665 return false; | |
2666 } | |
2667 | |
2668 if (close->unit->expr_type == EXPR_CONSTANT | |
2669 && close->unit->ts.type == BT_INTEGER | |
2670 && mpz_sgn (close->unit->value.integer) < 0) | |
2671 { | |
2672 gfc_error ("UNIT number in CLOSE statement at %L must be non-negative", | |
2673 &close->unit->where); | |
2674 } | |
2675 | |
2676 return true; | |
2677 } | |
2678 | |
2679 | |
2680 /* Free a gfc_filepos structure. */ | |
2681 | |
2682 void | |
2683 gfc_free_filepos (gfc_filepos *fp) | |
2684 { | |
2685 gfc_free_expr (fp->unit); | |
2686 gfc_free_expr (fp->iomsg); | |
2687 gfc_free_expr (fp->iostat); | |
2688 free (fp); | |
2689 } | |
2690 | |
2691 | |
2692 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */ | |
2693 | |
2694 static match | |
2695 match_file_element (gfc_filepos *fp) | |
2696 { | |
2697 match m; | |
2698 | |
2699 m = match_etag (&tag_unit, &fp->unit); | |
2700 if (m != MATCH_NO) | |
2701 return m; | |
2702 m = match_etag (&tag_iomsg, &fp->iomsg); | |
2703 if (m == MATCH_YES && !check_char_variable (fp->iomsg)) | |
2704 return MATCH_ERROR; | |
2705 if (m != MATCH_NO) | |
2706 return m; | |
2707 m = match_out_tag (&tag_iostat, &fp->iostat); | |
2708 if (m != MATCH_NO) | |
2709 return m; | |
2710 m = match_ltag (&tag_err, &fp->err); | |
2711 if (m != MATCH_NO) | |
2712 return m; | |
2713 | |
2714 return MATCH_NO; | |
2715 } | |
2716 | |
2717 | |
2718 /* Match the second half of the file-positioning statements, REWIND, | |
2719 BACKSPACE, ENDFILE, or the FLUSH statement. */ | |
2720 | |
2721 static match | |
2722 match_filepos (gfc_statement st, gfc_exec_op op) | |
2723 { | |
2724 gfc_filepos *fp; | |
2725 match m; | |
2726 | |
2727 fp = XCNEW (gfc_filepos); | |
2728 | |
2729 if (gfc_match_char ('(') == MATCH_NO) | |
2730 { | |
2731 m = gfc_match_expr (&fp->unit); | |
2732 if (m == MATCH_ERROR) | |
2733 goto cleanup; | |
2734 if (m == MATCH_NO) | |
2735 goto syntax; | |
2736 | |
2737 goto done; | |
2738 } | |
2739 | |
2740 m = match_file_element (fp); | |
2741 if (m == MATCH_ERROR) | |
2742 goto done; | |
2743 if (m == MATCH_NO) | |
2744 { | |
2745 m = gfc_match_expr (&fp->unit); | |
2746 if (m == MATCH_ERROR || m == MATCH_NO) | |
2747 goto syntax; | |
2748 } | |
2749 | |
2750 for (;;) | |
2751 { | |
2752 if (gfc_match_char (')') == MATCH_YES) | |
2753 break; | |
2754 if (gfc_match_char (',') != MATCH_YES) | |
2755 goto syntax; | |
2756 | |
2757 m = match_file_element (fp); | |
2758 if (m == MATCH_ERROR) | |
2759 goto cleanup; | |
2760 if (m == MATCH_NO) | |
2761 goto syntax; | |
2762 } | |
2763 | |
2764 done: | |
2765 if (gfc_match_eos () != MATCH_YES) | |
2766 goto syntax; | |
2767 | |
2768 if (gfc_pure (NULL)) | |
2769 { | |
2770 gfc_error ("%s statement not allowed in PURE procedure at %C", | |
2771 gfc_ascii_statement (st)); | |
2772 | |
2773 goto cleanup; | |
2774 } | |
2775 | |
2776 gfc_unset_implicit_pure (NULL); | |
2777 | |
2778 new_st.op = op; | |
2779 new_st.ext.filepos = fp; | |
2780 return MATCH_YES; | |
2781 | |
2782 syntax: | |
2783 gfc_syntax_error (st); | |
2784 | |
2785 cleanup: | |
2786 gfc_free_filepos (fp); | |
2787 return MATCH_ERROR; | |
2788 } | |
2789 | |
2790 | |
2791 bool | |
2792 gfc_resolve_filepos (gfc_filepos *fp) | |
2793 { | |
2794 RESOLVE_TAG (&tag_unit, fp->unit); | |
2795 RESOLVE_TAG (&tag_iostat, fp->iostat); | |
2796 RESOLVE_TAG (&tag_iomsg, fp->iomsg); | |
2797 if (!gfc_reference_st_label (fp->err, ST_LABEL_TARGET)) | |
2798 return false; | |
2799 | |
2800 if (!fp->unit && (fp->iostat || fp->iomsg)) | |
2801 { | |
2802 locus where; | |
2803 where = fp->iostat ? fp->iostat->where : fp->iomsg->where; | |
2804 gfc_error ("UNIT number missing in statement at %L", &where); | |
2805 return false; | |
2806 } | |
2807 | |
2808 if (fp->unit->expr_type == EXPR_CONSTANT | |
2809 && fp->unit->ts.type == BT_INTEGER | |
2810 && mpz_sgn (fp->unit->value.integer) < 0) | |
2811 { | |
2812 gfc_error ("UNIT number in statement at %L must be non-negative", | |
2813 &fp->unit->where); | |
2814 return false; | |
2815 } | |
2816 | |
2817 return true; | |
2818 } | |
2819 | |
2820 | |
2821 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND, | |
2822 and the FLUSH statement. */ | |
2823 | |
2824 match | |
2825 gfc_match_endfile (void) | |
2826 { | |
2827 return match_filepos (ST_END_FILE, EXEC_ENDFILE); | |
2828 } | |
2829 | |
2830 match | |
2831 gfc_match_backspace (void) | |
2832 { | |
2833 return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE); | |
2834 } | |
2835 | |
2836 match | |
2837 gfc_match_rewind (void) | |
2838 { | |
2839 return match_filepos (ST_REWIND, EXEC_REWIND); | |
2840 } | |
2841 | |
2842 match | |
2843 gfc_match_flush (void) | |
2844 { | |
2845 if (!gfc_notify_std (GFC_STD_F2003, "FLUSH statement at %C")) | |
2846 return MATCH_ERROR; | |
2847 | |
2848 return match_filepos (ST_FLUSH, EXEC_FLUSH); | |
2849 } | |
2850 | |
2851 /******************** Data Transfer Statements *********************/ | |
2852 | |
2853 /* Return a default unit number. */ | |
2854 | |
2855 static gfc_expr * | |
2856 default_unit (io_kind k) | |
2857 { | |
2858 int unit; | |
2859 | |
2860 if (k == M_READ) | |
2861 unit = 5; | |
2862 else | |
2863 unit = 6; | |
2864 | |
2865 return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit); | |
2866 } | |
2867 | |
2868 | |
2869 /* Match a unit specification for a data transfer statement. */ | |
2870 | |
2871 static match | |
2872 match_dt_unit (io_kind k, gfc_dt *dt) | |
2873 { | |
2874 gfc_expr *e; | |
2875 char c; | |
2876 | |
2877 if (gfc_match_char ('*') == MATCH_YES) | |
2878 { | |
2879 if (dt->io_unit != NULL) | |
2880 goto conflict; | |
2881 | |
2882 dt->io_unit = default_unit (k); | |
2883 | |
2884 c = gfc_peek_ascii_char (); | |
2885 if (c == ')') | |
2886 gfc_error_now ("Missing format with default unit at %C"); | |
2887 | |
2888 return MATCH_YES; | |
2889 } | |
2890 | |
2891 if (gfc_match_expr (&e) == MATCH_YES) | |
2892 { | |
2893 if (dt->io_unit != NULL) | |
2894 { | |
2895 gfc_free_expr (e); | |
2896 goto conflict; | |
2897 } | |
2898 | |
2899 dt->io_unit = e; | |
2900 return MATCH_YES; | |
2901 } | |
2902 | |
2903 return MATCH_NO; | |
2904 | |
2905 conflict: | |
2906 gfc_error ("Duplicate UNIT specification at %C"); | |
2907 return MATCH_ERROR; | |
2908 } | |
2909 | |
2910 | |
2911 /* Match a format specification. */ | |
2912 | |
2913 static match | |
2914 match_dt_format (gfc_dt *dt) | |
2915 { | |
2916 locus where; | |
2917 gfc_expr *e; | |
2918 gfc_st_label *label; | |
2919 match m; | |
2920 | |
2921 where = gfc_current_locus; | |
2922 | |
2923 if (gfc_match_char ('*') == MATCH_YES) | |
2924 { | |
2925 if (dt->format_expr != NULL || dt->format_label != NULL) | |
2926 goto conflict; | |
2927 | |
2928 dt->format_label = &format_asterisk; | |
2929 return MATCH_YES; | |
2930 } | |
2931 | |
2932 if ((m = gfc_match_st_label (&label)) == MATCH_YES) | |
2933 { | |
2934 char c; | |
2935 | |
2936 /* Need to check if the format label is actually either an operand | |
2937 to a user-defined operator or is a kind type parameter. That is, | |
2938 print 2.ip.8 ! .ip. is a user-defined operator return CHARACTER. | |
2939 print 1_'(I0)', i ! 1_'(I0)' is a default character string. */ | |
2940 | |
2941 gfc_gobble_whitespace (); | |
2942 c = gfc_peek_ascii_char (); | |
2943 if (c == '.' || c == '_') | |
2944 gfc_current_locus = where; | |
2945 else | |
2946 { | |
2947 if (dt->format_expr != NULL || dt->format_label != NULL) | |
2948 { | |
2949 gfc_free_st_label (label); | |
2950 goto conflict; | |
2951 } | |
2952 | |
2953 if (!gfc_reference_st_label (label, ST_LABEL_FORMAT)) | |
2954 return MATCH_ERROR; | |
2955 | |
2956 dt->format_label = label; | |
2957 return MATCH_YES; | |
2958 } | |
2959 } | |
2960 else if (m == MATCH_ERROR) | |
2961 /* The label was zero or too large. Emit the correct diagnosis. */ | |
2962 return MATCH_ERROR; | |
2963 | |
2964 if (gfc_match_expr (&e) == MATCH_YES) | |
2965 { | |
2966 if (dt->format_expr != NULL || dt->format_label != NULL) | |
2967 { | |
2968 gfc_free_expr (e); | |
2969 goto conflict; | |
2970 } | |
2971 dt->format_expr = e; | |
2972 return MATCH_YES; | |
2973 } | |
2974 | |
2975 gfc_current_locus = where; /* The only case where we have to restore */ | |
2976 | |
2977 return MATCH_NO; | |
2978 | |
2979 conflict: | |
2980 gfc_error ("Duplicate format specification at %C"); | |
2981 return MATCH_ERROR; | |
2982 } | |
2983 | |
2984 /* Check for formatted read and write DTIO procedures. */ | |
2985 | |
2986 static bool | |
2987 dtio_procs_present (gfc_symbol *sym, io_kind k) | |
2988 { | |
2989 gfc_symbol *derived; | |
2990 | |
2991 if (sym && sym->ts.u.derived) | |
2992 { | |
2993 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) | |
2994 derived = CLASS_DATA (sym)->ts.u.derived; | |
2995 else if (sym->ts.type == BT_DERIVED) | |
2996 derived = sym->ts.u.derived; | |
2997 else | |
2998 return false; | |
2999 if ((k == M_WRITE || k == M_PRINT) && | |
3000 (gfc_find_specific_dtio_proc (derived, true, true) != NULL)) | |
3001 return true; | |
3002 if ((k == M_READ) && | |
3003 (gfc_find_specific_dtio_proc (derived, false, true) != NULL)) | |
3004 return true; | |
3005 } | |
3006 return false; | |
3007 } | |
3008 | |
3009 /* Traverse a namelist that is part of a READ statement to make sure | |
3010 that none of the variables in the namelist are INTENT(IN). Returns | |
3011 nonzero if we find such a variable. */ | |
3012 | |
3013 static int | |
3014 check_namelist (gfc_symbol *sym) | |
3015 { | |
3016 gfc_namelist *p; | |
3017 | |
3018 for (p = sym->namelist; p; p = p->next) | |
3019 if (p->sym->attr.intent == INTENT_IN) | |
3020 { | |
3021 gfc_error ("Symbol %qs in namelist %qs is INTENT(IN) at %C", | |
3022 p->sym->name, sym->name); | |
3023 return 1; | |
3024 } | |
3025 | |
3026 return 0; | |
3027 } | |
3028 | |
3029 | |
3030 /* Match a single data transfer element. */ | |
3031 | |
3032 static match | |
3033 match_dt_element (io_kind k, gfc_dt *dt) | |
3034 { | |
3035 char name[GFC_MAX_SYMBOL_LEN + 1]; | |
3036 gfc_symbol *sym; | |
3037 match m; | |
3038 | |
3039 if (gfc_match (" unit =") == MATCH_YES) | |
3040 { | |
3041 m = match_dt_unit (k, dt); | |
3042 if (m != MATCH_NO) | |
3043 return m; | |
3044 } | |
3045 | |
3046 if (gfc_match (" fmt =") == MATCH_YES) | |
3047 { | |
3048 m = match_dt_format (dt); | |
3049 if (m != MATCH_NO) | |
3050 return m; | |
3051 } | |
3052 | |
3053 if (gfc_match (" nml = %n", name) == MATCH_YES) | |
3054 { | |
3055 if (dt->namelist != NULL) | |
3056 { | |
3057 gfc_error ("Duplicate NML specification at %C"); | |
3058 return MATCH_ERROR; | |
3059 } | |
3060 | |
3061 if (gfc_find_symbol (name, NULL, 1, &sym)) | |
3062 return MATCH_ERROR; | |
3063 | |
3064 if (sym == NULL || sym->attr.flavor != FL_NAMELIST) | |
3065 { | |
3066 gfc_error ("Symbol %qs at %C must be a NAMELIST group name", | |
3067 sym != NULL ? sym->name : name); | |
3068 return MATCH_ERROR; | |
3069 } | |
3070 | |
3071 dt->namelist = sym; | |
3072 if (k == M_READ && check_namelist (sym)) | |
3073 return MATCH_ERROR; | |
3074 | |
3075 return MATCH_YES; | |
3076 } | |
3077 | |
3078 m = match_etag (&tag_e_async, &dt->asynchronous); | |
3079 if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", dt->asynchronous)) | |
3080 return MATCH_ERROR; | |
3081 if (m != MATCH_NO) | |
3082 return m; | |
3083 m = match_etag (&tag_e_blank, &dt->blank); | |
3084 if (m != MATCH_NO) | |
3085 return m; | |
3086 m = match_etag (&tag_e_delim, &dt->delim); | |
3087 if (m != MATCH_NO) | |
3088 return m; | |
3089 m = match_etag (&tag_e_pad, &dt->pad); | |
3090 if (m != MATCH_NO) | |
3091 return m; | |
3092 m = match_etag (&tag_e_sign, &dt->sign); | |
3093 if (m != MATCH_NO) | |
3094 return m; | |
3095 m = match_etag (&tag_e_round, &dt->round); | |
3096 if (m != MATCH_NO) | |
3097 return m; | |
3098 m = match_out_tag (&tag_id, &dt->id); | |
3099 if (m != MATCH_NO) | |
3100 return m; | |
3101 m = match_etag (&tag_e_decimal, &dt->decimal); | |
3102 if (m != MATCH_NO) | |
3103 return m; | |
3104 m = match_etag (&tag_rec, &dt->rec); | |
3105 if (m != MATCH_NO) | |
3106 return m; | |
3107 m = match_etag (&tag_spos, &dt->pos); | |
3108 if (m != MATCH_NO) | |
3109 return m; | |
3110 m = match_etag (&tag_iomsg, &dt->iomsg); | |
3111 if (m == MATCH_YES && !check_char_variable (dt->iomsg)) | |
3112 return MATCH_ERROR; | |
3113 if (m != MATCH_NO) | |
3114 return m; | |
3115 | |
3116 m = match_out_tag (&tag_iostat, &dt->iostat); | |
3117 if (m != MATCH_NO) | |
3118 return m; | |
3119 m = match_ltag (&tag_err, &dt->err); | |
3120 if (m == MATCH_YES) | |
3121 dt->err_where = gfc_current_locus; | |
3122 if (m != MATCH_NO) | |
3123 return m; | |
3124 m = match_etag (&tag_advance, &dt->advance); | |
3125 if (m != MATCH_NO) | |
3126 return m; | |
3127 m = match_out_tag (&tag_size, &dt->size); | |
3128 if (m != MATCH_NO) | |
3129 return m; | |
3130 | |
3131 m = match_ltag (&tag_end, &dt->end); | |
3132 if (m == MATCH_YES) | |
3133 { | |
3134 if (k == M_WRITE) | |
3135 { | |
3136 gfc_error ("END tag at %C not allowed in output statement"); | |
3137 return MATCH_ERROR; | |
3138 } | |
3139 dt->end_where = gfc_current_locus; | |
3140 } | |
3141 if (m != MATCH_NO) | |
3142 return m; | |
3143 | |
3144 m = match_ltag (&tag_eor, &dt->eor); | |
3145 if (m == MATCH_YES) | |
3146 dt->eor_where = gfc_current_locus; | |
3147 if (m != MATCH_NO) | |
3148 return m; | |
3149 | |
3150 return MATCH_NO; | |
3151 } | |
3152 | |
3153 | |
3154 /* Free a data transfer structure and everything below it. */ | |
3155 | |
3156 void | |
3157 gfc_free_dt (gfc_dt *dt) | |
3158 { | |
3159 if (dt == NULL) | |
3160 return; | |
3161 | |
3162 gfc_free_expr (dt->io_unit); | |
3163 gfc_free_expr (dt->format_expr); | |
3164 gfc_free_expr (dt->rec); | |
3165 gfc_free_expr (dt->advance); | |
3166 gfc_free_expr (dt->iomsg); | |
3167 gfc_free_expr (dt->iostat); | |
3168 gfc_free_expr (dt->size); | |
3169 gfc_free_expr (dt->pad); | |
3170 gfc_free_expr (dt->delim); | |
3171 gfc_free_expr (dt->sign); | |
3172 gfc_free_expr (dt->round); | |
3173 gfc_free_expr (dt->blank); | |
3174 gfc_free_expr (dt->decimal); | |
3175 gfc_free_expr (dt->pos); | |
3176 gfc_free_expr (dt->dt_io_kind); | |
3177 /* dt->extra_comma is a link to dt_io_kind if it is set. */ | |
3178 free (dt); | |
3179 } | |
3180 | |
3181 | |
3182 /* Resolve everything in a gfc_dt structure. */ | |
3183 | |
3184 bool | |
3185 gfc_resolve_dt (gfc_dt *dt, locus *loc) | |
3186 { | |
3187 gfc_expr *e; | |
3188 io_kind k; | |
3189 | |
3190 /* This is set in any case. */ | |
3191 gcc_assert (dt->dt_io_kind); | |
3192 k = dt->dt_io_kind->value.iokind; | |
3193 | |
3194 RESOLVE_TAG (&tag_format, dt->format_expr); | |
3195 RESOLVE_TAG (&tag_rec, dt->rec); | |
3196 RESOLVE_TAG (&tag_spos, dt->pos); | |
3197 RESOLVE_TAG (&tag_advance, dt->advance); | |
3198 RESOLVE_TAG (&tag_id, dt->id); | |
3199 RESOLVE_TAG (&tag_iomsg, dt->iomsg); | |
3200 RESOLVE_TAG (&tag_iostat, dt->iostat); | |
3201 RESOLVE_TAG (&tag_size, dt->size); | |
3202 RESOLVE_TAG (&tag_e_pad, dt->pad); | |
3203 RESOLVE_TAG (&tag_e_delim, dt->delim); | |
3204 RESOLVE_TAG (&tag_e_sign, dt->sign); | |
3205 RESOLVE_TAG (&tag_e_round, dt->round); | |
3206 RESOLVE_TAG (&tag_e_blank, dt->blank); | |
3207 RESOLVE_TAG (&tag_e_decimal, dt->decimal); | |
3208 RESOLVE_TAG (&tag_e_async, dt->asynchronous); | |
3209 | |
3210 e = dt->io_unit; | |
3211 if (e == NULL) | |
3212 { | |
3213 gfc_error ("UNIT not specified at %L", loc); | |
3214 return false; | |
3215 } | |
3216 | |
3217 if (gfc_resolve_expr (e) | |
3218 && (e->ts.type != BT_INTEGER | |
3219 && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE))) | |
3220 { | |
3221 /* If there is no extra comma signifying the "format" form of the IO | |
3222 statement, then this must be an error. */ | |
3223 if (!dt->extra_comma) | |
3224 { | |
3225 gfc_error ("UNIT specification at %L must be an INTEGER expression " | |
3226 "or a CHARACTER variable", &e->where); | |
3227 return false; | |
3228 } | |
3229 else | |
3230 { | |
3231 /* At this point, we have an extra comma. If io_unit has arrived as | |
3232 type character, we assume its really the "format" form of the I/O | |
3233 statement. We set the io_unit to the default unit and format to | |
3234 the character expression. See F95 Standard section 9.4. */ | |
3235 if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT)) | |
3236 { | |
3237 dt->format_expr = dt->io_unit; | |
3238 dt->io_unit = default_unit (k); | |
3239 | |
3240 /* Nullify this pointer now so that a warning/error is not | |
3241 triggered below for the "Extension". */ | |
3242 dt->extra_comma = NULL; | |
3243 } | |
3244 | |
3245 if (k == M_WRITE) | |
3246 { | |
3247 gfc_error ("Invalid form of WRITE statement at %L, UNIT required", | |
3248 &dt->extra_comma->where); | |
3249 return false; | |
3250 } | |
3251 } | |
3252 } | |
3253 | |
3254 if (e->ts.type == BT_CHARACTER) | |
3255 { | |
3256 if (gfc_has_vector_index (e)) | |
3257 { | |
3258 gfc_error ("Internal unit with vector subscript at %L", &e->where); | |
3259 return false; | |
3260 } | |
3261 | |
3262 /* If we are writing, make sure the internal unit can be changed. */ | |
3263 gcc_assert (k != M_PRINT); | |
3264 if (k == M_WRITE | |
3265 && !gfc_check_vardef_context (e, false, false, false, | |
3266 _("internal unit in WRITE"))) | |
3267 return false; | |
3268 } | |
3269 | |
3270 if (e->rank && e->ts.type != BT_CHARACTER) | |
3271 { | |
3272 gfc_error ("External IO UNIT cannot be an array at %L", &e->where); | |
3273 return false; | |
3274 } | |
3275 | |
3276 if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER | |
3277 && mpz_sgn (e->value.integer) < 0) | |
3278 { | |
3279 gfc_error ("UNIT number in statement at %L must be non-negative", | |
3280 &e->where); | |
3281 return false; | |
3282 } | |
3283 | |
3284 /* If we are reading and have a namelist, check that all namelist symbols | |
3285 can appear in a variable definition context. */ | |
3286 if (dt->namelist) | |
3287 { | |
3288 gfc_namelist* n; | |
3289 for (n = dt->namelist->namelist; n; n = n->next) | |
3290 { | |
3291 gfc_expr* e; | |
3292 bool t; | |
3293 | |
3294 if (k == M_READ) | |
3295 { | |
3296 e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym)); | |
3297 t = gfc_check_vardef_context (e, false, false, false, NULL); | |
3298 gfc_free_expr (e); | |
3299 | |
3300 if (!t) | |
3301 { | |
3302 gfc_error ("NAMELIST %qs in READ statement at %L contains" | |
3303 " the symbol %qs which may not appear in a" | |
3304 " variable definition context", | |
3305 dt->namelist->name, loc, n->sym->name); | |
3306 return false; | |
3307 } | |
3308 } | |
3309 | |
3310 t = dtio_procs_present (n->sym, k); | |
3311 | |
3312 if (n->sym->ts.type == BT_CLASS && !t) | |
3313 { | |
3314 gfc_error ("NAMELIST object %qs in namelist %qs at %L is " | |
3315 "polymorphic and requires a defined input/output " | |
3316 "procedure", n->sym->name, dt->namelist->name, loc); | |
3317 return false; | |
3318 } | |
3319 | |
3320 if ((n->sym->ts.type == BT_DERIVED) | |
3321 && (n->sym->ts.u.derived->attr.alloc_comp | |
3322 || n->sym->ts.u.derived->attr.pointer_comp)) | |
3323 { | |
3324 if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in " | |
3325 "namelist %qs at %L with ALLOCATABLE " | |
3326 "or POINTER components", n->sym->name, | |
3327 dt->namelist->name, loc)) | |
3328 return false; | |
3329 | |
3330 if (!t) | |
3331 { | |
3332 gfc_error ("NAMELIST object %qs in namelist %qs at %L has " | |
3333 "ALLOCATABLE or POINTER components and thus requires " | |
3334 "a defined input/output procedure", n->sym->name, | |
3335 dt->namelist->name, loc); | |
3336 return false; | |
3337 } | |
3338 } | |
3339 } | |
3340 } | |
3341 | |
3342 if (dt->extra_comma | |
3343 && !gfc_notify_std (GFC_STD_LEGACY, "Comma before i/o item list at %L", | |
3344 &dt->extra_comma->where)) | |
3345 return false; | |
3346 | |
3347 if (dt->err) | |
3348 { | |
3349 if (!gfc_reference_st_label (dt->err, ST_LABEL_TARGET)) | |
3350 return false; | |
3351 if (dt->err->defined == ST_LABEL_UNKNOWN) | |
3352 { | |
3353 gfc_error ("ERR tag label %d at %L not defined", | |
3354 dt->err->value, &dt->err_where); | |
3355 return false; | |
3356 } | |
3357 } | |
3358 | |
3359 if (dt->end) | |
3360 { | |
3361 if (!gfc_reference_st_label (dt->end, ST_LABEL_TARGET)) | |
3362 return false; | |
3363 if (dt->end->defined == ST_LABEL_UNKNOWN) | |
3364 { | |
3365 gfc_error ("END tag label %d at %L not defined", | |
3366 dt->end->value, &dt->end_where); | |
3367 return false; | |
3368 } | |
3369 } | |
3370 | |
3371 if (dt->eor) | |
3372 { | |
3373 if (!gfc_reference_st_label (dt->eor, ST_LABEL_TARGET)) | |
3374 return false; | |
3375 if (dt->eor->defined == ST_LABEL_UNKNOWN) | |
3376 { | |
3377 gfc_error ("EOR tag label %d at %L not defined", | |
3378 dt->eor->value, &dt->eor_where); | |
3379 return false; | |
3380 } | |
3381 } | |
3382 | |
3383 /* Check the format label actually exists. */ | |
3384 if (dt->format_label && dt->format_label != &format_asterisk | |
3385 && dt->format_label->defined == ST_LABEL_UNKNOWN) | |
3386 { | |
3387 gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value, | |
3388 loc); | |
3389 return false; | |
3390 } | |
3391 | |
3392 return true; | |
3393 } | |
3394 | |
3395 | |
3396 /* Given an io_kind, return its name. */ | |
3397 | |
3398 static const char * | |
3399 io_kind_name (io_kind k) | |
3400 { | |
3401 const char *name; | |
3402 | |
3403 switch (k) | |
3404 { | |
3405 case M_READ: | |
3406 name = "READ"; | |
3407 break; | |
3408 case M_WRITE: | |
3409 name = "WRITE"; | |
3410 break; | |
3411 case M_PRINT: | |
3412 name = "PRINT"; | |
3413 break; | |
3414 case M_INQUIRE: | |
3415 name = "INQUIRE"; | |
3416 break; | |
3417 default: | |
3418 gfc_internal_error ("io_kind_name(): bad I/O-kind"); | |
3419 } | |
3420 | |
3421 return name; | |
3422 } | |
3423 | |
3424 | |
3425 /* Match an IO iteration statement of the form: | |
3426 | |
3427 ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] ) | |
3428 | |
3429 which is equivalent to a single IO element. This function is | |
3430 mutually recursive with match_io_element(). */ | |
3431 | |
3432 static match match_io_element (io_kind, gfc_code **); | |
3433 | |
3434 static match | |
3435 match_io_iterator (io_kind k, gfc_code **result) | |
3436 { | |
3437 gfc_code *head, *tail, *new_code; | |
3438 gfc_iterator *iter; | |
3439 locus old_loc; | |
3440 match m; | |
3441 int n; | |
3442 | |
3443 iter = NULL; | |
3444 head = NULL; | |
3445 old_loc = gfc_current_locus; | |
3446 | |
3447 if (gfc_match_char ('(') != MATCH_YES) | |
3448 return MATCH_NO; | |
3449 | |
3450 m = match_io_element (k, &head); | |
3451 tail = head; | |
3452 | |
3453 if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES) | |
3454 { | |
3455 m = MATCH_NO; | |
3456 goto cleanup; | |
3457 } | |
3458 | |
3459 /* Can't be anything but an IO iterator. Build a list. */ | |
3460 iter = gfc_get_iterator (); | |
3461 | |
3462 for (n = 1;; n++) | |
3463 { | |
3464 m = gfc_match_iterator (iter, 0); | |
3465 if (m == MATCH_ERROR) | |
3466 goto cleanup; | |
3467 if (m == MATCH_YES) | |
3468 { | |
3469 gfc_check_do_variable (iter->var->symtree); | |
3470 break; | |
3471 } | |
3472 | |
3473 m = match_io_element (k, &new_code); | |
3474 if (m == MATCH_ERROR) | |
3475 goto cleanup; | |
3476 if (m == MATCH_NO) | |
3477 { | |
3478 if (n > 2) | |
3479 goto syntax; | |
3480 goto cleanup; | |
3481 } | |
3482 | |
3483 tail = gfc_append_code (tail, new_code); | |
3484 | |
3485 if (gfc_match_char (',') != MATCH_YES) | |
3486 { | |
3487 if (n > 2) | |
3488 goto syntax; | |
3489 m = MATCH_NO; | |
3490 goto cleanup; | |
3491 } | |
3492 } | |
3493 | |
3494 if (gfc_match_char (')') != MATCH_YES) | |
3495 goto syntax; | |
3496 | |
3497 new_code = gfc_get_code (EXEC_DO); | |
3498 new_code->ext.iterator = iter; | |
3499 | |
3500 new_code->block = gfc_get_code (EXEC_DO); | |
3501 new_code->block->next = head; | |
3502 | |
3503 *result = new_code; | |
3504 return MATCH_YES; | |
3505 | |
3506 syntax: | |
3507 gfc_error ("Syntax error in I/O iterator at %C"); | |
3508 m = MATCH_ERROR; | |
3509 | |
3510 cleanup: | |
3511 gfc_free_iterator (iter, 1); | |
3512 gfc_free_statements (head); | |
3513 gfc_current_locus = old_loc; | |
3514 return m; | |
3515 } | |
3516 | |
3517 | |
3518 /* Match a single element of an IO list, which is either a single | |
3519 expression or an IO Iterator. */ | |
3520 | |
3521 static match | |
3522 match_io_element (io_kind k, gfc_code **cpp) | |
3523 { | |
3524 gfc_expr *expr; | |
3525 gfc_code *cp; | |
3526 match m; | |
3527 | |
3528 expr = NULL; | |
3529 | |
3530 m = match_io_iterator (k, cpp); | |
3531 if (m == MATCH_YES) | |
3532 return MATCH_YES; | |
3533 | |
3534 if (k == M_READ) | |
3535 { | |
3536 m = gfc_match_variable (&expr, 0); | |
3537 if (m == MATCH_NO) | |
3538 gfc_error ("Expected variable in READ statement at %C"); | |
3539 } | |
3540 else | |
3541 { | |
3542 m = gfc_match_expr (&expr); | |
3543 if (m == MATCH_NO) | |
3544 gfc_error ("Expected expression in %s statement at %C", | |
3545 io_kind_name (k)); | |
3546 } | |
3547 | |
3548 if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree)) | |
3549 m = MATCH_ERROR; | |
3550 | |
3551 if (m != MATCH_YES) | |
3552 { | |
3553 gfc_free_expr (expr); | |
3554 return MATCH_ERROR; | |
3555 } | |
3556 | |
3557 cp = gfc_get_code (EXEC_TRANSFER); | |
3558 cp->expr1 = expr; | |
3559 if (k != M_INQUIRE) | |
3560 cp->ext.dt = current_dt; | |
3561 | |
3562 *cpp = cp; | |
3563 return MATCH_YES; | |
3564 } | |
3565 | |
3566 | |
3567 /* Match an I/O list, building gfc_code structures as we go. */ | |
3568 | |
3569 static match | |
3570 match_io_list (io_kind k, gfc_code **head_p) | |
3571 { | |
3572 gfc_code *head, *tail, *new_code; | |
3573 match m; | |
3574 | |
3575 *head_p = head = tail = NULL; | |
3576 if (gfc_match_eos () == MATCH_YES) | |
3577 return MATCH_YES; | |
3578 | |
3579 for (;;) | |
3580 { | |
3581 m = match_io_element (k, &new_code); | |
3582 if (m == MATCH_ERROR) | |
3583 goto cleanup; | |
3584 if (m == MATCH_NO) | |
3585 goto syntax; | |
3586 | |
3587 tail = gfc_append_code (tail, new_code); | |
3588 if (head == NULL) | |
3589 head = new_code; | |
3590 | |
3591 if (gfc_match_eos () == MATCH_YES) | |
3592 break; | |
3593 if (gfc_match_char (',') != MATCH_YES) | |
3594 goto syntax; | |
3595 } | |
3596 | |
3597 *head_p = head; | |
3598 return MATCH_YES; | |
3599 | |
3600 syntax: | |
3601 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k)); | |
3602 | |
3603 cleanup: | |
3604 gfc_free_statements (head); | |
3605 return MATCH_ERROR; | |
3606 } | |
3607 | |
3608 | |
3609 /* Attach the data transfer end node. */ | |
3610 | |
3611 static void | |
3612 terminate_io (gfc_code *io_code) | |
3613 { | |
3614 gfc_code *c; | |
3615 | |
3616 if (io_code == NULL) | |
3617 io_code = new_st.block; | |
3618 | |
3619 c = gfc_get_code (EXEC_DT_END); | |
3620 | |
3621 /* Point to structure that is already there */ | |
3622 c->ext.dt = new_st.ext.dt; | |
3623 gfc_append_code (io_code, c); | |
3624 } | |
3625 | |
3626 | |
3627 /* Check the constraints for a data transfer statement. The majority of the | |
3628 constraints appearing in 9.4 of the standard appear here. Some are handled | |
3629 in resolve_tag and others in gfc_resolve_dt. Also set the async_io_dt flag | |
3630 and, if necessary, the asynchronous flag on the SIZE argument. */ | |
3631 | |
3632 static match | |
3633 check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code, | |
3634 locus *spec_end) | |
3635 { | |
3636 #define io_constraint(condition,msg,arg)\ | |
3637 if (condition) \ | |
3638 {\ | |
3639 gfc_error(msg,arg);\ | |
3640 m = MATCH_ERROR;\ | |
3641 } | |
3642 | |
3643 match m; | |
3644 gfc_expr *expr; | |
3645 gfc_symbol *sym = NULL; | |
3646 bool warn, unformatted; | |
3647 | |
3648 warn = (dt->err || dt->iostat) ? true : false; | |
3649 unformatted = dt->format_expr == NULL && dt->format_label == NULL | |
3650 && dt->namelist == NULL; | |
3651 | |
3652 m = MATCH_YES; | |
3653 | |
3654 expr = dt->io_unit; | |
3655 if (expr && expr->expr_type == EXPR_VARIABLE | |
3656 && expr->ts.type == BT_CHARACTER) | |
3657 { | |
3658 sym = expr->symtree->n.sym; | |
3659 | |
3660 io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN, | |
3661 "Internal file at %L must not be INTENT(IN)", | |
3662 &expr->where); | |
3663 | |
3664 io_constraint (gfc_has_vector_index (dt->io_unit), | |
3665 "Internal file incompatible with vector subscript at %L", | |
3666 &expr->where); | |
3667 | |
3668 io_constraint (dt->rec != NULL, | |
3669 "REC tag at %L is incompatible with internal file", | |
3670 &dt->rec->where); | |
3671 | |
3672 io_constraint (dt->pos != NULL, | |
3673 "POS tag at %L is incompatible with internal file", | |
3674 &dt->pos->where); | |
3675 | |
3676 io_constraint (unformatted, | |
3677 "Unformatted I/O not allowed with internal unit at %L", | |
3678 &dt->io_unit->where); | |
3679 | |
3680 io_constraint (dt->asynchronous != NULL, | |
3681 "ASYNCHRONOUS tag at %L not allowed with internal file", | |
3682 &dt->asynchronous->where); | |
3683 | |
3684 if (dt->namelist != NULL) | |
3685 { | |
3686 if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with " | |
3687 "namelist", &expr->where)) | |
3688 m = MATCH_ERROR; | |
3689 } | |
3690 | |
3691 io_constraint (dt->advance != NULL, | |
3692 "ADVANCE tag at %L is incompatible with internal file", | |
3693 &dt->advance->where); | |
3694 } | |
3695 | |
3696 if (expr && expr->ts.type != BT_CHARACTER) | |
3697 { | |
3698 | |
3699 io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE), | |
3700 "IO UNIT in %s statement at %C must be " | |
3701 "an internal file in a PURE procedure", | |
3702 io_kind_name (k)); | |
3703 | |
3704 if (k == M_READ || k == M_WRITE) | |
3705 gfc_unset_implicit_pure (NULL); | |
3706 } | |
3707 | |
3708 if (k != M_READ) | |
3709 { | |
3710 io_constraint (dt->end, "END tag not allowed with output at %L", | |
3711 &dt->end_where); | |
3712 | |
3713 io_constraint (dt->eor, "EOR tag not allowed with output at %L", | |
3714 &dt->eor_where); | |
3715 | |
3716 io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L", | |
3717 &dt->blank->where); | |
3718 | |
3719 io_constraint (dt->pad, "PAD= specifier not allowed with output at %L", | |
3720 &dt->pad->where); | |
3721 | |
3722 io_constraint (dt->size, "SIZE= specifier not allowed with output at %L", | |
3723 &dt->size->where); | |
3724 } | |
3725 else | |
3726 { | |
3727 io_constraint (dt->size && dt->advance == NULL, | |
3728 "SIZE tag at %L requires an ADVANCE tag", | |
3729 &dt->size->where); | |
3730 | |
3731 io_constraint (dt->eor && dt->advance == NULL, | |
3732 "EOR tag at %L requires an ADVANCE tag", | |
3733 &dt->eor_where); | |
3734 } | |
3735 | |
3736 if (dt->asynchronous) | |
3737 { | |
3738 int num; | |
3739 static const char * asynchronous[] = { "YES", "NO", NULL }; | |
3740 | |
3741 if (!gfc_reduce_init_expr (dt->asynchronous)) | |
3742 { | |
3743 gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization " | |
3744 "expression", &dt->asynchronous->where); | |
3745 return MATCH_ERROR; | |
3746 } | |
3747 | |
3748 if (!is_char_type ("ASYNCHRONOUS", dt->asynchronous)) | |
3749 return MATCH_ERROR; | |
3750 | |
3751 if (!compare_to_allowed_values | |
3752 ("ASYNCHRONOUS", asynchronous, NULL, NULL, | |
3753 dt->asynchronous->value.character.string, | |
3754 io_kind_name (k), warn, &num)) | |
3755 return MATCH_ERROR; | |
3756 | |
3757 /* Best to put this here because the yes/no info is still around. */ | |
3758 async_io_dt = num == 0; | |
3759 if (async_io_dt && dt->size) | |
3760 dt->size->symtree->n.sym->attr.asynchronous = 1; | |
3761 } | |
3762 else | |
3763 async_io_dt = false; | |
3764 | |
3765 if (dt->id) | |
3766 { | |
3767 bool not_yes | |
3768 = !dt->asynchronous | |
3769 || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3 | |
3770 || gfc_wide_strncasecmp (dt->asynchronous->value.character.string, | |
3771 "yes", 3) != 0; | |
3772 io_constraint (not_yes, | |
3773 "ID= specifier at %L must be with ASYNCHRONOUS='yes' " | |
3774 "specifier", &dt->id->where); | |
3775 } | |
3776 | |
3777 if (dt->decimal) | |
3778 { | |
3779 if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C " | |
3780 "not allowed in Fortran 95")) | |
3781 return MATCH_ERROR; | |
3782 | |
3783 if (dt->decimal->expr_type == EXPR_CONSTANT) | |
3784 { | |
3785 static const char * decimal[] = { "COMMA", "POINT", NULL }; | |
3786 | |
3787 if (!is_char_type ("DECIMAL", dt->decimal)) | |
3788 return MATCH_ERROR; | |
3789 | |
3790 if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, | |
3791 dt->decimal->value.character.string, | |
3792 io_kind_name (k), warn)) | |
3793 return MATCH_ERROR; | |
3794 | |
3795 io_constraint (unformatted, | |
3796 "the DECIMAL= specifier at %L must be with an " | |
3797 "explicit format expression", &dt->decimal->where); | |
3798 } | |
3799 } | |
3800 | |
3801 if (dt->blank) | |
3802 { | |
3803 if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C " | |
3804 "not allowed in Fortran 95")) | |
3805 return MATCH_ERROR; | |
3806 | |
3807 if (!is_char_type ("BLANK", dt->blank)) | |
3808 return MATCH_ERROR; | |
3809 | |
3810 if (dt->blank->expr_type == EXPR_CONSTANT) | |
3811 { | |
3812 static const char * blank[] = { "NULL", "ZERO", NULL }; | |
3813 | |
3814 | |
3815 if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, | |
3816 dt->blank->value.character.string, | |
3817 io_kind_name (k), warn)) | |
3818 return MATCH_ERROR; | |
3819 | |
3820 io_constraint (unformatted, | |
3821 "the BLANK= specifier at %L must be with an " | |
3822 "explicit format expression", &dt->blank->where); | |
3823 } | |
3824 } | |
3825 | |
3826 if (dt->pad) | |
3827 { | |
3828 if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %C " | |
3829 "not allowed in Fortran 95")) | |
3830 return MATCH_ERROR; | |
3831 | |
3832 if (!is_char_type ("PAD", dt->pad)) | |
3833 return MATCH_ERROR; | |
3834 | |
3835 if (dt->pad->expr_type == EXPR_CONSTANT) | |
3836 { | |
3837 static const char * pad[] = { "YES", "NO", NULL }; | |
3838 | |
3839 if (!compare_to_allowed_values ("PAD", pad, NULL, NULL, | |
3840 dt->pad->value.character.string, | |
3841 io_kind_name (k), warn)) | |
3842 return MATCH_ERROR; | |
3843 | |
3844 io_constraint (unformatted, | |
3845 "the PAD= specifier at %L must be with an " | |
3846 "explicit format expression", &dt->pad->where); | |
3847 } | |
3848 } | |
3849 | |
3850 if (dt->round) | |
3851 { | |
3852 if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C " | |
3853 "not allowed in Fortran 95")) | |
3854 return MATCH_ERROR; | |
3855 | |
3856 if (!is_char_type ("ROUND", dt->round)) | |
3857 return MATCH_ERROR; | |
3858 | |
3859 if (dt->round->expr_type == EXPR_CONSTANT) | |
3860 { | |
3861 static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST", | |
3862 "COMPATIBLE", "PROCESSOR_DEFINED", | |
3863 NULL }; | |
3864 | |
3865 if (!compare_to_allowed_values ("ROUND", round, NULL, NULL, | |
3866 dt->round->value.character.string, | |
3867 io_kind_name (k), warn)) | |
3868 return MATCH_ERROR; | |
3869 } | |
3870 } | |
3871 | |
3872 if (dt->sign) | |
3873 { | |
3874 /* When implemented, change the following to use gfc_notify_std F2003. | |
3875 if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C " | |
3876 "not allowed in Fortran 95") == false) | |
3877 return MATCH_ERROR; */ | |
3878 | |
3879 if (!is_char_type ("SIGN", dt->sign)) | |
3880 return MATCH_ERROR; | |
3881 | |
3882 if (dt->sign->expr_type == EXPR_CONSTANT) | |
3883 { | |
3884 static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED", | |
3885 NULL }; | |
3886 | |
3887 if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL, | |
3888 dt->sign->value.character.string, | |
3889 io_kind_name (k), warn)) | |
3890 return MATCH_ERROR; | |
3891 | |
3892 io_constraint (unformatted, | |
3893 "SIGN= specifier at %L must be with an " | |
3894 "explicit format expression", &dt->sign->where); | |
3895 | |
3896 io_constraint (k == M_READ, | |
3897 "SIGN= specifier at %L not allowed in a " | |
3898 "READ statement", &dt->sign->where); | |
3899 } | |
3900 } | |
3901 | |
3902 if (dt->delim) | |
3903 { | |
3904 if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %C " | |
3905 "not allowed in Fortran 95")) | |
3906 return MATCH_ERROR; | |
3907 | |
3908 if (!is_char_type ("DELIM", dt->delim)) | |
3909 return MATCH_ERROR; | |
3910 | |
3911 if (dt->delim->expr_type == EXPR_CONSTANT) | |
3912 { | |
3913 static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; | |
3914 | |
3915 if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, | |
3916 dt->delim->value.character.string, | |
3917 io_kind_name (k), warn)) | |
3918 return MATCH_ERROR; | |
3919 | |
3920 io_constraint (k == M_READ, | |
3921 "DELIM= specifier at %L not allowed in a " | |
3922 "READ statement", &dt->delim->where); | |
3923 | |
3924 io_constraint (dt->format_label != &format_asterisk | |
3925 && dt->namelist == NULL, | |
3926 "DELIM= specifier at %L must have FMT=*", | |
3927 &dt->delim->where); | |
3928 | |
3929 io_constraint (unformatted && dt->namelist == NULL, | |
3930 "DELIM= specifier at %L must be with FMT=* or " | |
3931 "NML= specifier", &dt->delim->where); | |
3932 } | |
3933 } | |
3934 | |
3935 if (dt->namelist) | |
3936 { | |
3937 io_constraint (io_code && dt->namelist, | |
3938 "NAMELIST cannot be followed by IO-list at %L", | |
3939 &io_code->loc); | |
3940 | |
3941 io_constraint (dt->format_expr, | |
3942 "IO spec-list cannot contain both NAMELIST group name " | |
3943 "and format specification at %L", | |
3944 &dt->format_expr->where); | |
3945 | |
3946 io_constraint (dt->format_label, | |
3947 "IO spec-list cannot contain both NAMELIST group name " | |
3948 "and format label at %L", spec_end); | |
3949 | |
3950 io_constraint (dt->rec, | |
3951 "NAMELIST IO is not allowed with a REC= specifier " | |
3952 "at %L", &dt->rec->where); | |
3953 | |
3954 io_constraint (dt->advance, | |
3955 "NAMELIST IO is not allowed with a ADVANCE= specifier " | |
3956 "at %L", &dt->advance->where); | |
3957 } | |
3958 | |
3959 if (dt->rec) | |
3960 { | |
3961 io_constraint (dt->end, | |
3962 "An END tag is not allowed with a " | |
3963 "REC= specifier at %L", &dt->end_where); | |
3964 | |
3965 io_constraint (dt->format_label == &format_asterisk, | |
3966 "FMT=* is not allowed with a REC= specifier " | |
3967 "at %L", spec_end); | |
3968 | |
3969 io_constraint (dt->pos, | |
3970 "POS= is not allowed with REC= specifier " | |
3971 "at %L", &dt->pos->where); | |
3972 } | |
3973 | |
3974 if (dt->advance) | |
3975 { | |
3976 int not_yes, not_no; | |
3977 expr = dt->advance; | |
3978 | |
3979 io_constraint (dt->format_label == &format_asterisk, | |
3980 "List directed format(*) is not allowed with a " | |
3981 "ADVANCE= specifier at %L.", &expr->where); | |
3982 | |
3983 io_constraint (unformatted, | |
3984 "the ADVANCE= specifier at %L must appear with an " | |
3985 "explicit format expression", &expr->where); | |
3986 | |
3987 if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER) | |
3988 { | |
3989 const gfc_char_t *advance = expr->value.character.string; | |
3990 not_no = gfc_wide_strlen (advance) != 2 | |
3991 || gfc_wide_strncasecmp (advance, "no", 2) != 0; | |
3992 not_yes = gfc_wide_strlen (advance) != 3 | |
3993 || gfc_wide_strncasecmp (advance, "yes", 3) != 0; | |
3994 } | |
3995 else | |
3996 { | |
3997 not_no = 0; | |
3998 not_yes = 0; | |
3999 } | |
4000 | |
4001 io_constraint (not_no && not_yes, | |
4002 "ADVANCE= specifier at %L must have value = " | |
4003 "YES or NO.", &expr->where); | |
4004 | |
4005 io_constraint (dt->size && not_no && k == M_READ, | |
4006 "SIZE tag at %L requires an ADVANCE = %<NO%>", | |
4007 &dt->size->where); | |
4008 | |
4009 io_constraint (dt->eor && not_no && k == M_READ, | |
4010 "EOR tag at %L requires an ADVANCE = %<NO%>", | |
4011 &dt->eor_where); | |
4012 } | |
4013 | |
4014 expr = dt->format_expr; | |
4015 if (!gfc_simplify_expr (expr, 0) | |
4016 || !check_format_string (expr, k == M_READ)) | |
4017 return MATCH_ERROR; | |
4018 | |
4019 return m; | |
4020 } | |
4021 #undef io_constraint | |
4022 | |
4023 | |
4024 /* Match a READ, WRITE or PRINT statement. */ | |
4025 | |
4026 static match | |
4027 match_io (io_kind k) | |
4028 { | |
4029 char name[GFC_MAX_SYMBOL_LEN + 1]; | |
4030 gfc_code *io_code; | |
4031 gfc_symbol *sym; | |
4032 int comma_flag; | |
4033 locus where; | |
4034 locus spec_end, control; | |
4035 gfc_dt *dt; | |
4036 match m; | |
4037 | |
4038 where = gfc_current_locus; | |
4039 comma_flag = 0; | |
4040 current_dt = dt = XCNEW (gfc_dt); | |
4041 m = gfc_match_char ('('); | |
4042 if (m == MATCH_NO) | |
4043 { | |
4044 where = gfc_current_locus; | |
4045 if (k == M_WRITE) | |
4046 goto syntax; | |
4047 else if (k == M_PRINT) | |
4048 { | |
4049 /* Treat the non-standard case of PRINT namelist. */ | |
4050 if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ') | |
4051 && gfc_match_name (name) == MATCH_YES) | |
4052 { | |
4053 gfc_find_symbol (name, NULL, 1, &sym); | |
4054 if (sym && sym->attr.flavor == FL_NAMELIST) | |
4055 { | |
4056 if (!gfc_notify_std (GFC_STD_GNU, "PRINT namelist at " | |
4057 "%C is an extension")) | |
4058 { | |
4059 m = MATCH_ERROR; | |
4060 goto cleanup; | |
4061 } | |
4062 | |
4063 dt->io_unit = default_unit (k); | |
4064 dt->namelist = sym; | |
4065 goto get_io_list; | |
4066 } | |
4067 else | |
4068 gfc_current_locus = where; | |
4069 } | |
4070 } | |
4071 | |
4072 if (gfc_current_form == FORM_FREE) | |
4073 { | |
4074 char c = gfc_peek_ascii_char (); | |
4075 if (c != ' ' && c != '*' && c != '\'' && c != '"') | |
4076 { | |
4077 m = MATCH_NO; | |
4078 goto cleanup; | |
4079 } | |
4080 } | |
4081 | |
4082 m = match_dt_format (dt); | |
4083 if (m == MATCH_ERROR) | |
4084 goto cleanup; | |
4085 if (m == MATCH_NO) | |
4086 goto syntax; | |
4087 | |
4088 comma_flag = 1; | |
4089 dt->io_unit = default_unit (k); | |
4090 goto get_io_list; | |
4091 } | |
4092 else | |
4093 { | |
4094 /* Before issuing an error for a malformed 'print (1,*)' type of | |
4095 error, check for a default-char-expr of the form ('(I0)'). */ | |
4096 if (m == MATCH_YES) | |
4097 { | |
4098 control = gfc_current_locus; | |
4099 if (k == M_PRINT) | |
4100 { | |
4101 /* Reset current locus to get the initial '(' in an expression. */ | |
4102 gfc_current_locus = where; | |
4103 dt->format_expr = NULL; | |
4104 m = match_dt_format (dt); | |
4105 | |
4106 if (m == MATCH_ERROR) | |
4107 goto cleanup; | |
4108 if (m == MATCH_NO || dt->format_expr == NULL) | |
4109 goto syntax; | |
4110 | |
4111 comma_flag = 1; | |
4112 dt->io_unit = default_unit (k); | |
4113 goto get_io_list; | |
4114 } | |
4115 if (k == M_READ) | |
4116 { | |
4117 /* Commit any pending symbols now so that when we undo | |
4118 symbols later we wont lose them. */ | |
4119 gfc_commit_symbols (); | |
4120 /* Reset current locus to get the initial '(' in an expression. */ | |
4121 gfc_current_locus = where; | |
4122 dt->format_expr = NULL; | |
4123 m = gfc_match_expr (&dt->format_expr); | |
4124 if (m == MATCH_YES) | |
4125 { | |
4126 if (dt->format_expr | |
4127 && dt->format_expr->ts.type == BT_CHARACTER) | |
4128 { | |
4129 comma_flag = 1; | |
4130 dt->io_unit = default_unit (k); | |
4131 goto get_io_list; | |
4132 } | |
4133 else | |
4134 { | |
4135 gfc_free_expr (dt->format_expr); | |
4136 dt->format_expr = NULL; | |
4137 gfc_current_locus = control; | |
4138 } | |
4139 } | |
4140 else | |
4141 { | |
4142 gfc_clear_error (); | |
4143 gfc_undo_symbols (); | |
4144 gfc_free_expr (dt->format_expr); | |
4145 dt->format_expr = NULL; | |
4146 gfc_current_locus = control; | |
4147 } | |
4148 } | |
4149 } | |
4150 } | |
4151 | |
4152 /* Match a control list */ | |
4153 if (match_dt_element (k, dt) == MATCH_YES) | |
4154 goto next; | |
4155 if (match_dt_unit (k, dt) != MATCH_YES) | |
4156 goto loop; | |
4157 | |
4158 if (gfc_match_char (')') == MATCH_YES) | |
4159 goto get_io_list; | |
4160 if (gfc_match_char (',') != MATCH_YES) | |
4161 goto syntax; | |
4162 | |
4163 m = match_dt_element (k, dt); | |
4164 if (m == MATCH_YES) | |
4165 goto next; | |
4166 if (m == MATCH_ERROR) | |
4167 goto cleanup; | |
4168 | |
4169 m = match_dt_format (dt); | |
4170 if (m == MATCH_YES) | |
4171 goto next; | |
4172 if (m == MATCH_ERROR) | |
4173 goto cleanup; | |
4174 | |
4175 where = gfc_current_locus; | |
4176 | |
4177 m = gfc_match_name (name); | |
4178 if (m == MATCH_YES) | |
4179 { | |
4180 gfc_find_symbol (name, NULL, 1, &sym); | |
4181 if (sym && sym->attr.flavor == FL_NAMELIST) | |
4182 { | |
4183 dt->namelist = sym; | |
4184 if (k == M_READ && check_namelist (sym)) | |
4185 { | |
4186 m = MATCH_ERROR; | |
4187 goto cleanup; | |
4188 } | |
4189 goto next; | |
4190 } | |
4191 } | |
4192 | |
4193 gfc_current_locus = where; | |
4194 | |
4195 goto loop; /* No matches, try regular elements */ | |
4196 | |
4197 next: | |
4198 if (gfc_match_char (')') == MATCH_YES) | |
4199 goto get_io_list; | |
4200 if (gfc_match_char (',') != MATCH_YES) | |
4201 goto syntax; | |
4202 | |
4203 loop: | |
4204 for (;;) | |
4205 { | |
4206 m = match_dt_element (k, dt); | |
4207 if (m == MATCH_NO) | |
4208 goto syntax; | |
4209 if (m == MATCH_ERROR) | |
4210 goto cleanup; | |
4211 | |
4212 if (gfc_match_char (')') == MATCH_YES) | |
4213 break; | |
4214 if (gfc_match_char (',') != MATCH_YES) | |
4215 goto syntax; | |
4216 } | |
4217 | |
4218 get_io_list: | |
4219 | |
4220 /* Used in check_io_constraints, where no locus is available. */ | |
4221 spec_end = gfc_current_locus; | |
4222 | |
4223 /* Save the IO kind for later use. */ | |
4224 dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k); | |
4225 | |
4226 /* Optional leading comma (non-standard). We use a gfc_expr structure here | |
4227 to save the locus. This is used later when resolving transfer statements | |
4228 that might have a format expression without unit number. */ | |
4229 if (!comma_flag && gfc_match_char (',') == MATCH_YES) | |
4230 dt->extra_comma = dt->dt_io_kind; | |
4231 | |
4232 io_code = NULL; | |
4233 if (gfc_match_eos () != MATCH_YES) | |
4234 { | |
4235 if (comma_flag && gfc_match_char (',') != MATCH_YES) | |
4236 { | |
4237 gfc_error ("Expected comma in I/O list at %C"); | |
4238 m = MATCH_ERROR; | |
4239 goto cleanup; | |
4240 } | |
4241 | |
4242 m = match_io_list (k, &io_code); | |
4243 if (m == MATCH_ERROR) | |
4244 goto cleanup; | |
4245 if (m == MATCH_NO) | |
4246 goto syntax; | |
4247 } | |
4248 | |
4249 /* See if we want to use defaults for missing exponents in real transfers. */ | |
4250 if (flag_dec) | |
4251 dt->default_exp = 1; | |
4252 | |
4253 /* A full IO statement has been matched. Check the constraints. spec_end is | |
4254 supplied for cases where no locus is supplied. */ | |
4255 m = check_io_constraints (k, dt, io_code, &spec_end); | |
4256 | |
4257 if (m == MATCH_ERROR) | |
4258 goto cleanup; | |
4259 | |
4260 new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE; | |
4261 new_st.ext.dt = dt; | |
4262 new_st.block = gfc_get_code (new_st.op); | |
4263 new_st.block->next = io_code; | |
4264 | |
4265 terminate_io (io_code); | |
4266 | |
4267 return MATCH_YES; | |
4268 | |
4269 syntax: | |
4270 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k)); | |
4271 m = MATCH_ERROR; | |
4272 | |
4273 cleanup: | |
4274 gfc_free_dt (dt); | |
4275 return m; | |
4276 } | |
4277 | |
4278 | |
4279 match | |
4280 gfc_match_read (void) | |
4281 { | |
4282 return match_io (M_READ); | |
4283 } | |
4284 | |
4285 | |
4286 match | |
4287 gfc_match_write (void) | |
4288 { | |
4289 return match_io (M_WRITE); | |
4290 } | |
4291 | |
4292 | |
4293 match | |
4294 gfc_match_print (void) | |
4295 { | |
4296 match m; | |
4297 | |
4298 m = match_io (M_PRINT); | |
4299 if (m != MATCH_YES) | |
4300 return m; | |
4301 | |
4302 if (gfc_pure (NULL)) | |
4303 { | |
4304 gfc_error ("PRINT statement at %C not allowed within PURE procedure"); | |
4305 return MATCH_ERROR; | |
4306 } | |
4307 | |
4308 gfc_unset_implicit_pure (NULL); | |
4309 | |
4310 return MATCH_YES; | |
4311 } | |
4312 | |
4313 | |
4314 /* Free a gfc_inquire structure. */ | |
4315 | |
4316 void | |
4317 gfc_free_inquire (gfc_inquire *inquire) | |
4318 { | |
4319 | |
4320 if (inquire == NULL) | |
4321 return; | |
4322 | |
4323 gfc_free_expr (inquire->unit); | |
4324 gfc_free_expr (inquire->file); | |
4325 gfc_free_expr (inquire->iomsg); | |
4326 gfc_free_expr (inquire->iostat); | |
4327 gfc_free_expr (inquire->exist); | |
4328 gfc_free_expr (inquire->opened); | |
4329 gfc_free_expr (inquire->number); | |
4330 gfc_free_expr (inquire->named); | |
4331 gfc_free_expr (inquire->name); | |
4332 gfc_free_expr (inquire->access); | |
4333 gfc_free_expr (inquire->sequential); | |
4334 gfc_free_expr (inquire->direct); | |
4335 gfc_free_expr (inquire->form); | |
4336 gfc_free_expr (inquire->formatted); | |
4337 gfc_free_expr (inquire->unformatted); | |
4338 gfc_free_expr (inquire->recl); | |
4339 gfc_free_expr (inquire->nextrec); | |
4340 gfc_free_expr (inquire->blank); | |
4341 gfc_free_expr (inquire->position); | |
4342 gfc_free_expr (inquire->action); | |
4343 gfc_free_expr (inquire->read); | |
4344 gfc_free_expr (inquire->write); | |
4345 gfc_free_expr (inquire->readwrite); | |
4346 gfc_free_expr (inquire->delim); | |
4347 gfc_free_expr (inquire->encoding); | |
4348 gfc_free_expr (inquire->pad); | |
4349 gfc_free_expr (inquire->iolength); | |
4350 gfc_free_expr (inquire->convert); | |
4351 gfc_free_expr (inquire->strm_pos); | |
4352 gfc_free_expr (inquire->asynchronous); | |
4353 gfc_free_expr (inquire->decimal); | |
4354 gfc_free_expr (inquire->pending); | |
4355 gfc_free_expr (inquire->id); | |
4356 gfc_free_expr (inquire->sign); | |
4357 gfc_free_expr (inquire->size); | |
4358 gfc_free_expr (inquire->round); | |
4359 gfc_free_expr (inquire->share); | |
4360 gfc_free_expr (inquire->cc); | |
4361 free (inquire); | |
4362 } | |
4363 | |
4364 | |
4365 /* Match an element of an INQUIRE statement. */ | |
4366 | |
4367 #define RETM if (m != MATCH_NO) return m; | |
4368 | |
4369 static match | |
4370 match_inquire_element (gfc_inquire *inquire) | |
4371 { | |
4372 match m; | |
4373 | |
4374 m = match_etag (&tag_unit, &inquire->unit); | |
4375 RETM m = match_etag (&tag_file, &inquire->file); | |
4376 RETM m = match_ltag (&tag_err, &inquire->err); | |
4377 RETM m = match_etag (&tag_iomsg, &inquire->iomsg); | |
4378 if (m == MATCH_YES && !check_char_variable (inquire->iomsg)) | |
4379 return MATCH_ERROR; | |
4380 RETM m = match_out_tag (&tag_iostat, &inquire->iostat); | |
4381 RETM m = match_vtag (&tag_exist, &inquire->exist); | |
4382 RETM m = match_vtag (&tag_opened, &inquire->opened); | |
4383 RETM m = match_vtag (&tag_named, &inquire->named); | |
4384 RETM m = match_vtag (&tag_name, &inquire->name); | |
4385 RETM m = match_out_tag (&tag_number, &inquire->number); | |
4386 RETM m = match_vtag (&tag_s_access, &inquire->access); | |
4387 RETM m = match_vtag (&tag_sequential, &inquire->sequential); | |
4388 RETM m = match_vtag (&tag_direct, &inquire->direct); | |
4389 RETM m = match_vtag (&tag_s_form, &inquire->form); | |
4390 RETM m = match_vtag (&tag_formatted, &inquire->formatted); | |
4391 RETM m = match_vtag (&tag_unformatted, &inquire->unformatted); | |
4392 RETM m = match_out_tag (&tag_s_recl, &inquire->recl); | |
4393 RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec); | |
4394 RETM m = match_vtag (&tag_s_blank, &inquire->blank); | |
4395 RETM m = match_vtag (&tag_s_position, &inquire->position); | |
4396 RETM m = match_vtag (&tag_s_action, &inquire->action); | |
4397 RETM m = match_vtag (&tag_read, &inquire->read); | |
4398 RETM m = match_vtag (&tag_write, &inquire->write); | |
4399 RETM m = match_vtag (&tag_readwrite, &inquire->readwrite); | |
4400 RETM m = match_vtag (&tag_s_async, &inquire->asynchronous); | |
4401 if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", inquire->asynchronous)) | |
4402 return MATCH_ERROR; | |
4403 RETM m = match_vtag (&tag_s_delim, &inquire->delim); | |
4404 RETM m = match_vtag (&tag_s_decimal, &inquire->decimal); | |
4405 RETM m = match_out_tag (&tag_size, &inquire->size); | |
4406 RETM m = match_vtag (&tag_s_encoding, &inquire->encoding); | |
4407 RETM m = match_vtag (&tag_s_round, &inquire->round); | |
4408 RETM m = match_vtag (&tag_s_sign, &inquire->sign); | |
4409 RETM m = match_vtag (&tag_s_pad, &inquire->pad); | |
4410 RETM m = match_out_tag (&tag_iolength, &inquire->iolength); | |
4411 RETM m = match_vtag (&tag_convert, &inquire->convert); | |
4412 RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos); | |
4413 RETM m = match_vtag (&tag_pending, &inquire->pending); | |
4414 RETM m = match_vtag (&tag_id, &inquire->id); | |
4415 RETM m = match_vtag (&tag_s_iqstream, &inquire->iqstream); | |
4416 RETM m = match_dec_vtag (&tag_v_share, &inquire->share); | |
4417 RETM m = match_dec_vtag (&tag_v_cc, &inquire->cc); | |
4418 RETM return MATCH_NO; | |
4419 } | |
4420 | |
4421 #undef RETM | |
4422 | |
4423 | |
4424 match | |
4425 gfc_match_inquire (void) | |
4426 { | |
4427 gfc_inquire *inquire; | |
4428 gfc_code *code; | |
4429 match m; | |
4430 locus loc; | |
4431 | |
4432 m = gfc_match_char ('('); | |
4433 if (m == MATCH_NO) | |
4434 return m; | |
4435 | |
4436 inquire = XCNEW (gfc_inquire); | |
4437 | |
4438 loc = gfc_current_locus; | |
4439 | |
4440 m = match_inquire_element (inquire); | |
4441 if (m == MATCH_ERROR) | |
4442 goto cleanup; | |
4443 if (m == MATCH_NO) | |
4444 { | |
4445 m = gfc_match_expr (&inquire->unit); | |
4446 if (m == MATCH_ERROR) | |
4447 goto cleanup; | |
4448 if (m == MATCH_NO) | |
4449 goto syntax; | |
4450 } | |
4451 | |
4452 /* See if we have the IOLENGTH form of the inquire statement. */ | |
4453 if (inquire->iolength != NULL) | |
4454 { | |
4455 if (gfc_match_char (')') != MATCH_YES) | |
4456 goto syntax; | |
4457 | |
4458 m = match_io_list (M_INQUIRE, &code); | |
4459 if (m == MATCH_ERROR) | |
4460 goto cleanup; | |
4461 if (m == MATCH_NO) | |
4462 goto syntax; | |
4463 | |
4464 new_st.op = EXEC_IOLENGTH; | |
4465 new_st.expr1 = inquire->iolength; | |
4466 new_st.ext.inquire = inquire; | |
4467 | |
4468 if (gfc_pure (NULL)) | |
4469 { | |
4470 gfc_free_statements (code); | |
4471 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C"); | |
4472 return MATCH_ERROR; | |
4473 } | |
4474 | |
4475 gfc_unset_implicit_pure (NULL); | |
4476 | |
4477 new_st.block = gfc_get_code (EXEC_IOLENGTH); | |
4478 terminate_io (code); | |
4479 new_st.block->next = code; | |
4480 return MATCH_YES; | |
4481 } | |
4482 | |
4483 /* At this point, we have the non-IOLENGTH inquire statement. */ | |
4484 for (;;) | |
4485 { | |
4486 if (gfc_match_char (')') == MATCH_YES) | |
4487 break; | |
4488 if (gfc_match_char (',') != MATCH_YES) | |
4489 goto syntax; | |
4490 | |
4491 m = match_inquire_element (inquire); | |
4492 if (m == MATCH_ERROR) | |
4493 goto cleanup; | |
4494 if (m == MATCH_NO) | |
4495 goto syntax; | |
4496 | |
4497 if (inquire->iolength != NULL) | |
4498 { | |
4499 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C"); | |
4500 goto cleanup; | |
4501 } | |
4502 } | |
4503 | |
4504 if (gfc_match_eos () != MATCH_YES) | |
4505 goto syntax; | |
4506 | |
4507 if (inquire->unit != NULL && inquire->file != NULL) | |
4508 { | |
4509 gfc_error ("INQUIRE statement at %L cannot contain both FILE and " | |
4510 "UNIT specifiers", &loc); | |
4511 goto cleanup; | |
4512 } | |
4513 | |
4514 if (inquire->unit == NULL && inquire->file == NULL) | |
4515 { | |
4516 gfc_error ("INQUIRE statement at %L requires either FILE or " | |
4517 "UNIT specifier", &loc); | |
4518 goto cleanup; | |
4519 } | |
4520 | |
4521 if (inquire->unit != NULL && inquire->unit->expr_type == EXPR_CONSTANT | |
4522 && inquire->unit->ts.type == BT_INTEGER | |
4523 && ((mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT4) | |
4524 || (mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT))) | |
4525 { | |
4526 gfc_error ("UNIT number in INQUIRE statement at %L can not " | |
4527 "be %d", &loc, (int) mpz_get_si (inquire->unit->value.integer)); | |
4528 goto cleanup; | |
4529 } | |
4530 | |
4531 if (gfc_pure (NULL)) | |
4532 { | |
4533 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C"); | |
4534 goto cleanup; | |
4535 } | |
4536 | |
4537 gfc_unset_implicit_pure (NULL); | |
4538 | |
4539 if (inquire->id != NULL && inquire->pending == NULL) | |
4540 { | |
4541 gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with " | |
4542 "the ID= specifier", &loc); | |
4543 goto cleanup; | |
4544 } | |
4545 | |
4546 new_st.op = EXEC_INQUIRE; | |
4547 new_st.ext.inquire = inquire; | |
4548 return MATCH_YES; | |
4549 | |
4550 syntax: | |
4551 gfc_syntax_error (ST_INQUIRE); | |
4552 | |
4553 cleanup: | |
4554 gfc_free_inquire (inquire); | |
4555 return MATCH_ERROR; | |
4556 } | |
4557 | |
4558 | |
4559 /* Resolve everything in a gfc_inquire structure. */ | |
4560 | |
4561 bool | |
4562 gfc_resolve_inquire (gfc_inquire *inquire) | |
4563 { | |
4564 RESOLVE_TAG (&tag_unit, inquire->unit); | |
4565 RESOLVE_TAG (&tag_file, inquire->file); | |
4566 RESOLVE_TAG (&tag_id, inquire->id); | |
4567 | |
4568 /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition | |
4569 contexts. Thus, use an extended RESOLVE_TAG macro for that. */ | |
4570 #define INQUIRE_RESOLVE_TAG(tag, expr) \ | |
4571 RESOLVE_TAG (tag, expr); \ | |
4572 if (expr) \ | |
4573 { \ | |
4574 char context[64]; \ | |
4575 sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \ | |
4576 if (gfc_check_vardef_context ((expr), false, false, false, \ | |
4577 context) == false) \ | |
4578 return false; \ | |
4579 } | |
4580 INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg); | |
4581 INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat); | |
4582 INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist); | |
4583 INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened); | |
4584 INQUIRE_RESOLVE_TAG (&tag_number, inquire->number); | |
4585 INQUIRE_RESOLVE_TAG (&tag_named, inquire->named); | |
4586 INQUIRE_RESOLVE_TAG (&tag_name, inquire->name); | |
4587 INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access); | |
4588 INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential); | |
4589 INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct); | |
4590 INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form); | |
4591 INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted); | |
4592 INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted); | |
4593 INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl); | |
4594 INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec); | |
4595 INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank); | |
4596 INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position); | |
4597 INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action); | |
4598 INQUIRE_RESOLVE_TAG (&tag_read, inquire->read); | |
4599 INQUIRE_RESOLVE_TAG (&tag_write, inquire->write); | |
4600 INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite); | |
4601 INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim); | |
4602 INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad); | |
4603 INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding); | |
4604 INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round); | |
4605 INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength); | |
4606 INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert); | |
4607 INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos); | |
4608 INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous); | |
4609 INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign); | |
4610 INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round); | |
4611 INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending); | |
4612 INQUIRE_RESOLVE_TAG (&tag_size, inquire->size); | |
4613 INQUIRE_RESOLVE_TAG (&tag_s_decimal, inquire->decimal); | |
4614 INQUIRE_RESOLVE_TAG (&tag_s_iqstream, inquire->iqstream); | |
4615 INQUIRE_RESOLVE_TAG (&tag_v_share, inquire->share); | |
4616 INQUIRE_RESOLVE_TAG (&tag_v_cc, inquire->cc); | |
4617 #undef INQUIRE_RESOLVE_TAG | |
4618 | |
4619 if (!gfc_reference_st_label (inquire->err, ST_LABEL_TARGET)) | |
4620 return false; | |
4621 | |
4622 return true; | |
4623 } | |
4624 | |
4625 | |
4626 void | |
4627 gfc_free_wait (gfc_wait *wait) | |
4628 { | |
4629 if (wait == NULL) | |
4630 return; | |
4631 | |
4632 gfc_free_expr (wait->unit); | |
4633 gfc_free_expr (wait->iostat); | |
4634 gfc_free_expr (wait->iomsg); | |
4635 gfc_free_expr (wait->id); | |
4636 free (wait); | |
4637 } | |
4638 | |
4639 | |
4640 bool | |
4641 gfc_resolve_wait (gfc_wait *wait) | |
4642 { | |
4643 RESOLVE_TAG (&tag_unit, wait->unit); | |
4644 RESOLVE_TAG (&tag_iomsg, wait->iomsg); | |
4645 RESOLVE_TAG (&tag_iostat, wait->iostat); | |
4646 RESOLVE_TAG (&tag_id, wait->id); | |
4647 | |
4648 if (!gfc_reference_st_label (wait->err, ST_LABEL_TARGET)) | |
4649 return false; | |
4650 | |
4651 if (!gfc_reference_st_label (wait->end, ST_LABEL_TARGET)) | |
4652 return false; | |
4653 | |
4654 return true; | |
4655 } | |
4656 | |
4657 /* Match an element of a WAIT statement. */ | |
4658 | |
4659 #define RETM if (m != MATCH_NO) return m; | |
4660 | |
4661 static match | |
4662 match_wait_element (gfc_wait *wait) | |
4663 { | |
4664 match m; | |
4665 | |
4666 m = match_etag (&tag_unit, &wait->unit); | |
4667 RETM m = match_ltag (&tag_err, &wait->err); | |
4668 RETM m = match_ltag (&tag_end, &wait->end); | |
4669 RETM m = match_ltag (&tag_eor, &wait->eor); | |
4670 RETM m = match_etag (&tag_iomsg, &wait->iomsg); | |
4671 if (m == MATCH_YES && !check_char_variable (wait->iomsg)) | |
4672 return MATCH_ERROR; | |
4673 RETM m = match_out_tag (&tag_iostat, &wait->iostat); | |
4674 RETM m = match_etag (&tag_id, &wait->id); | |
4675 RETM return MATCH_NO; | |
4676 } | |
4677 | |
4678 #undef RETM | |
4679 | |
4680 | |
4681 match | |
4682 gfc_match_wait (void) | |
4683 { | |
4684 gfc_wait *wait; | |
4685 match m; | |
4686 | |
4687 m = gfc_match_char ('('); | |
4688 if (m == MATCH_NO) | |
4689 return m; | |
4690 | |
4691 wait = XCNEW (gfc_wait); | |
4692 | |
4693 m = match_wait_element (wait); | |
4694 if (m == MATCH_ERROR) | |
4695 goto cleanup; | |
4696 if (m == MATCH_NO) | |
4697 { | |
4698 m = gfc_match_expr (&wait->unit); | |
4699 if (m == MATCH_ERROR) | |
4700 goto cleanup; | |
4701 if (m == MATCH_NO) | |
4702 goto syntax; | |
4703 } | |
4704 | |
4705 for (;;) | |
4706 { | |
4707 if (gfc_match_char (')') == MATCH_YES) | |
4708 break; | |
4709 if (gfc_match_char (',') != MATCH_YES) | |
4710 goto syntax; | |
4711 | |
4712 m = match_wait_element (wait); | |
4713 if (m == MATCH_ERROR) | |
4714 goto cleanup; | |
4715 if (m == MATCH_NO) | |
4716 goto syntax; | |
4717 } | |
4718 | |
4719 if (!gfc_notify_std (GFC_STD_F2003, "WAIT at %C " | |
4720 "not allowed in Fortran 95")) | |
4721 goto cleanup; | |
4722 | |
4723 if (gfc_pure (NULL)) | |
4724 { | |
4725 gfc_error ("WAIT statement not allowed in PURE procedure at %C"); | |
4726 goto cleanup; | |
4727 } | |
4728 | |
4729 gfc_unset_implicit_pure (NULL); | |
4730 | |
4731 new_st.op = EXEC_WAIT; | |
4732 new_st.ext.wait = wait; | |
4733 | |
4734 return MATCH_YES; | |
4735 | |
4736 syntax: | |
4737 gfc_syntax_error (ST_WAIT); | |
4738 | |
4739 cleanup: | |
4740 gfc_free_wait (wait); | |
4741 return MATCH_ERROR; | |
4742 } |