?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2018-03-01 Paul Thomas <pault@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / io.c
blobd9f0fb1d4ac9e35ba5d1ad8bcadc7b74be82925d
1 /* Deal with I/O statements & related stuff.
2 Copyright (C) 2000-2018 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_COLON:
989 goto format_item_1;
990
991 case FMT_LPAREN:
992
993 dtio_vlist:
994 t = format_lex ();
995 if (t == FMT_ERROR)
996 goto fail;
997
998 if (t != FMT_POSINT)
999 {
1000 error = posint_required;
1001 goto syntax;
1002 }
1003
1004 t = format_lex ();
1005 if (t == FMT_ERROR)
1006 goto fail;
1007
1008 if (t == FMT_COMMA)
1009 goto dtio_vlist;
1010 if (t != FMT_RPAREN)
1011 {
1012 error = _("Right parenthesis expected at %C");
1013 goto syntax;
1014 }
1015 goto between_desc;
1016
1017 default:
1018 error = unexpected_element;
1019 goto syntax;
1020 }
1021 break;
1022
1023 case FMT_F:
1024 t = format_lex ();
1025 if (t == FMT_ERROR)
1026 goto fail;
1027 if (t != FMT_ZERO && t != FMT_POSINT)
1028 {
1029 error = nonneg_required;
1030 goto syntax;
1031 }
1032 else if (is_input && t == FMT_ZERO)
1033 {
1034 error = posint_required;
1035 goto syntax;
1036 }
1037
1038 t = format_lex ();
1039 if (t == FMT_ERROR)
1040 goto fail;
1041 if (t != FMT_PERIOD)
1042 {
1043 /* Warn if -std=legacy, otherwise error. */
1044 if (gfc_option.warn_std != 0)
1045 {
1046 error = _("Period required in format specifier");
1047 goto syntax;
1048 }
1049 if (mode != MODE_FORMAT)
1050 format_locus.nextc += format_string_pos;
1051 gfc_warning (0, "Period required in format specifier at %L",
1052 &format_locus);
1053 saved_token = t;
1054 break;
1055 }
1056
1057 t = format_lex ();
1058 if (t == FMT_ERROR)
1059 goto fail;
1060 if (t != FMT_ZERO && t != FMT_POSINT)
1061 {
1062 error = nonneg_required;
1063 goto syntax;
1064 }
1065
1066 break;
1067
1068 case FMT_H:
1069 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
1070 {
1071 if (mode != MODE_FORMAT)
1072 format_locus.nextc += format_string_pos;
1073 gfc_warning (0, "The H format specifier at %L is"
1074 " a Fortran 95 deleted feature", &format_locus);
1075 }
1076 if (mode == MODE_STRING)
1077 {
1078 format_string += value;
1079 format_length -= value;
1080 format_string_pos += repeat;
1081 }
1082 else
1083 {
1084 while (repeat >0)
1085 {
1086 next_char (INSTRING_WARN);
1087 repeat -- ;
1088 }
1089 }
1090 break;
1091
1092 case FMT_IBOZ:
1093 t = format_lex ();
1094 if (t == FMT_ERROR)
1095 goto fail;
1096 if (t != FMT_ZERO && t != FMT_POSINT)
1097 {
1098 error = nonneg_required;
1099 goto syntax;
1100 }
1101 else if (is_input && t == FMT_ZERO)
1102 {
1103 error = posint_required;
1104 goto syntax;
1105 }
1106
1107 t = format_lex ();
1108 if (t == FMT_ERROR)
1109 goto fail;
1110 if (t != FMT_PERIOD)
1111 {
1112 saved_token = t;
1113 }
1114 else
1115 {
1116 t = format_lex ();
1117 if (t == FMT_ERROR)
1118 goto fail;
1119 if (t != FMT_ZERO && t != FMT_POSINT)
1120 {
1121 error = nonneg_required;
1122 goto syntax;
1123 }
1124 }
1125
1126 break;
1127
1128 default:
1129 error = unexpected_element;
1130 goto syntax;
1131 }
1132
1133 between_desc:
1134 /* Between a descriptor and what comes next. */
1135 t = format_lex ();
1136 if (t == FMT_ERROR)
1137 goto fail;
1138 switch (t)
1139 {
1140
1141 case FMT_COMMA:
1142 goto format_item;
1143
1144 case FMT_RPAREN:
1145 level--;
1146 if (level < 0)
1147 goto finished;
1148 goto between_desc;
1149
1150 case FMT_COLON:
1151 case FMT_SLASH:
1152 goto optional_comma;
1153
1154 case FMT_END:
1155 error = unexpected_end;
1156 goto syntax;
1157
1158 default:
1159 if (mode != MODE_FORMAT)
1160 format_locus.nextc += format_string_pos - 1;
1161 if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus))
1162 return false;
1163 /* If we do not actually return a failure, we need to unwind this
1164 before the next round. */
1165 if (mode != MODE_FORMAT)
1166 format_locus.nextc -= format_string_pos;
1167 goto format_item_1;
1168 }
1169
1170 optional_comma:
1171 /* Optional comma is a weird between state where we've just finished
1172 reading a colon, slash, dollar or P descriptor. */
1173 t = format_lex ();
1174 if (t == FMT_ERROR)
1175 goto fail;
1176 optional_comma_1:
1177 switch (t)
1178 {
1179 case FMT_COMMA:
1180 break;
1181
1182 case FMT_RPAREN:
1183 level--;
1184 if (level < 0)
1185 goto finished;
1186 goto between_desc;
1187
1188 default:
1189 /* Assume that we have another format item. */
1190 saved_token = t;
1191 break;
1192 }
1193
1194 goto format_item;
1195
1196 extension_optional_comma:
1197 /* As a GNU extension, permit a missing comma after a string literal. */
1198 t = format_lex ();
1199 if (t == FMT_ERROR)
1200 goto fail;
1201 switch (t)
1202 {
1203 case FMT_COMMA:
1204 break;
1205
1206 case FMT_RPAREN:
1207 level--;
1208 if (level < 0)
1209 goto finished;
1210 goto between_desc;
1211
1212 case FMT_COLON:
1213 case FMT_SLASH:
1214 goto optional_comma;
1215
1216 case FMT_END:
1217 error = unexpected_end;
1218 goto syntax;
1219
1220 default:
1221 if (mode != MODE_FORMAT)
1222 format_locus.nextc += format_string_pos;
1223 if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus))
1224 return false;
1225 /* If we do not actually return a failure, we need to unwind this
1226 before the next round. */
1227 if (mode != MODE_FORMAT)
1228 format_locus.nextc -= format_string_pos;
1229 saved_token = t;
1230 break;
1231 }
1232
1233 goto format_item;
1234
1235 syntax:
1236 if (mode != MODE_FORMAT)
1237 format_locus.nextc += format_string_pos;
1238 if (error == unexpected_element)
1239 gfc_error (error, error_element, &format_locus);
1240 else
1241 gfc_error ("%s in format string at %L", error, &format_locus);
1242 fail:
1243 rv = false;
1244
1245 finished:
1246 return rv;
1247 }
1248
1249
1250 /* Given an expression node that is a constant string, see if it looks
1251 like a format string. */
1252
1253 static bool
1254 check_format_string (gfc_expr *e, bool is_input)
1255 {
1256 bool rv;
1257 int i;
1258 if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1259 return true;
1260
1261 mode = MODE_STRING;
1262 format_string = e->value.character.string;
1263
1264 /* More elaborate measures are needed to show where a problem is within a
1265 format string that has been calculated, but that's probably not worth the
1266 effort. */
1267 format_locus = e->where;
1268 rv = check_format (is_input);
1269 /* check for extraneous characters at the end of an otherwise valid format
1270 string, like '(A10,I3)F5'
1271 start at the end and move back to the last character processed,
1272 spaces are OK */
1273 if (rv && e->value.character.length > format_string_pos)
1274 for (i=e->value.character.length-1;i>format_string_pos-1;i--)
1275 if (e->value.character.string[i] != ' ')
1276 {
1277 format_locus.nextc += format_length + 1;
1278 gfc_warning (0,
1279 "Extraneous characters in format at %L", &format_locus);
1280 break;
1281 }
1282 return rv;
1283 }
1284
1285
1286 /************ Fortran I/O statement matchers *************/
1287
1288 /* Match a FORMAT statement. This amounts to actually parsing the
1289 format descriptors in order to correctly locate the end of the
1290 format string. */
1291
1292 match
1293 gfc_match_format (void)
1294 {
1295 gfc_expr *e;
1296 locus start;
1297
1298 if (gfc_current_ns->proc_name
1299 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
1300 {
1301 gfc_error ("Format statement in module main block at %C");
1302 return MATCH_ERROR;
1303 }
1304
1305 /* Before parsing the rest of a FORMAT statement, check F2008:c1206. */
1306 if ((gfc_current_state () == COMP_FUNCTION
1307 || gfc_current_state () == COMP_SUBROUTINE)
1308 && gfc_state_stack->previous->state == COMP_INTERFACE)
1309 {
1310 gfc_error ("FORMAT statement at %C cannot appear within an INTERFACE");
1311 return MATCH_ERROR;
1312 }
1313
1314 if (gfc_statement_label == NULL)
1315 {
1316 gfc_error ("Missing format label at %C");
1317 return MATCH_ERROR;
1318 }
1319 gfc_gobble_whitespace ();
1320
1321 mode = MODE_FORMAT;
1322 format_length = 0;
1323
1324 start = gfc_current_locus;
1325
1326 if (!check_format (false))
1327 return MATCH_ERROR;
1328
1329 if (gfc_match_eos () != MATCH_YES)
1330 {
1331 gfc_syntax_error (ST_FORMAT);
1332 return MATCH_ERROR;
1333 }
1334
1335 /* The label doesn't get created until after the statement is done
1336 being matched, so we have to leave the string for later. */
1337
1338 gfc_current_locus = start; /* Back to the beginning */
1339
1340 new_st.loc = start;
1341 new_st.op = EXEC_NOP;
1342
1343 e = gfc_get_character_expr (gfc_default_character_kind, &start,
1344 NULL, format_length);
1345 format_string = e->value.character.string;
1346 gfc_statement_label->format = e;
1347
1348 mode = MODE_COPY;
1349 check_format (false); /* Guaranteed to succeed */
1350 gfc_match_eos (); /* Guaranteed to succeed */
1351
1352 return MATCH_YES;
1353 }
1354
1355
1356 /* Check for a CHARACTER variable. The check for scalar is done in
1357 resolve_tag. */
1358
1359 static bool
1360 check_char_variable (gfc_expr *e)
1361 {
1362 if (e->expr_type != EXPR_VARIABLE || e->ts.type != BT_CHARACTER)
1363 {
1364 gfc_error("IOMSG must be a scalar-default-char-variable at %L", &e->where);
1365 return false;
1366 }
1367 return true;
1368 }
1369
1370
1371 static bool
1372 is_char_type (const char *name, gfc_expr *e)
1373 {
1374 gfc_resolve_expr (e);
1375
1376 if (e->ts.type != BT_CHARACTER)
1377 {
1378 gfc_error ("%s requires a scalar-default-char-expr at %L",
1379 name, &e->where);
1380 return false;
1381 }
1382 return true;
1383 }
1384
1385
1386 /* Match an expression I/O tag of some sort. */
1387
1388 static match
1389 match_etag (const io_tag *tag, gfc_expr **v)
1390 {
1391 gfc_expr *result;
1392 match m;
1393
1394 m = gfc_match (tag->spec);
1395 if (m != MATCH_YES)
1396 return m;
1397
1398 m = gfc_match (tag->value, &result);
1399 if (m != MATCH_YES)
1400 {
1401 gfc_error ("Invalid value for %s specification at %C", tag->name);
1402 return MATCH_ERROR;
1403 }
1404
1405 if (*v != NULL)
1406 {
1407 gfc_error ("Duplicate %s specification at %C", tag->name);
1408 gfc_free_expr (result);
1409 return MATCH_ERROR;
1410 }
1411
1412 *v = result;
1413 return MATCH_YES;
1414 }
1415
1416
1417 /* Match a variable I/O tag of some sort. */
1418
1419 static match
1420 match_vtag (const io_tag *tag, gfc_expr **v)
1421 {
1422 gfc_expr *result;
1423 match m;
1424
1425 m = gfc_match (tag->spec);
1426 if (m != MATCH_YES)
1427 return m;
1428
1429 m = gfc_match (tag->value, &result);
1430 if (m != MATCH_YES)
1431 {
1432 gfc_error ("Invalid value for %s specification at %C", tag->name);
1433 return MATCH_ERROR;
1434 }
1435
1436 if (*v != NULL)
1437 {
1438 gfc_error ("Duplicate %s specification at %C", tag->name);
1439 gfc_free_expr (result);
1440 return MATCH_ERROR;
1441 }
1442
1443 if (result->symtree->n.sym->attr.intent == INTENT_IN)
1444 {
1445 gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag->name);
1446 gfc_free_expr (result);
1447 return MATCH_ERROR;
1448 }
1449
1450 bool impure = gfc_impure_variable (result->symtree->n.sym);
1451 if (impure && gfc_pure (NULL))
1452 {
1453 gfc_error ("Variable %s cannot be assigned in PURE procedure at %C",
1454 tag->name);
1455 gfc_free_expr (result);
1456 return MATCH_ERROR;
1457 }
1458
1459 if (impure)
1460 gfc_unset_implicit_pure (NULL);
1461
1462 *v = result;
1463 return MATCH_YES;
1464 }
1465
1466
1467 /* Match I/O tags that cause variables to become redefined. */
1468
1469 static match
1470 match_out_tag (const io_tag *tag, gfc_expr **result)
1471 {
1472 match m;
1473
1474 m = match_vtag (tag, result);
1475 if (m == MATCH_YES)
1476 gfc_check_do_variable ((*result)->symtree);
1477
1478 return m;
1479 }
1480
1481
1482 /* Match a label I/O tag. */
1483
1484 static match
1485 match_ltag (const io_tag *tag, gfc_st_label ** label)
1486 {
1487 match m;
1488 gfc_st_label *old;
1489
1490 old = *label;
1491 m = gfc_match (tag->spec);
1492 if (m != MATCH_YES)
1493 return m;
1494
1495 m = gfc_match (tag->value, label);
1496 if (m != MATCH_YES)
1497 {
1498 gfc_error ("Invalid value for %s specification at %C", tag->name);
1499 return MATCH_ERROR;
1500 }
1501
1502 if (old)
1503 {
1504 gfc_error ("Duplicate %s label specification at %C", tag->name);
1505 return MATCH_ERROR;
1506 }
1507
1508 if (!gfc_reference_st_label (*label, ST_LABEL_TARGET))
1509 return MATCH_ERROR;
1510
1511 return m;
1512 }
1513
1514
1515 /* Match a tag using match_etag, but only if -fdec is enabled. */
1516 static match
1517 match_dec_etag (const io_tag *tag, gfc_expr **e)
1518 {
1519 match m = match_etag (tag, e);
1520 if (flag_dec && m != MATCH_NO)
1521 return m;
1522 else if (m != MATCH_NO)
1523 {
1524 gfc_error ("%s at %C is a DEC extension, enable with "
1525 "%<-fdec%>", tag->name);
1526 return MATCH_ERROR;
1527 }
1528 return m;
1529 }
1530
1531
1532 /* Match a tag using match_vtag, but only if -fdec is enabled. */
1533 static match
1534 match_dec_vtag (const io_tag *tag, gfc_expr **e)
1535 {
1536 match m = match_vtag(tag, e);
1537 if (flag_dec && m != MATCH_NO)
1538 return m;
1539 else if (m != MATCH_NO)
1540 {
1541 gfc_error ("%s at %C is a DEC extension, enable with "
1542 "%<-fdec%>", tag->name);
1543 return MATCH_ERROR;
1544 }
1545 return m;
1546 }
1547
1548
1549 /* Match a DEC I/O flag tag - a tag with no expression such as READONLY. */
1550
1551 static match
1552 match_dec_ftag (const io_tag *tag, gfc_open *o)
1553 {
1554 match m;
1555
1556 m = gfc_match (tag->spec);
1557 if (m != MATCH_YES)
1558 return m;
1559
1560 if (!flag_dec)
1561 {
1562 gfc_error ("%s at %C is a DEC extension, enable with "
1563 "%<-fdec%>", tag->name);
1564 return MATCH_ERROR;
1565 }
1566
1567 /* Just set the READONLY flag, which we use at runtime to avoid delete on
1568 close. */
1569 if (tag == &tag_readonly)
1570 {
1571 o->readonly |= 1;
1572 return MATCH_YES;
1573 }
1574
1575 /* Interpret SHARED as SHARE='DENYNONE' (read lock). */
1576 else if (tag == &tag_shared)
1577 {
1578 if (o->share != NULL)
1579 {
1580 gfc_error ("Duplicate %s specification at %C", tag->name);
1581 return MATCH_ERROR;
1582 }
1583 o->share = gfc_get_character_expr (gfc_default_character_kind,
1584 &gfc_current_locus, "denynone", 8);
1585 return MATCH_YES;
1586 }
1587
1588 /* Interpret NOSHARED as SHARE='DENYRW' (exclusive lock). */
1589 else if (tag == &tag_noshared)
1590 {
1591 if (o->share != NULL)
1592 {
1593 gfc_error ("Duplicate %s specification at %C", tag->name);
1594 return MATCH_ERROR;
1595 }
1596 o->share = gfc_get_character_expr (gfc_default_character_kind,
1597 &gfc_current_locus, "denyrw", 6);
1598 return MATCH_YES;
1599 }
1600
1601 /* We handle all DEC tags above. */
1602 gcc_unreachable ();
1603 }
1604
1605
1606 /* Resolution of the FORMAT tag, to be called from resolve_tag. */
1607
1608 static bool
1609 resolve_tag_format (const gfc_expr *e)
1610 {
1611 if (e->expr_type == EXPR_CONSTANT
1612 && (e->ts.type != BT_CHARACTER
1613 || e->ts.kind != gfc_default_character_kind))
1614 {
1615 gfc_error ("Constant expression in FORMAT tag at %L must be "
1616 "of type default CHARACTER", &e->where);
1617 return false;
1618 }
1619
1620 /* If e's rank is zero and e is not an element of an array, it should be
1621 of integer or character type. The integer variable should be
1622 ASSIGNED. */
1623 if (e->rank == 0
1624 && (e->expr_type != EXPR_VARIABLE
1625 || e->symtree == NULL
1626 || e->symtree->n.sym->as == NULL
1627 || e->symtree->n.sym->as->rank == 0))
1628 {
1629 if ((e->ts.type != BT_CHARACTER
1630 || e->ts.kind != gfc_default_character_kind)
1631 && e->ts.type != BT_INTEGER)
1632 {
1633 gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER "
1634 "or of INTEGER", &e->where);
1635 return false;
1636 }
1637 else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
1638 {
1639 if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGNED variable in "
1640 "FORMAT tag at %L", &e->where))
1641 return false;
1642 if (e->symtree->n.sym->attr.assign != 1)
1643 {
1644 gfc_error ("Variable %qs at %L has not been assigned a "
1645 "format label", e->symtree->n.sym->name, &e->where);
1646 return false;
1647 }
1648 }
1649 else if (e->ts.type == BT_INTEGER)
1650 {
1651 gfc_error ("Scalar %qs in FORMAT tag at %L is not an ASSIGNED "
1652 "variable", gfc_basic_typename (e->ts.type), &e->where);
1653 return false;
1654 }
1655
1656 return true;
1657 }
1658
1659 /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
1660 It may be assigned an Hollerith constant. */
1661 if (e->ts.type != BT_CHARACTER)
1662 {
1663 if (!gfc_notify_std (GFC_STD_LEGACY, "Non-character in FORMAT tag "
1664 "at %L", &e->where))
1665 return false;
1666
1667 if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)
1668 {
1669 gfc_error ("Non-character assumed shape array element in FORMAT"
1670 " tag at %L", &e->where);
1671 return false;
1672 }
1673
1674 if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
1675 {
1676 gfc_error ("Non-character assumed size array element in FORMAT"
1677 " tag at %L", &e->where);
1678 return false;
1679 }
1680
1681 if (e->rank == 0 && e->symtree->n.sym->attr.pointer)
1682 {
1683 gfc_error ("Non-character pointer array element in FORMAT tag at %L",
1684 &e->where);
1685 return false;
1686 }
1687 }
1688
1689 return true;
1690 }
1691
1692
1693 /* Do expression resolution and type-checking on an expression tag. */
1694
1695 static bool
1696 resolve_tag (const io_tag *tag, gfc_expr *e)
1697 {
1698 if (e == NULL)
1699 return true;
1700
1701 if (!gfc_resolve_expr (e))
1702 return false;
1703
1704 if (tag == &tag_format)
1705 return resolve_tag_format (e);
1706
1707 if (e->ts.type != tag->type)
1708 {
1709 gfc_error ("%s tag at %L must be of type %s", tag->name,
1710 &e->where, gfc_basic_typename (tag->type));
1711 return false;
1712 }
1713
1714 if (e->ts.type == BT_CHARACTER && e->ts.kind != gfc_default_character_kind)
1715 {
1716 gfc_error ("%s tag at %L must be a character string of default kind",
1717 tag->name, &e->where);
1718 return false;
1719 }
1720
1721 if (e->rank != 0)
1722 {
1723 gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
1724 return false;
1725 }
1726
1727 if (tag == &tag_iomsg)
1728 {
1729 if (!gfc_notify_std (GFC_STD_F2003, "IOMSG tag at %L", &e->where))
1730 return false;
1731 }
1732
1733 if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength
1734 || tag == &tag_number || tag == &tag_nextrec || tag == &tag_s_recl)
1735 && e->ts.kind != gfc_default_integer_kind)
1736 {
1737 if (!gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
1738 "INTEGER in %s tag at %L", tag->name, &e->where))
1739 return false;
1740 }
1741
1742 if (e->ts.kind != gfc_default_logical_kind &&
1743 (tag == &tag_exist || tag == &tag_named || tag == &tag_opened
1744 || tag == &tag_pending))
1745 {
1746 if (!gfc_notify_std (GFC_STD_F2008, "Non-default LOGICAL kind "
1747 "in %s tag at %L", tag->name, &e->where))
1748 return false;
1749 }
1750
1751 if (tag == &tag_newunit)
1752 {
1753 if (!gfc_notify_std (GFC_STD_F2008, "NEWUNIT specifier at %L",
1754 &e->where))
1755 return false;
1756 }
1757
1758 /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */
1759 if (tag == &tag_newunit || tag == &tag_iostat
1760 || tag == &tag_size || tag == &tag_iomsg)
1761 {
1762 char context[64];
1763
1764 sprintf (context, _("%s tag"), tag->name);
1765 if (!gfc_check_vardef_context (e, false, false, false, context))
1766 return false;
1767 }
1768
1769 if (tag == &tag_convert)
1770 {
1771 if (!gfc_notify_std (GFC_STD_GNU, "CONVERT tag at %L", &e->where))
1772 return false;
1773 }
1774
1775 return true;
1776 }
1777
1778
1779 /* Match a single tag of an OPEN statement. */
1780
1781 static match
1782 match_open_element (gfc_open *open)
1783 {
1784 match m;
1785
1786 m = match_etag (&tag_e_async, &open->asynchronous);
1787 if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", open->asynchronous))
1788 return MATCH_ERROR;
1789 if (m != MATCH_NO)
1790 return m;
1791 m = match_etag (&tag_unit, &open->unit);
1792 if (m != MATCH_NO)
1793 return m;
1794 m = match_etag (&tag_iomsg, &open->iomsg);
1795 if (m == MATCH_YES && !check_char_variable (open->iomsg))
1796 return MATCH_ERROR;
1797 if (m != MATCH_NO)
1798 return m;
1799 m = match_out_tag (&tag_iostat, &open->iostat);
1800 if (m != MATCH_NO)
1801 return m;
1802 m = match_etag (&tag_file, &open->file);
1803 if (m != MATCH_NO)
1804 return m;
1805 m = match_etag (&tag_status, &open->status);
1806 if (m != MATCH_NO)
1807 return m;
1808 m = match_etag (&tag_e_access, &open->access);
1809 if (m != MATCH_NO)
1810 return m;
1811 m = match_etag (&tag_e_form, &open->form);
1812 if (m != MATCH_NO)
1813 return m;
1814 m = match_etag (&tag_e_recl, &open->recl);
1815 if (m != MATCH_NO)
1816 return m;
1817 m = match_etag (&tag_e_blank, &open->blank);
1818 if (m != MATCH_NO)
1819 return m;
1820 m = match_etag (&tag_e_position, &open->position);
1821 if (m != MATCH_NO)
1822 return m;
1823 m = match_etag (&tag_e_action, &open->action);
1824 if (m != MATCH_NO)
1825 return m;
1826 m = match_etag (&tag_e_delim, &open->delim);
1827 if (m != MATCH_NO)
1828 return m;
1829 m = match_etag (&tag_e_pad, &open->pad);
1830 if (m != MATCH_NO)
1831 return m;
1832 m = match_etag (&tag_e_decimal, &open->decimal);
1833 if (m != MATCH_NO)
1834 return m;
1835 m = match_etag (&tag_e_encoding, &open->encoding);
1836 if (m != MATCH_NO)
1837 return m;
1838 m = match_etag (&tag_e_round, &open->round);
1839 if (m != MATCH_NO)
1840 return m;
1841 m = match_etag (&tag_e_sign, &open->sign);
1842 if (m != MATCH_NO)
1843 return m;
1844 m = match_ltag (&tag_err, &open->err);
1845 if (m != MATCH_NO)
1846 return m;
1847 m = match_etag (&tag_convert, &open->convert);
1848 if (m != MATCH_NO)
1849 return m;
1850 m = match_out_tag (&tag_newunit, &open->newunit);
1851 if (m != MATCH_NO)
1852 return m;
1853
1854 /* The following are extensions enabled with -fdec. */
1855 m = match_dec_etag (&tag_e_share, &open->share);
1856 if (m != MATCH_NO)
1857 return m;
1858 m = match_dec_etag (&tag_cc, &open->cc);
1859 if (m != MATCH_NO)
1860 return m;
1861 m = match_dec_ftag (&tag_readonly, open);
1862 if (m != MATCH_NO)
1863 return m;
1864 m = match_dec_ftag (&tag_shared, open);
1865 if (m != MATCH_NO)
1866 return m;
1867 m = match_dec_ftag (&tag_noshared, open);
1868 if (m != MATCH_NO)
1869 return m;
1870
1871 return MATCH_NO;
1872 }
1873
1874
1875 /* Free the gfc_open structure and all the expressions it contains. */
1876
1877 void
1878 gfc_free_open (gfc_open *open)
1879 {
1880 if (open == NULL)
1881 return;
1882
1883 gfc_free_expr (open->unit);
1884 gfc_free_expr (open->iomsg);
1885 gfc_free_expr (open->iostat);
1886 gfc_free_expr (open->file);
1887 gfc_free_expr (open->status);
1888 gfc_free_expr (open->access);
1889 gfc_free_expr (open->form);
1890 gfc_free_expr (open->recl);
1891 gfc_free_expr (open->blank);
1892 gfc_free_expr (open->position);
1893 gfc_free_expr (open->action);
1894 gfc_free_expr (open->delim);
1895 gfc_free_expr (open->pad);
1896 gfc_free_expr (open->decimal);
1897 gfc_free_expr (open->encoding);
1898 gfc_free_expr (open->round);
1899 gfc_free_expr (open->sign);
1900 gfc_free_expr (open->convert);
1901 gfc_free_expr (open->asynchronous);
1902 gfc_free_expr (open->newunit);
1903 gfc_free_expr (open->share);
1904 gfc_free_expr (open->cc);
1905 free (open);
1906 }
1907
1908
1909 /* Resolve everything in a gfc_open structure. */
1910
1911 bool
1912 gfc_resolve_open (gfc_open *open)
1913 {
1914
1915 RESOLVE_TAG (&tag_unit, open->unit);
1916 RESOLVE_TAG (&tag_iomsg, open->iomsg);
1917 RESOLVE_TAG (&tag_iostat, open->iostat);
1918 RESOLVE_TAG (&tag_file, open->file);
1919 RESOLVE_TAG (&tag_status, open->status);
1920 RESOLVE_TAG (&tag_e_access, open->access);
1921 RESOLVE_TAG (&tag_e_form, open->form);
1922 RESOLVE_TAG (&tag_e_recl, open->recl);
1923 RESOLVE_TAG (&tag_e_blank, open->blank);
1924 RESOLVE_TAG (&tag_e_position, open->position);
1925 RESOLVE_TAG (&tag_e_action, open->action);
1926 RESOLVE_TAG (&tag_e_delim, open->delim);
1927 RESOLVE_TAG (&tag_e_pad, open->pad);
1928 RESOLVE_TAG (&tag_e_decimal, open->decimal);
1929 RESOLVE_TAG (&tag_e_encoding, open->encoding);
1930 RESOLVE_TAG (&tag_e_async, open->asynchronous);
1931 RESOLVE_TAG (&tag_e_round, open->round);
1932 RESOLVE_TAG (&tag_e_sign, open->sign);
1933 RESOLVE_TAG (&tag_convert, open->convert);
1934 RESOLVE_TAG (&tag_newunit, open->newunit);
1935 RESOLVE_TAG (&tag_e_share, open->share);
1936 RESOLVE_TAG (&tag_cc, open->cc);
1937
1938 if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET))
1939 return false;
1940
1941 return true;
1942 }
1943
1944
1945 /* Check if a given value for a SPECIFIER is either in the list of values
1946 allowed in F95 or F2003, issuing an error message and returning a zero
1947 value if it is not allowed. */
1948
1949 static int
1950 compare_to_allowed_values (const char *specifier, const char *allowed[],
1951 const char *allowed_f2003[],
1952 const char *allowed_gnu[], gfc_char_t *value,
1953 const char *statement, bool warn,
1954 int *num = NULL);
1955
1956
1957 static int
1958 compare_to_allowed_values (const char *specifier, const char *allowed[],
1959 const char *allowed_f2003[],
1960 const char *allowed_gnu[], gfc_char_t *value,
1961 const char *statement, bool warn, int *num)
1962 {
1963 int i;
1964 unsigned int len;
1965
1966 len = gfc_wide_strlen (value);
1967 if (len > 0)
1968 {
1969 for (len--; len > 0; len--)
1970 if (value[len] != ' ')
1971 break;
1972 len++;
1973 }
1974
1975 for (i = 0; allowed[i]; i++)
1976 if (len == strlen (allowed[i])
1977 && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
1978 {
1979 if (num)
1980 *num = i;
1981 return 1;
1982 }
1983
1984 for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
1985 if (len == strlen (allowed_f2003[i])
1986 && gfc_wide_strncasecmp (value, allowed_f2003[i],
1987 strlen (allowed_f2003[i])) == 0)
1988 {
1989 notification n = gfc_notification_std (GFC_STD_F2003);
1990
1991 if (n == WARNING || (warn && n == ERROR))
1992 {
1993 gfc_warning (0, "Fortran 2003: %s specifier in %s statement at %C "
1994 "has value %qs", specifier, statement,
1995 allowed_f2003[i]);
1996 return 1;
1997 }
1998 else
1999 if (n == ERROR)
2000 {
2001 gfc_notify_std (GFC_STD_F2003, "%s specifier in "
2002 "%s statement at %C has value %qs", specifier,
2003 statement, allowed_f2003[i]);
2004 return 0;
2005 }
2006
2007 /* n == SILENT */
2008 return 1;
2009 }
2010
2011 for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
2012 if (len == strlen (allowed_gnu[i])
2013 && gfc_wide_strncasecmp (value, allowed_gnu[i],
2014 strlen (allowed_gnu[i])) == 0)
2015 {
2016 notification n = gfc_notification_std (GFC_STD_GNU);
2017
2018 if (n == WARNING || (warn && n == ERROR))
2019 {
2020 gfc_warning (0, "Extension: %s specifier in %s statement at %C "
2021 "has value %qs", specifier, statement,
2022 allowed_gnu[i]);
2023 return 1;
2024 }
2025 else
2026 if (n == ERROR)
2027 {
2028 gfc_notify_std (GFC_STD_GNU, "%s specifier in "
2029 "%s statement at %C has value %qs", specifier,
2030 statement, allowed_gnu[i]);
2031 return 0;
2032 }
2033
2034 /* n == SILENT */
2035 return 1;
2036 }
2037
2038 if (warn)
2039 {
2040 char *s = gfc_widechar_to_char (value, -1);
2041 gfc_warning (0,
2042 "%s specifier in %s statement at %C has invalid value %qs",
2043 specifier, statement, s);
2044 free (s);
2045 return 1;
2046 }
2047 else
2048 {
2049 char *s = gfc_widechar_to_char (value, -1);
2050 gfc_error ("%s specifier in %s statement at %C has invalid value %qs",
2051 specifier, statement, s);
2052 free (s);
2053 return 0;
2054 }
2055 }
2056
2057
2058 /* Match an OPEN statement. */
2059
2060 match
2061 gfc_match_open (void)
2062 {
2063 gfc_open *open;
2064 match m;
2065 bool warn;
2066
2067 m = gfc_match_char ('(');
2068 if (m == MATCH_NO)
2069 return m;
2070
2071 open = XCNEW (gfc_open);
2072
2073 m = match_open_element (open);
2074
2075 if (m == MATCH_ERROR)
2076 goto cleanup;
2077 if (m == MATCH_NO)
2078 {
2079 m = gfc_match_expr (&open->unit);
2080 if (m == MATCH_ERROR)
2081 goto cleanup;
2082 }
2083
2084 for (;;)
2085 {
2086 if (gfc_match_char (')') == MATCH_YES)
2087 break;
2088 if (gfc_match_char (',') != MATCH_YES)
2089 goto syntax;
2090
2091 m = match_open_element (open);
2092 if (m == MATCH_ERROR)
2093 goto cleanup;
2094 if (m == MATCH_NO)
2095 goto syntax;
2096 }
2097
2098 if (gfc_match_eos () == MATCH_NO)
2099 goto syntax;
2100
2101 if (gfc_pure (NULL))
2102 {
2103 gfc_error ("OPEN statement not allowed in PURE procedure at %C");
2104 goto cleanup;
2105 }
2106
2107 gfc_unset_implicit_pure (NULL);
2108
2109 warn = (open->err || open->iostat) ? true : false;
2110
2111 /* Checks on NEWUNIT specifier. */
2112 if (open->newunit)
2113 {
2114 if (open->unit)
2115 {
2116 gfc_error ("UNIT specifier not allowed with NEWUNIT at %C");
2117 goto cleanup;
2118 }
2119
2120 if (!open->file && open->status)
2121 {
2122 if (open->status->expr_type == EXPR_CONSTANT
2123 && gfc_wide_strncasecmp (open->status->value.character.string,
2124 "scratch", 7) != 0)
2125 {
2126 gfc_error ("NEWUNIT specifier must have FILE= "
2127 "or STATUS='scratch' at %C");
2128 goto cleanup;
2129 }
2130 }
2131 }
2132 else if (!open->unit)
2133 {
2134 gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified");
2135 goto cleanup;
2136 }
2137
2138 /* Checks on the ACCESS specifier. */
2139 if (open->access && open->access->expr_type == EXPR_CONSTANT)
2140 {
2141 static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
2142 static const char *access_f2003[] = { "STREAM", NULL };
2143 static const char *access_gnu[] = { "APPEND", NULL };
2144
2145 if (!is_char_type ("ACCESS", open->access))
2146 goto cleanup;
2147
2148 if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
2149 access_gnu,
2150 open->access->value.character.string,
2151 "OPEN", warn))
2152 goto cleanup;
2153 }
2154
2155 /* Checks on the ACTION specifier. */
2156 if (open->action && open->action->expr_type == EXPR_CONSTANT)
2157 {
2158 gfc_char_t *str = open->action->value.character.string;
2159 static const char *action[] = { "READ", "WRITE", "READWRITE", NULL };
2160
2161 if (!is_char_type ("ACTION", open->action))
2162 goto cleanup;
2163
2164 if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
2165 str, "OPEN", warn))
2166 goto cleanup;
2167
2168 /* With READONLY, only allow ACTION='READ'. */
2169 if (open->readonly && (gfc_wide_strlen (str) != 4
2170 || gfc_wide_strncasecmp (str, "READ", 4) != 0))
2171 {
2172 gfc_error ("ACTION type conflicts with READONLY specifier at %C");
2173 goto cleanup;
2174 }
2175 }
2176 /* If we see READONLY and no ACTION, set ACTION='READ'. */
2177 else if (open->readonly && open->action == NULL)
2178 {
2179 open->action = gfc_get_character_expr (gfc_default_character_kind,
2180 &gfc_current_locus, "read", 4);
2181 }
2182
2183 /* Checks on the ASYNCHRONOUS specifier. */
2184 if (open->asynchronous)
2185 {
2186 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %C "
2187 "not allowed in Fortran 95"))
2188 goto cleanup;
2189
2190 if (!is_char_type ("ASYNCHRONOUS", open->asynchronous))
2191 goto cleanup;
2192
2193 if (open->asynchronous->expr_type == EXPR_CONSTANT)
2194 {
2195 static const char * asynchronous[] = { "YES", "NO", NULL };
2196
2197 if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous,
2198 NULL, NULL, open->asynchronous->value.character.string,
2199 "OPEN", warn))
2200 goto cleanup;
2201 }
2202 }
2203
2204 /* Checks on the BLANK specifier. */
2205 if (open->blank)
2206 {
2207 if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C "
2208 "not allowed in Fortran 95"))
2209 goto cleanup;
2210
2211 if (!is_char_type ("BLANK", open->blank))
2212 goto cleanup;
2213
2214 if (open->blank->expr_type == EXPR_CONSTANT)
2215 {
2216 static const char *blank[] = { "ZERO", "NULL", NULL };
2217
2218 if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
2219 open->blank->value.character.string,
2220 "OPEN", warn))
2221 goto cleanup;
2222 }
2223 }
2224
2225 /* Checks on the CARRIAGECONTROL specifier. */
2226 if (open->cc)
2227 {
2228 if (!is_char_type ("CARRIAGECONTROL", open->cc))
2229 goto cleanup;
2230
2231 if (open->cc->expr_type == EXPR_CONSTANT)
2232 {
2233 static const char *cc[] = { "LIST", "FORTRAN", "NONE", NULL };
2234 if (!compare_to_allowed_values ("CARRIAGECONTROL", cc, NULL, NULL,
2235 open->cc->value.character.string,
2236 "OPEN", warn))
2237 goto cleanup;
2238 }
2239 }
2240
2241 /* Checks on the DECIMAL specifier. */
2242 if (open->decimal)
2243 {
2244 if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C "
2245 "not allowed in Fortran 95"))
2246 goto cleanup;
2247
2248 if (!is_char_type ("DECIMAL", open->decimal))
2249 goto cleanup;
2250
2251 if (open->decimal->expr_type == EXPR_CONSTANT)
2252 {
2253 static const char * decimal[] = { "COMMA", "POINT", NULL };
2254
2255 if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
2256 open->decimal->value.character.string,
2257 "OPEN", warn))
2258 goto cleanup;
2259 }
2260 }
2261
2262 /* Checks on the DELIM specifier. */
2263 if (open->delim)
2264 {
2265 if (open->delim->expr_type == EXPR_CONSTANT)
2266 {
2267 static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
2268
2269 if (!is_char_type ("DELIM", open->delim))
2270 goto cleanup;
2271
2272 if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
2273 open->delim->value.character.string,
2274 "OPEN", warn))
2275 goto cleanup;
2276 }
2277 }
2278
2279 /* Checks on the ENCODING specifier. */
2280 if (open->encoding)
2281 {
2282 if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %C "
2283 "not allowed in Fortran 95"))
2284 goto cleanup;
2285
2286 if (!is_char_type ("ENCODING", open->encoding))
2287 goto cleanup;
2288
2289 if (open->encoding->expr_type == EXPR_CONSTANT)
2290 {
2291 static const char * encoding[] = { "DEFAULT", "UTF-8", NULL };
2292
2293 if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
2294 open->encoding->value.character.string,
2295 "OPEN", warn))
2296 goto cleanup;
2297 }
2298 }
2299
2300 /* Checks on the FORM specifier. */
2301 if (open->form && open->form->expr_type == EXPR_CONSTANT)
2302 {
2303 static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
2304
2305 if (!is_char_type ("FORM", open->form))
2306 goto cleanup;
2307
2308 if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
2309 open->form->value.character.string,
2310 "OPEN", warn))
2311 goto cleanup;
2312 }
2313
2314 /* Checks on the PAD specifier. */
2315 if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
2316 {
2317 static const char *pad[] = { "YES", "NO", NULL };
2318
2319 if (!is_char_type ("PAD", open->pad))
2320 goto cleanup;
2321
2322 if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
2323 open->pad->value.character.string,
2324 "OPEN", warn))
2325 goto cleanup;
2326 }
2327
2328 /* Checks on the POSITION specifier. */
2329 if (open->position && open->position->expr_type == EXPR_CONSTANT)
2330 {
2331 static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
2332
2333 if (!is_char_type ("POSITION", open->position))
2334 goto cleanup;
2335
2336 if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
2337 open->position->value.character.string,
2338 "OPEN", warn))
2339 goto cleanup;
2340 }
2341
2342 /* Checks on the ROUND specifier. */
2343 if (open->round)
2344 {
2345 if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C "
2346 "not allowed in Fortran 95"))
2347 goto cleanup;
2348
2349 if (!is_char_type ("ROUND", open->round))
2350 goto cleanup;
2351
2352 if (open->round->expr_type == EXPR_CONSTANT)
2353 {
2354 static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
2355 "COMPATIBLE", "PROCESSOR_DEFINED",
2356 NULL };
2357
2358 if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
2359 open->round->value.character.string,
2360 "OPEN", warn))
2361 goto cleanup;
2362 }
2363 }
2364
2365 /* Checks on the SHARE specifier. */
2366 if (open->share)
2367 {
2368 if (!is_char_type ("SHARE", open->share))
2369 goto cleanup;
2370
2371 if (open->share->expr_type == EXPR_CONSTANT)
2372 {
2373 static const char *share[] = { "DENYNONE", "DENYRW", NULL };
2374 if (!compare_to_allowed_values ("SHARE", share, NULL, NULL,
2375 open->share->value.character.string,
2376 "OPEN", warn))
2377 goto cleanup;
2378 }
2379 }
2380
2381 /* Checks on the SIGN specifier. */
2382 if (open->sign)
2383 {
2384 if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %C "
2385 "not allowed in Fortran 95"))
2386 goto cleanup;
2387
2388 if (!is_char_type ("SIGN", open->sign))
2389 goto cleanup;
2390
2391 if (open->sign->expr_type == EXPR_CONSTANT)
2392 {
2393 static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
2394 NULL };
2395
2396 if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
2397 open->sign->value.character.string,
2398 "OPEN", warn))
2399 goto cleanup;
2400 }
2401 }
2402
2403 #define warn_or_error(...) \
2404 { \
2405 if (warn) \
2406 gfc_warning (0, __VA_ARGS__); \
2407 else \
2408 { \
2409 gfc_error (__VA_ARGS__); \
2410 goto cleanup; \
2411 } \
2412 }
2413
2414 /* Checks on the RECL specifier. */
2415 if (open->recl && open->recl->expr_type == EXPR_CONSTANT
2416 && open->recl->ts.type == BT_INTEGER
2417 && mpz_sgn (open->recl->value.integer) != 1)
2418 {
2419 warn_or_error ("RECL in OPEN statement at %C must be positive");
2420 }
2421
2422 /* Checks on the STATUS specifier. */
2423 if (open->status && open->status->expr_type == EXPR_CONSTANT)
2424 {
2425 static const char *status[] = { "OLD", "NEW", "SCRATCH",
2426 "REPLACE", "UNKNOWN", NULL };
2427
2428 if (!is_char_type ("STATUS", open->status))
2429 goto cleanup;
2430
2431 if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2432 open->status->value.character.string,
2433 "OPEN", warn))
2434 goto cleanup;
2435
2436 /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2437 the FILE= specifier shall appear. */
2438 if (open->file == NULL
2439 && (gfc_wide_strncasecmp (open->status->value.character.string,
2440 "replace", 7) == 0
2441 || gfc_wide_strncasecmp (open->status->value.character.string,
2442 "new", 3) == 0))
2443 {
2444 char *s = gfc_widechar_to_char (open->status->value.character.string,
2445 -1);
2446 warn_or_error ("The STATUS specified in OPEN statement at %C is "
2447 "%qs and no FILE specifier is present", s);
2448 free (s);
2449 }
2450
2451 /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2452 the FILE= specifier shall not appear. */
2453 if (gfc_wide_strncasecmp (open->status->value.character.string,
2454 "scratch", 7) == 0 && open->file)
2455 {
2456 warn_or_error ("The STATUS specified in OPEN statement at %C "
2457 "cannot have the value SCRATCH if a FILE specifier "
2458 "is present");
2459 }
2460 }
2461
2462 /* Things that are not allowed for unformatted I/O. */
2463 if (open->form && open->form->expr_type == EXPR_CONSTANT
2464 && (open->delim || open->decimal || open->encoding || open->round
2465 || open->sign || open->pad || open->blank)
2466 && gfc_wide_strncasecmp (open->form->value.character.string,
2467 "unformatted", 11) == 0)
2468 {
2469 const char *spec = (open->delim ? "DELIM "
2470 : (open->pad ? "PAD " : open->blank
2471 ? "BLANK " : ""));
2472
2473 warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
2474 "unformatted I/O", spec);
2475 }
2476
2477 if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
2478 && gfc_wide_strncasecmp (open->access->value.character.string,
2479 "stream", 6) == 0)
2480 {
2481 warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
2482 "stream I/O");
2483 }
2484
2485 if (open->position
2486 && open->access && open->access->expr_type == EXPR_CONSTANT
2487 && !(gfc_wide_strncasecmp (open->access->value.character.string,
2488 "sequential", 10) == 0
2489 || gfc_wide_strncasecmp (open->access->value.character.string,
2490 "stream", 6) == 0
2491 || gfc_wide_strncasecmp (open->access->value.character.string,
2492 "append", 6) == 0))
2493 {
2494 warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
2495 "for stream or sequential ACCESS");
2496 }
2497
2498 #undef warn_or_error
2499
2500 new_st.op = EXEC_OPEN;
2501 new_st.ext.open = open;
2502 return MATCH_YES;
2503
2504 syntax:
2505 gfc_syntax_error (ST_OPEN);
2506
2507 cleanup:
2508 gfc_free_open (open);
2509 return MATCH_ERROR;
2510 }
2511
2512
2513 /* Free a gfc_close structure an all its expressions. */
2514
2515 void
2516 gfc_free_close (gfc_close *close)
2517 {
2518 if (close == NULL)
2519 return;
2520
2521 gfc_free_expr (close->unit);
2522 gfc_free_expr (close->iomsg);
2523 gfc_free_expr (close->iostat);
2524 gfc_free_expr (close->status);
2525 free (close);
2526 }
2527
2528
2529 /* Match elements of a CLOSE statement. */
2530
2531 static match
2532 match_close_element (gfc_close *close)
2533 {
2534 match m;
2535
2536 m = match_etag (&tag_unit, &close->unit);
2537 if (m != MATCH_NO)
2538 return m;
2539 m = match_etag (&tag_status, &close->status);
2540 if (m != MATCH_NO)
2541 return m;
2542 m = match_etag (&tag_iomsg, &close->iomsg);
2543 if (m == MATCH_YES && !check_char_variable (close->iomsg))
2544 return MATCH_ERROR;
2545 if (m != MATCH_NO)
2546 return m;
2547 m = match_out_tag (&tag_iostat, &close->iostat);
2548 if (m != MATCH_NO)
2549 return m;
2550 m = match_ltag (&tag_err, &close->err);
2551 if (m != MATCH_NO)
2552 return m;
2553
2554 return MATCH_NO;
2555 }
2556
2557
2558 /* Match a CLOSE statement. */
2559
2560 match
2561 gfc_match_close (void)
2562 {
2563 gfc_close *close;
2564 match m;
2565 bool warn;
2566
2567 m = gfc_match_char ('(');
2568 if (m == MATCH_NO)
2569 return m;
2570
2571 close = XCNEW (gfc_close);
2572
2573 m = match_close_element (close);
2574
2575 if (m == MATCH_ERROR)
2576 goto cleanup;
2577 if (m == MATCH_NO)
2578 {
2579 m = gfc_match_expr (&close->unit);
2580 if (m == MATCH_NO)
2581 goto syntax;
2582 if (m == MATCH_ERROR)
2583 goto cleanup;
2584 }
2585
2586 for (;;)
2587 {
2588 if (gfc_match_char (')') == MATCH_YES)
2589 break;
2590 if (gfc_match_char (',') != MATCH_YES)
2591 goto syntax;
2592
2593 m = match_close_element (close);
2594 if (m == MATCH_ERROR)
2595 goto cleanup;
2596 if (m == MATCH_NO)
2597 goto syntax;
2598 }
2599
2600 if (gfc_match_eos () == MATCH_NO)
2601 goto syntax;
2602
2603 if (gfc_pure (NULL))
2604 {
2605 gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2606 goto cleanup;
2607 }
2608
2609 gfc_unset_implicit_pure (NULL);
2610
2611 warn = (close->iostat || close->err) ? true : false;
2612
2613 /* Checks on the STATUS specifier. */
2614 if (close->status && close->status->expr_type == EXPR_CONSTANT)
2615 {
2616 static const char *status[] = { "KEEP", "DELETE", NULL };
2617
2618 if (!is_char_type ("STATUS", close->status))
2619 goto cleanup;
2620
2621 if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2622 close->status->value.character.string,
2623 "CLOSE", warn))
2624 goto cleanup;
2625 }
2626
2627 new_st.op = EXEC_CLOSE;
2628 new_st.ext.close = close;
2629 return MATCH_YES;
2630
2631 syntax:
2632 gfc_syntax_error (ST_CLOSE);
2633
2634 cleanup:
2635 gfc_free_close (close);
2636 return MATCH_ERROR;
2637 }
2638
2639
2640 /* Resolve everything in a gfc_close structure. */
2641
2642 bool
2643 gfc_resolve_close (gfc_close *close)
2644 {
2645 RESOLVE_TAG (&tag_unit, close->unit);
2646 RESOLVE_TAG (&tag_iomsg, close->iomsg);
2647 RESOLVE_TAG (&tag_iostat, close->iostat);
2648 RESOLVE_TAG (&tag_status, close->status);
2649
2650 if (!gfc_reference_st_label (close->err, ST_LABEL_TARGET))
2651 return false;
2652
2653 if (close->unit == NULL)
2654 {
2655 /* Find a locus from one of the arguments to close, when UNIT is
2656 not specified. */
2657 locus loc = gfc_current_locus;
2658 if (close->status)
2659 loc = close->status->where;
2660 else if (close->iostat)
2661 loc = close->iostat->where;
2662 else if (close->iomsg)
2663 loc = close->iomsg->where;
2664 else if (close->err)
2665 loc = close->err->where;
2666
2667 gfc_error ("CLOSE statement at %L requires a UNIT number", &loc);
2668 return false;
2669 }
2670
2671 if (close->unit->expr_type == EXPR_CONSTANT
2672 && close->unit->ts.type == BT_INTEGER
2673 && mpz_sgn (close->unit->value.integer) < 0)
2674 {
2675 gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2676 &close->unit->where);
2677 }
2678
2679 return true;
2680 }
2681
2682
2683 /* Free a gfc_filepos structure. */
2684
2685 void
2686 gfc_free_filepos (gfc_filepos *fp)
2687 {
2688 gfc_free_expr (fp->unit);
2689 gfc_free_expr (fp->iomsg);
2690 gfc_free_expr (fp->iostat);
2691 free (fp);
2692 }
2693
2694
2695 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
2696
2697 static match
2698 match_file_element (gfc_filepos *fp)
2699 {
2700 match m;
2701
2702 m = match_etag (&tag_unit, &fp->unit);
2703 if (m != MATCH_NO)
2704 return m;
2705 m = match_etag (&tag_iomsg, &fp->iomsg);
2706 if (m == MATCH_YES && !check_char_variable (fp->iomsg))
2707 return MATCH_ERROR;
2708 if (m != MATCH_NO)
2709 return m;
2710 m = match_out_tag (&tag_iostat, &fp->iostat);
2711 if (m != MATCH_NO)
2712 return m;
2713 m = match_ltag (&tag_err, &fp->err);
2714 if (m != MATCH_NO)
2715 return m;
2716
2717 return MATCH_NO;
2718 }
2719
2720
2721 /* Match the second half of the file-positioning statements, REWIND,
2722 BACKSPACE, ENDFILE, or the FLUSH statement. */
2723
2724 static match
2725 match_filepos (gfc_statement st, gfc_exec_op op)
2726 {
2727 gfc_filepos *fp;
2728 match m;
2729
2730 fp = XCNEW (gfc_filepos);
2731
2732 if (gfc_match_char ('(') == MATCH_NO)
2733 {
2734 m = gfc_match_expr (&fp->unit);
2735 if (m == MATCH_ERROR)
2736 goto cleanup;
2737 if (m == MATCH_NO)
2738 goto syntax;
2739
2740 goto done;
2741 }
2742
2743 m = match_file_element (fp);
2744 if (m == MATCH_ERROR)
2745 goto done;
2746 if (m == MATCH_NO)
2747 {
2748 m = gfc_match_expr (&fp->unit);
2749 if (m == MATCH_ERROR || m == MATCH_NO)
2750 goto syntax;
2751 }
2752
2753 for (;;)
2754 {
2755 if (gfc_match_char (')') == MATCH_YES)
2756 break;
2757 if (gfc_match_char (',') != MATCH_YES)
2758 goto syntax;
2759
2760 m = match_file_element (fp);
2761 if (m == MATCH_ERROR)
2762 goto cleanup;
2763 if (m == MATCH_NO)
2764 goto syntax;
2765 }
2766
2767 done:
2768 if (gfc_match_eos () != MATCH_YES)
2769 goto syntax;
2770
2771 if (gfc_pure (NULL))
2772 {
2773 gfc_error ("%s statement not allowed in PURE procedure at %C",
2774 gfc_ascii_statement (st));
2775
2776 goto cleanup;
2777 }
2778
2779 gfc_unset_implicit_pure (NULL);
2780
2781 new_st.op = op;
2782 new_st.ext.filepos = fp;
2783 return MATCH_YES;
2784
2785 syntax:
2786 gfc_syntax_error (st);
2787
2788 cleanup:
2789 gfc_free_filepos (fp);
2790 return MATCH_ERROR;
2791 }
2792
2793
2794 bool
2795 gfc_resolve_filepos (gfc_filepos *fp)
2796 {
2797 RESOLVE_TAG (&tag_unit, fp->unit);
2798 RESOLVE_TAG (&tag_iostat, fp->iostat);
2799 RESOLVE_TAG (&tag_iomsg, fp->iomsg);
2800 if (!gfc_reference_st_label (fp->err, ST_LABEL_TARGET))
2801 return false;
2802
2803 if (!fp->unit && (fp->iostat || fp->iomsg))
2804 {
2805 locus where;
2806 where = fp->iostat ? fp->iostat->where : fp->iomsg->where;
2807 gfc_error ("UNIT number missing in statement at %L", &where);
2808 return false;
2809 }
2810
2811 if (fp->unit->expr_type == EXPR_CONSTANT
2812 && fp->unit->ts.type == BT_INTEGER
2813 && mpz_sgn (fp->unit->value.integer) < 0)
2814 {
2815 gfc_error ("UNIT number in statement at %L must be non-negative",
2816 &fp->unit->where);
2817 return false;
2818 }
2819
2820 return true;
2821 }
2822
2823
2824 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2825 and the FLUSH statement. */
2826
2827 match
2828 gfc_match_endfile (void)
2829 {
2830 return match_filepos (ST_END_FILE, EXEC_ENDFILE);
2831 }
2832
2833 match
2834 gfc_match_backspace (void)
2835 {
2836 return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
2837 }
2838
2839 match
2840 gfc_match_rewind (void)
2841 {
2842 return match_filepos (ST_REWIND, EXEC_REWIND);
2843 }
2844
2845 match
2846 gfc_match_flush (void)
2847 {
2848 if (!gfc_notify_std (GFC_STD_F2003, "FLUSH statement at %C"))
2849 return MATCH_ERROR;
2850
2851 return match_filepos (ST_FLUSH, EXEC_FLUSH);
2852 }
2853
2854 /******************** Data Transfer Statements *********************/
2855
2856 /* Return a default unit number. */
2857
2858 static gfc_expr *
2859 default_unit (io_kind k)
2860 {
2861 int unit;
2862
2863 if (k == M_READ)
2864 unit = 5;
2865 else
2866 unit = 6;
2867
2868 return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit);
2869 }
2870
2871
2872 /* Match a unit specification for a data transfer statement. */
2873
2874 static match
2875 match_dt_unit (io_kind k, gfc_dt *dt)
2876 {
2877 gfc_expr *e;
2878 char c;
2879
2880 if (gfc_match_char ('*') == MATCH_YES)
2881 {
2882 if (dt->io_unit != NULL)
2883 goto conflict;
2884
2885 dt->io_unit = default_unit (k);
2886
2887 c = gfc_peek_ascii_char ();
2888 if (c == ')')
2889 gfc_error_now ("Missing format with default unit at %C");
2890
2891 return MATCH_YES;
2892 }
2893
2894 if (gfc_match_expr (&e) == MATCH_YES)
2895 {
2896 if (dt->io_unit != NULL)
2897 {
2898 gfc_free_expr (e);
2899 goto conflict;
2900 }
2901
2902 dt->io_unit = e;
2903 return MATCH_YES;
2904 }
2905
2906 return MATCH_NO;
2907
2908 conflict:
2909 gfc_error ("Duplicate UNIT specification at %C");
2910 return MATCH_ERROR;
2911 }
2912
2913
2914 /* Match a format specification. */
2915
2916 static match
2917 match_dt_format (gfc_dt *dt)
2918 {
2919 locus where;
2920 gfc_expr *e;
2921 gfc_st_label *label;
2922 match m;
2923
2924 where = gfc_current_locus;
2925
2926 if (gfc_match_char ('*') == MATCH_YES)
2927 {
2928 if (dt->format_expr != NULL || dt->format_label != NULL)
2929 goto conflict;
2930
2931 dt->format_label = &format_asterisk;
2932 return MATCH_YES;
2933 }
2934
2935 if ((m = gfc_match_st_label (&label)) == MATCH_YES)
2936 {
2937 char c;
2938
2939 /* Need to check if the format label is actually either an operand
2940 to a user-defined operator or is a kind type parameter. That is,
2941 print 2.ip.8 ! .ip. is a user-defined operator return CHARACTER.
2942 print 1_'(I0)', i ! 1_'(I0)' is a default character string. */
2943
2944 gfc_gobble_whitespace ();
2945 c = gfc_peek_ascii_char ();
2946 if (c == '.' || c == '_')
2947 gfc_current_locus = where;
2948 else
2949 {
2950 if (dt->format_expr != NULL || dt->format_label != NULL)
2951 {
2952 gfc_free_st_label (label);
2953 goto conflict;
2954 }
2955
2956 if (!gfc_reference_st_label (label, ST_LABEL_FORMAT))
2957 return MATCH_ERROR;
2958
2959 dt->format_label = label;
2960 return MATCH_YES;
2961 }
2962 }
2963 else if (m == MATCH_ERROR)
2964 /* The label was zero or too large. Emit the correct diagnosis. */
2965 return MATCH_ERROR;
2966
2967 if (gfc_match_expr (&e) == MATCH_YES)
2968 {
2969 if (dt->format_expr != NULL || dt->format_label != NULL)
2970 {
2971 gfc_free_expr (e);
2972 goto conflict;
2973 }
2974 dt->format_expr = e;
2975 return MATCH_YES;
2976 }
2977
2978 gfc_current_locus = where; /* The only case where we have to restore */
2979
2980 return MATCH_NO;
2981
2982 conflict:
2983 gfc_error ("Duplicate format specification at %C");
2984 return MATCH_ERROR;
2985 }
2986
2987 /* Check for formatted read and write DTIO procedures. */
2988
2989 static bool
2990 dtio_procs_present (gfc_symbol *sym, io_kind k)
2991 {
2992 gfc_symbol *derived;
2993
2994 if (sym && sym->ts.u.derived)
2995 {
2996 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
2997 derived = CLASS_DATA (sym)->ts.u.derived;
2998 else if (sym->ts.type == BT_DERIVED)
2999 derived = sym->ts.u.derived;
3000 else
3001 return false;
3002 if ((k == M_WRITE || k == M_PRINT) &&
3003 (gfc_find_specific_dtio_proc (derived, true, true) != NULL))
3004 return true;
3005 if ((k == M_READ) &&
3006 (gfc_find_specific_dtio_proc (derived, false, true) != NULL))
3007 return true;
3008 }
3009 return false;
3010 }
3011
3012 /* Traverse a namelist that is part of a READ statement to make sure
3013 that none of the variables in the namelist are INTENT(IN). Returns
3014 nonzero if we find such a variable. */
3015
3016 static int
3017 check_namelist (gfc_symbol *sym)
3018 {
3019 gfc_namelist *p;
3020
3021 for (p = sym->namelist; p; p = p->next)
3022 if (p->sym->attr.intent == INTENT_IN)
3023 {
3024 gfc_error ("Symbol %qs in namelist %qs is INTENT(IN) at %C",
3025 p->sym->name, sym->name);
3026 return 1;
3027 }
3028
3029 return 0;
3030 }
3031
3032
3033 /* Match a single data transfer element. */
3034
3035 static match
3036 match_dt_element (io_kind k, gfc_dt *dt)
3037 {
3038 char name[GFC_MAX_SYMBOL_LEN + 1];
3039 gfc_symbol *sym;
3040 match m;
3041
3042 if (gfc_match (" unit =") == MATCH_YES)
3043 {
3044 m = match_dt_unit (k, dt);
3045 if (m != MATCH_NO)
3046 return m;
3047 }
3048
3049 if (gfc_match (" fmt =") == MATCH_YES)
3050 {
3051 m = match_dt_format (dt);
3052 if (m != MATCH_NO)
3053 return m;
3054 }
3055
3056 if (gfc_match (" nml = %n", name) == MATCH_YES)
3057 {
3058 if (dt->namelist != NULL)
3059 {
3060 gfc_error ("Duplicate NML specification at %C");
3061 return MATCH_ERROR;
3062 }
3063
3064 if (gfc_find_symbol (name, NULL, 1, &sym))
3065 return MATCH_ERROR;
3066
3067 if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
3068 {
3069 gfc_error ("Symbol %qs at %C must be a NAMELIST group name",
3070 sym != NULL ? sym->name : name);
3071 return MATCH_ERROR;
3072 }
3073
3074 dt->namelist = sym;
3075 if (k == M_READ && check_namelist (sym))
3076 return MATCH_ERROR;
3077
3078 return MATCH_YES;
3079 }
3080
3081 m = match_etag (&tag_e_async, &dt->asynchronous);
3082 if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", dt->asynchronous))
3083 return MATCH_ERROR;
3084 if (m != MATCH_NO)
3085 return m;
3086 m = match_etag (&tag_e_blank, &dt->blank);
3087 if (m != MATCH_NO)
3088 return m;
3089 m = match_etag (&tag_e_delim, &dt->delim);
3090 if (m != MATCH_NO)
3091 return m;
3092 m = match_etag (&tag_e_pad, &dt->pad);
3093 if (m != MATCH_NO)
3094 return m;
3095 m = match_etag (&tag_e_sign, &dt->sign);
3096 if (m != MATCH_NO)
3097 return m;
3098 m = match_etag (&tag_e_round, &dt->round);
3099 if (m != MATCH_NO)
3100 return m;
3101 m = match_out_tag (&tag_id, &dt->id);
3102 if (m != MATCH_NO)
3103 return m;
3104 m = match_etag (&tag_e_decimal, &dt->decimal);
3105 if (m != MATCH_NO)
3106 return m;
3107 m = match_etag (&tag_rec, &dt->rec);
3108 if (m != MATCH_NO)
3109 return m;
3110 m = match_etag (&tag_spos, &dt->pos);
3111 if (m != MATCH_NO)
3112 return m;
3113 m = match_etag (&tag_iomsg, &dt->iomsg);
3114 if (m == MATCH_YES && !check_char_variable (dt->iomsg))
3115 return MATCH_ERROR;
3116 if (m != MATCH_NO)
3117 return m;
3118
3119 m = match_out_tag (&tag_iostat, &dt->iostat);
3120 if (m != MATCH_NO)
3121 return m;
3122 m = match_ltag (&tag_err, &dt->err);
3123 if (m == MATCH_YES)
3124 dt->err_where = gfc_current_locus;
3125 if (m != MATCH_NO)
3126 return m;
3127 m = match_etag (&tag_advance, &dt->advance);
3128 if (m != MATCH_NO)
3129 return m;
3130 m = match_out_tag (&tag_size, &dt->size);
3131 if (m != MATCH_NO)
3132 return m;
3133
3134 m = match_ltag (&tag_end, &dt->end);
3135 if (m == MATCH_YES)
3136 {
3137 if (k == M_WRITE)
3138 {
3139 gfc_error ("END tag at %C not allowed in output statement");
3140 return MATCH_ERROR;
3141 }
3142 dt->end_where = gfc_current_locus;
3143 }
3144 if (m != MATCH_NO)
3145 return m;
3146
3147 m = match_ltag (&tag_eor, &dt->eor);
3148 if (m == MATCH_YES)
3149 dt->eor_where = gfc_current_locus;
3150 if (m != MATCH_NO)
3151 return m;
3152
3153 return MATCH_NO;
3154 }
3155
3156
3157 /* Free a data transfer structure and everything below it. */
3158
3159 void
3160 gfc_free_dt (gfc_dt *dt)
3161 {
3162 if (dt == NULL)
3163 return;
3164
3165 gfc_free_expr (dt->io_unit);
3166 gfc_free_expr (dt->format_expr);
3167 gfc_free_expr (dt->rec);
3168 gfc_free_expr (dt->advance);
3169 gfc_free_expr (dt->iomsg);
3170 gfc_free_expr (dt->iostat);
3171 gfc_free_expr (dt->size);
3172 gfc_free_expr (dt->pad);
3173 gfc_free_expr (dt->delim);
3174 gfc_free_expr (dt->sign);
3175 gfc_free_expr (dt->round);
3176 gfc_free_expr (dt->blank);
3177 gfc_free_expr (dt->decimal);
3178 gfc_free_expr (dt->pos);
3179 gfc_free_expr (dt->dt_io_kind);
3180 /* dt->extra_comma is a link to dt_io_kind if it is set. */
3181 free (dt);
3182 }
3183
3184
3185 /* Resolve everything in a gfc_dt structure. */
3186
3187 bool
3188 gfc_resolve_dt (gfc_dt *dt, locus *loc)
3189 {
3190 gfc_expr *e;
3191 io_kind k;
3192
3193 /* This is set in any case. */
3194 gcc_assert (dt->dt_io_kind);
3195 k = dt->dt_io_kind->value.iokind;
3196
3197 RESOLVE_TAG (&tag_format, dt->format_expr);
3198 RESOLVE_TAG (&tag_rec, dt->rec);
3199 RESOLVE_TAG (&tag_spos, dt->pos);
3200 RESOLVE_TAG (&tag_advance, dt->advance);
3201 RESOLVE_TAG (&tag_id, dt->id);
3202 RESOLVE_TAG (&tag_iomsg, dt->iomsg);
3203 RESOLVE_TAG (&tag_iostat, dt->iostat);
3204 RESOLVE_TAG (&tag_size, dt->size);
3205 RESOLVE_TAG (&tag_e_pad, dt->pad);
3206 RESOLVE_TAG (&tag_e_delim, dt->delim);
3207 RESOLVE_TAG (&tag_e_sign, dt->sign);
3208 RESOLVE_TAG (&tag_e_round, dt->round);
3209 RESOLVE_TAG (&tag_e_blank, dt->blank);
3210 RESOLVE_TAG (&tag_e_decimal, dt->decimal);
3211 RESOLVE_TAG (&tag_e_async, dt->asynchronous);
3212
3213 e = dt->io_unit;
3214 if (e == NULL)
3215 {
3216 gfc_error ("UNIT not specified at %L", loc);
3217 return false;
3218 }
3219
3220 if (gfc_resolve_expr (e)
3221 && (e->ts.type != BT_INTEGER
3222 && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
3223 {
3224 /* If there is no extra comma signifying the "format" form of the IO
3225 statement, then this must be an error. */
3226 if (!dt->extra_comma)
3227 {
3228 gfc_error ("UNIT specification at %L must be an INTEGER expression "
3229 "or a CHARACTER variable", &e->where);
3230 return false;
3231 }
3232 else
3233 {
3234 /* At this point, we have an extra comma. If io_unit has arrived as
3235 type character, we assume its really the "format" form of the I/O
3236 statement. We set the io_unit to the default unit and format to
3237 the character expression. See F95 Standard section 9.4. */
3238 if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
3239 {
3240 dt->format_expr = dt->io_unit;
3241 dt->io_unit = default_unit (k);
3242
3243 /* Nullify this pointer now so that a warning/error is not
3244 triggered below for the "Extension". */
3245 dt->extra_comma = NULL;
3246 }
3247
3248 if (k == M_WRITE)
3249 {
3250 gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
3251 &dt->extra_comma->where);
3252 return false;
3253 }
3254 }
3255 }
3256
3257 if (e->ts.type == BT_CHARACTER)
3258 {
3259 if (gfc_has_vector_index (e))
3260 {
3261 gfc_error ("Internal unit with vector subscript at %L", &e->where);
3262 return false;
3263 }
3264
3265 /* If we are writing, make sure the internal unit can be changed. */
3266 gcc_assert (k != M_PRINT);
3267 if (k == M_WRITE
3268 && !gfc_check_vardef_context (e, false, false, false,
3269 _("internal unit in WRITE")))
3270 return false;
3271 }
3272
3273 if (e->rank && e->ts.type != BT_CHARACTER)
3274 {
3275 gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
3276 return false;
3277 }
3278
3279 if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER
3280 && mpz_sgn (e->value.integer) < 0)
3281 {
3282 gfc_error ("UNIT number in statement at %L must be non-negative",
3283 &e->where);
3284 return false;
3285 }
3286
3287 /* If we are reading and have a namelist, check that all namelist symbols
3288 can appear in a variable definition context. */
3289 if (dt->namelist)
3290 {
3291 gfc_namelist* n;
3292 for (n = dt->namelist->namelist; n; n = n->next)
3293 {
3294 gfc_expr* e;
3295 bool t;
3296
3297 if (k == M_READ)
3298 {
3299 e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
3300 t = gfc_check_vardef_context (e, false, false, false, NULL);
3301 gfc_free_expr (e);
3302
3303 if (!t)
3304 {
3305 gfc_error ("NAMELIST %qs in READ statement at %L contains"
3306 " the symbol %qs which may not appear in a"
3307 " variable definition context",
3308 dt->namelist->name, loc, n->sym->name);
3309 return false;
3310 }
3311 }
3312
3313 t = dtio_procs_present (n->sym, k);
3314
3315 if (n->sym->ts.type == BT_CLASS && !t)
3316 {
3317 gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
3318 "polymorphic and requires a defined input/output "
3319 "procedure", n->sym->name, dt->namelist->name, loc);
3320 return false;
3321 }
3322
3323 if ((n->sym->ts.type == BT_DERIVED)
3324 && (n->sym->ts.u.derived->attr.alloc_comp
3325 || n->sym->ts.u.derived->attr.pointer_comp))
3326 {
3327 if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
3328 "namelist %qs at %L with ALLOCATABLE "
3329 "or POINTER components", n->sym->name,
3330 dt->namelist->name, loc))
3331 return false;
3332
3333 if (!t)
3334 {
3335 gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
3336 "ALLOCATABLE or POINTER components and thus requires "
3337 "a defined input/output procedure", n->sym->name,
3338 dt->namelist->name, loc);
3339 return false;
3340 }
3341 }
3342 }
3343 }
3344
3345 if (dt->extra_comma
3346 && !gfc_notify_std (GFC_STD_LEGACY, "Comma before i/o item list at %L",
3347 &dt->extra_comma->where))
3348 return false;
3349
3350 if (dt->err)
3351 {
3352 if (!gfc_reference_st_label (dt->err, ST_LABEL_TARGET))
3353 return false;
3354 if (dt->err->defined == ST_LABEL_UNKNOWN)
3355 {
3356 gfc_error ("ERR tag label %d at %L not defined",
3357 dt->err->value, &dt->err_where);
3358 return false;
3359 }
3360 }
3361
3362 if (dt->end)
3363 {
3364 if (!gfc_reference_st_label (dt->end, ST_LABEL_TARGET))
3365 return false;
3366 if (dt->end->defined == ST_LABEL_UNKNOWN)
3367 {
3368 gfc_error ("END tag label %d at %L not defined",
3369 dt->end->value, &dt->end_where);
3370 return false;
3371 }
3372 }
3373
3374 if (dt->eor)
3375 {
3376 if (!gfc_reference_st_label (dt->eor, ST_LABEL_TARGET))
3377 return false;
3378 if (dt->eor->defined == ST_LABEL_UNKNOWN)
3379 {
3380 gfc_error ("EOR tag label %d at %L not defined",
3381 dt->eor->value, &dt->eor_where);
3382 return false;
3383 }
3384 }
3385
3386 /* Check the format label actually exists. */
3387 if (dt->format_label && dt->format_label != &format_asterisk
3388 && dt->format_label->defined == ST_LABEL_UNKNOWN)
3389 {
3390 gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
3391 loc);
3392 return false;
3393 }
3394
3395 return true;
3396 }
3397
3398
3399 /* Given an io_kind, return its name. */
3400
3401 static const char *
3402 io_kind_name (io_kind k)
3403 {
3404 const char *name;
3405
3406 switch (k)
3407 {
3408 case M_READ:
3409 name = "READ";
3410 break;
3411 case M_WRITE:
3412 name = "WRITE";
3413 break;
3414 case M_PRINT:
3415 name = "PRINT";
3416 break;
3417 case M_INQUIRE:
3418 name = "INQUIRE";
3419 break;
3420 default:
3421 gfc_internal_error ("io_kind_name(): bad I/O-kind");
3422 }
3423
3424 return name;
3425 }
3426
3427
3428 /* Match an IO iteration statement of the form:
3429
3430 ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
3431
3432 which is equivalent to a single IO element. This function is
3433 mutually recursive with match_io_element(). */
3434
3435 static match match_io_element (io_kind, gfc_code **);
3436
3437 static match
3438 match_io_iterator (io_kind k, gfc_code **result)
3439 {
3440 gfc_code *head, *tail, *new_code;
3441 gfc_iterator *iter;
3442 locus old_loc;
3443 match m;
3444 int n;
3445
3446 iter = NULL;
3447 head = NULL;
3448 old_loc = gfc_current_locus;
3449
3450 if (gfc_match_char ('(') != MATCH_YES)
3451 return MATCH_NO;
3452
3453 m = match_io_element (k, &head);
3454 tail = head;
3455
3456 if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
3457 {
3458 m = MATCH_NO;
3459 goto cleanup;
3460 }
3461
3462 /* Can't be anything but an IO iterator. Build a list. */
3463 iter = gfc_get_iterator ();
3464
3465 for (n = 1;; n++)
3466 {
3467 m = gfc_match_iterator (iter, 0);
3468 if (m == MATCH_ERROR)
3469 goto cleanup;
3470 if (m == MATCH_YES)
3471 {
3472 gfc_check_do_variable (iter->var->symtree);
3473 break;
3474 }
3475
3476 m = match_io_element (k, &new_code);
3477 if (m == MATCH_ERROR)
3478 goto cleanup;
3479 if (m == MATCH_NO)
3480 {
3481 if (n > 2)
3482 goto syntax;
3483 goto cleanup;
3484 }
3485
3486 tail = gfc_append_code (tail, new_code);
3487
3488 if (gfc_match_char (',') != MATCH_YES)
3489 {
3490 if (n > 2)
3491 goto syntax;
3492 m = MATCH_NO;
3493 goto cleanup;
3494 }
3495 }
3496
3497 if (gfc_match_char (')') != MATCH_YES)
3498 goto syntax;
3499
3500 new_code = gfc_get_code (EXEC_DO);
3501 new_code->ext.iterator = iter;
3502
3503 new_code->block = gfc_get_code (EXEC_DO);
3504 new_code->block->next = head;
3505
3506 *result = new_code;
3507 return MATCH_YES;
3508
3509 syntax:
3510 gfc_error ("Syntax error in I/O iterator at %C");
3511 m = MATCH_ERROR;
3512
3513 cleanup:
3514 gfc_free_iterator (iter, 1);
3515 gfc_free_statements (head);
3516 gfc_current_locus = old_loc;
3517 return m;
3518 }
3519
3520
3521 /* Match a single element of an IO list, which is either a single
3522 expression or an IO Iterator. */
3523
3524 static match
3525 match_io_element (io_kind k, gfc_code **cpp)
3526 {
3527 gfc_expr *expr;
3528 gfc_code *cp;
3529 match m;
3530
3531 expr = NULL;
3532
3533 m = match_io_iterator (k, cpp);
3534 if (m == MATCH_YES)
3535 return MATCH_YES;
3536
3537 if (k == M_READ)
3538 {
3539 m = gfc_match_variable (&expr, 0);
3540 if (m == MATCH_NO)
3541 gfc_error ("Expected variable in READ statement at %C");
3542 }
3543 else
3544 {
3545 m = gfc_match_expr (&expr);
3546 if (m == MATCH_NO)
3547 gfc_error ("Expected expression in %s statement at %C",
3548 io_kind_name (k));
3549 }
3550
3551 if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree))
3552 m = MATCH_ERROR;
3553
3554 if (m != MATCH_YES)
3555 {
3556 gfc_free_expr (expr);
3557 return MATCH_ERROR;
3558 }
3559
3560 cp = gfc_get_code (EXEC_TRANSFER);
3561 cp->expr1 = expr;
3562 if (k != M_INQUIRE)
3563 cp->ext.dt = current_dt;
3564
3565 *cpp = cp;
3566 return MATCH_YES;
3567 }
3568
3569
3570 /* Match an I/O list, building gfc_code structures as we go. */
3571
3572 static match
3573 match_io_list (io_kind k, gfc_code **head_p)
3574 {
3575 gfc_code *head, *tail, *new_code;
3576 match m;
3577
3578 *head_p = head = tail = NULL;
3579 if (gfc_match_eos () == MATCH_YES)
3580 return MATCH_YES;
3581
3582 for (;;)
3583 {
3584 m = match_io_element (k, &new_code);
3585 if (m == MATCH_ERROR)
3586 goto cleanup;
3587 if (m == MATCH_NO)
3588 goto syntax;
3589
3590 tail = gfc_append_code (tail, new_code);
3591 if (head == NULL)
3592 head = new_code;
3593
3594 if (gfc_match_eos () == MATCH_YES)
3595 break;
3596 if (gfc_match_char (',') != MATCH_YES)
3597 goto syntax;
3598 }
3599
3600 *head_p = head;
3601 return MATCH_YES;
3602
3603 syntax:
3604 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3605
3606 cleanup:
3607 gfc_free_statements (head);
3608 return MATCH_ERROR;
3609 }
3610
3611
3612 /* Attach the data transfer end node. */
3613
3614 static void
3615 terminate_io (gfc_code *io_code)
3616 {
3617 gfc_code *c;
3618
3619 if (io_code == NULL)
3620 io_code = new_st.block;
3621
3622 c = gfc_get_code (EXEC_DT_END);
3623
3624 /* Point to structure that is already there */
3625 c->ext.dt = new_st.ext.dt;
3626 gfc_append_code (io_code, c);
3627 }
3628
3629
3630 /* Check the constraints for a data transfer statement. The majority of the
3631 constraints appearing in 9.4 of the standard appear here. Some are handled
3632 in resolve_tag and others in gfc_resolve_dt. Also set the async_io_dt flag
3633 and, if necessary, the asynchronous flag on the SIZE argument. */
3634
3635 static match
3636 check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
3637 locus *spec_end)
3638 {
3639 #define io_constraint(condition,msg,arg)\
3640 if (condition) \
3641 {\
3642 gfc_error(msg,arg);\
3643 m = MATCH_ERROR;\
3644 }
3645
3646 match m;
3647 gfc_expr *expr;
3648 gfc_symbol *sym = NULL;
3649 bool warn, unformatted;
3650
3651 warn = (dt->err || dt->iostat) ? true : false;
3652 unformatted = dt->format_expr == NULL && dt->format_label == NULL
3653 && dt->namelist == NULL;
3654
3655 m = MATCH_YES;
3656
3657 expr = dt->io_unit;
3658 if (expr && expr->expr_type == EXPR_VARIABLE
3659 && expr->ts.type == BT_CHARACTER)
3660 {
3661 sym = expr->symtree->n.sym;
3662
3663 io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
3664 "Internal file at %L must not be INTENT(IN)",
3665 &expr->where);
3666
3667 io_constraint (gfc_has_vector_index (dt->io_unit),
3668 "Internal file incompatible with vector subscript at %L",
3669 &expr->where);
3670
3671 io_constraint (dt->rec != NULL,
3672 "REC tag at %L is incompatible with internal file",
3673 &dt->rec->where);
3674
3675 io_constraint (dt->pos != NULL,
3676 "POS tag at %L is incompatible with internal file",
3677 &dt->pos->where);
3678
3679 io_constraint (unformatted,
3680 "Unformatted I/O not allowed with internal unit at %L",
3681 &dt->io_unit->where);
3682
3683 io_constraint (dt->asynchronous != NULL,
3684 "ASYNCHRONOUS tag at %L not allowed with internal file",
3685 &dt->asynchronous->where);
3686
3687 if (dt->namelist != NULL)
3688 {
3689 if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with "
3690 "namelist", &expr->where))
3691 m = MATCH_ERROR;
3692 }
3693
3694 io_constraint (dt->advance != NULL,
3695 "ADVANCE tag at %L is incompatible with internal file",
3696 &dt->advance->where);
3697 }
3698
3699 if (expr && expr->ts.type != BT_CHARACTER)
3700 {
3701
3702 io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE),
3703 "IO UNIT in %s statement at %C must be "
3704 "an internal file in a PURE procedure",
3705 io_kind_name (k));
3706
3707 if (k == M_READ || k == M_WRITE)
3708 gfc_unset_implicit_pure (NULL);
3709 }
3710
3711 if (k != M_READ)
3712 {
3713 io_constraint (dt->end, "END tag not allowed with output at %L",
3714 &dt->end_where);
3715
3716 io_constraint (dt->eor, "EOR tag not allowed with output at %L",
3717 &dt->eor_where);
3718
3719 io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L",
3720 &dt->blank->where);
3721
3722 io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
3723 &dt->pad->where);
3724
3725 io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
3726 &dt->size->where);
3727 }
3728 else
3729 {
3730 io_constraint (dt->size && dt->advance == NULL,
3731 "SIZE tag at %L requires an ADVANCE tag",
3732 &dt->size->where);
3733
3734 io_constraint (dt->eor && dt->advance == NULL,
3735 "EOR tag at %L requires an ADVANCE tag",
3736 &dt->eor_where);
3737 }
3738
3739 if (dt->asynchronous)
3740 {
3741 int num;
3742 static const char * asynchronous[] = { "YES", "NO", NULL };
3743
3744 if (!gfc_reduce_init_expr (dt->asynchronous))
3745 {
3746 gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3747 "expression", &dt->asynchronous->where);
3748 return MATCH_ERROR;
3749 }
3750
3751 if (!is_char_type ("ASYNCHRONOUS", dt->asynchronous))
3752 return MATCH_ERROR;
3753
3754 if (!compare_to_allowed_values
3755 ("ASYNCHRONOUS", asynchronous, NULL, NULL,
3756 dt->asynchronous->value.character.string,
3757 io_kind_name (k), warn, &num))
3758 return MATCH_ERROR;
3759
3760 /* Best to put this here because the yes/no info is still around. */
3761 async_io_dt = num == 0;
3762 if (async_io_dt && dt->size)
3763 dt->size->symtree->n.sym->attr.asynchronous = 1;
3764 }
3765 else
3766 async_io_dt = false;
3767
3768 if (dt->id)
3769 {
3770 bool not_yes
3771 = !dt->asynchronous
3772 || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
3773 || gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
3774 "yes", 3) != 0;
3775 io_constraint (not_yes,
3776 "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3777 "specifier", &dt->id->where);
3778 }
3779
3780 if (dt->decimal)
3781 {
3782 if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C "
3783 "not allowed in Fortran 95"))
3784 return MATCH_ERROR;
3785
3786 if (dt->decimal->expr_type == EXPR_CONSTANT)
3787 {
3788 static const char * decimal[] = { "COMMA", "POINT", NULL };
3789
3790 if (!is_char_type ("DECIMAL", dt->decimal))
3791 return MATCH_ERROR;
3792
3793 if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
3794 dt->decimal->value.character.string,
3795 io_kind_name (k), warn))
3796 return MATCH_ERROR;
3797
3798 io_constraint (unformatted,
3799 "the DECIMAL= specifier at %L must be with an "
3800 "explicit format expression", &dt->decimal->where);
3801 }
3802 }
3803
3804 if (dt->blank)
3805 {
3806 if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C "
3807 "not allowed in Fortran 95"))
3808 return MATCH_ERROR;
3809
3810 if (!is_char_type ("BLANK", dt->blank))
3811 return MATCH_ERROR;
3812
3813 if (dt->blank->expr_type == EXPR_CONSTANT)
3814 {
3815 static const char * blank[] = { "NULL", "ZERO", NULL };
3816
3817
3818 if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
3819 dt->blank->value.character.string,
3820 io_kind_name (k), warn))
3821 return MATCH_ERROR;
3822
3823 io_constraint (unformatted,
3824 "the BLANK= specifier at %L must be with an "
3825 "explicit format expression", &dt->blank->where);
3826 }
3827 }
3828
3829 if (dt->pad)
3830 {
3831 if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %C "
3832 "not allowed in Fortran 95"))
3833 return MATCH_ERROR;
3834
3835 if (!is_char_type ("PAD", dt->pad))
3836 return MATCH_ERROR;
3837
3838 if (dt->pad->expr_type == EXPR_CONSTANT)
3839 {
3840 static const char * pad[] = { "YES", "NO", NULL };
3841
3842 if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
3843 dt->pad->value.character.string,
3844 io_kind_name (k), warn))
3845 return MATCH_ERROR;
3846
3847 io_constraint (unformatted,
3848 "the PAD= specifier at %L must be with an "
3849 "explicit format expression", &dt->pad->where);
3850 }
3851 }
3852
3853 if (dt->round)
3854 {
3855 if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C "
3856 "not allowed in Fortran 95"))
3857 return MATCH_ERROR;
3858
3859 if (!is_char_type ("ROUND", dt->round))
3860 return MATCH_ERROR;
3861
3862 if (dt->round->expr_type == EXPR_CONSTANT)
3863 {
3864 static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
3865 "COMPATIBLE", "PROCESSOR_DEFINED",
3866 NULL };
3867
3868 if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
3869 dt->round->value.character.string,
3870 io_kind_name (k), warn))
3871 return MATCH_ERROR;
3872 }
3873 }
3874
3875 if (dt->sign)
3876 {
3877 /* When implemented, change the following to use gfc_notify_std F2003.
3878 if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C "
3879 "not allowed in Fortran 95") == false)
3880 return MATCH_ERROR; */
3881
3882 if (!is_char_type ("SIGN", dt->sign))
3883 return MATCH_ERROR;
3884
3885 if (dt->sign->expr_type == EXPR_CONSTANT)
3886 {
3887 static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3888 NULL };
3889
3890 if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
3891 dt->sign->value.character.string,
3892 io_kind_name (k), warn))
3893 return MATCH_ERROR;
3894
3895 io_constraint (unformatted,
3896 "SIGN= specifier at %L must be with an "
3897 "explicit format expression", &dt->sign->where);
3898
3899 io_constraint (k == M_READ,
3900 "SIGN= specifier at %L not allowed in a "
3901 "READ statement", &dt->sign->where);
3902 }
3903 }
3904
3905 if (dt->delim)
3906 {
3907 if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %C "
3908 "not allowed in Fortran 95"))
3909 return MATCH_ERROR;
3910
3911 if (!is_char_type ("DELIM", dt->delim))
3912 return MATCH_ERROR;
3913
3914 if (dt->delim->expr_type == EXPR_CONSTANT)
3915 {
3916 static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
3917
3918 if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
3919 dt->delim->value.character.string,
3920 io_kind_name (k), warn))
3921 return MATCH_ERROR;
3922
3923 io_constraint (k == M_READ,
3924 "DELIM= specifier at %L not allowed in a "
3925 "READ statement", &dt->delim->where);
3926
3927 io_constraint (dt->format_label != &format_asterisk
3928 && dt->namelist == NULL,
3929 "DELIM= specifier at %L must have FMT=*",
3930 &dt->delim->where);
3931
3932 io_constraint (unformatted && dt->namelist == NULL,
3933 "DELIM= specifier at %L must be with FMT=* or "
3934 "NML= specifier", &dt->delim->where);
3935 }
3936 }
3937
3938 if (dt->namelist)
3939 {
3940 io_constraint (io_code && dt->namelist,
3941 "NAMELIST cannot be followed by IO-list at %L",
3942 &io_code->loc);
3943
3944 io_constraint (dt->format_expr,
3945 "IO spec-list cannot contain both NAMELIST group name "
3946 "and format specification at %L",
3947 &dt->format_expr->where);
3948
3949 io_constraint (dt->format_label,
3950 "IO spec-list cannot contain both NAMELIST group name "
3951 "and format label at %L", spec_end);
3952
3953 io_constraint (dt->rec,
3954 "NAMELIST IO is not allowed with a REC= specifier "
3955 "at %L", &dt->rec->where);
3956
3957 io_constraint (dt->advance,
3958 "NAMELIST IO is not allowed with a ADVANCE= specifier "
3959 "at %L", &dt->advance->where);
3960 }
3961
3962 if (dt->rec)
3963 {
3964 io_constraint (dt->end,
3965 "An END tag is not allowed with a "
3966 "REC= specifier at %L", &dt->end_where);
3967
3968 io_constraint (dt->format_label == &format_asterisk,
3969 "FMT=* is not allowed with a REC= specifier "
3970 "at %L", spec_end);
3971
3972 io_constraint (dt->pos,
3973 "POS= is not allowed with REC= specifier "
3974 "at %L", &dt->pos->where);
3975 }
3976
3977 if (dt->advance)
3978 {
3979 int not_yes, not_no;
3980 expr = dt->advance;
3981
3982 io_constraint (dt->format_label == &format_asterisk,
3983 "List directed format(*) is not allowed with a "
3984 "ADVANCE= specifier at %L.", &expr->where);
3985
3986 io_constraint (unformatted,
3987 "the ADVANCE= specifier at %L must appear with an "
3988 "explicit format expression", &expr->where);
3989
3990 if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
3991 {
3992 const gfc_char_t *advance = expr->value.character.string;
3993 not_no = gfc_wide_strlen (advance) != 2
3994 || gfc_wide_strncasecmp (advance, "no", 2) != 0;
3995 not_yes = gfc_wide_strlen (advance) != 3
3996 || gfc_wide_strncasecmp (advance, "yes", 3) != 0;
3997 }
3998 else
3999 {
4000 not_no = 0;
4001 not_yes = 0;
4002 }
4003
4004 io_constraint (not_no && not_yes,
4005 "ADVANCE= specifier at %L must have value = "
4006 "YES or NO.", &expr->where);
4007
4008 io_constraint (dt->size && not_no && k == M_READ,
4009 "SIZE tag at %L requires an ADVANCE = %<NO%>",
4010 &dt->size->where);
4011
4012 io_constraint (dt->eor && not_no && k == M_READ,
4013 "EOR tag at %L requires an ADVANCE = %<NO%>",
4014 &dt->eor_where);
4015 }
4016
4017 expr = dt->format_expr;
4018 if (!gfc_simplify_expr (expr, 0)
4019 || !check_format_string (expr, k == M_READ))
4020 return MATCH_ERROR;
4021
4022 return m;
4023 }
4024 #undef io_constraint
4025
4026
4027 /* Match a READ, WRITE or PRINT statement. */
4028
4029 static match
4030 match_io (io_kind k)
4031 {
4032 char name[GFC_MAX_SYMBOL_LEN + 1];
4033 gfc_code *io_code;
4034 gfc_symbol *sym;
4035 int comma_flag;
4036 locus where;
4037 locus spec_end, control;
4038 gfc_dt *dt;
4039 match m;
4040
4041 where = gfc_current_locus;
4042 comma_flag = 0;
4043 current_dt = dt = XCNEW (gfc_dt);
4044 m = gfc_match_char ('(');
4045 if (m == MATCH_NO)
4046 {
4047 where = gfc_current_locus;
4048 if (k == M_WRITE)
4049 goto syntax;
4050 else if (k == M_PRINT)
4051 {
4052 /* Treat the non-standard case of PRINT namelist. */
4053 if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
4054 && gfc_match_name (name) == MATCH_YES)
4055 {
4056 gfc_find_symbol (name, NULL, 1, &sym);
4057 if (sym && sym->attr.flavor == FL_NAMELIST)
4058 {
4059 if (!gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
4060 "%C is an extension"))
4061 {
4062 m = MATCH_ERROR;
4063 goto cleanup;
4064 }
4065
4066 dt->io_unit = default_unit (k);
4067 dt->namelist = sym;
4068 goto get_io_list;
4069 }
4070 else
4071 gfc_current_locus = where;
4072 }
4073 }
4074
4075 if (gfc_current_form == FORM_FREE)
4076 {
4077 char c = gfc_peek_ascii_char ();
4078 if (c != ' ' && c != '*' && c != '\'' && c != '"')
4079 {
4080 m = MATCH_NO;
4081 goto cleanup;
4082 }
4083 }
4084
4085 m = match_dt_format (dt);
4086 if (m == MATCH_ERROR)
4087 goto cleanup;
4088 if (m == MATCH_NO)
4089 goto syntax;
4090
4091 comma_flag = 1;
4092 dt->io_unit = default_unit (k);
4093 goto get_io_list;
4094 }
4095 else
4096 {
4097 /* Before issuing an error for a malformed 'print (1,*)' type of
4098 error, check for a default-char-expr of the form ('(I0)'). */
4099 if (m == MATCH_YES)
4100 {
4101 control = gfc_current_locus;
4102 if (k == M_PRINT)
4103 {
4104 /* Reset current locus to get the initial '(' in an expression. */
4105 gfc_current_locus = where;
4106 dt->format_expr = NULL;
4107 m = match_dt_format (dt);
4108
4109 if (m == MATCH_ERROR)
4110 goto cleanup;
4111 if (m == MATCH_NO || dt->format_expr == NULL)
4112 goto syntax;
4113
4114 comma_flag = 1;
4115 dt->io_unit = default_unit (k);
4116 goto get_io_list;
4117 }
4118 if (k == M_READ)
4119 {
4120 /* Commit any pending symbols now so that when we undo
4121 symbols later we wont lose them. */
4122 gfc_commit_symbols ();
4123 /* Reset current locus to get the initial '(' in an expression. */
4124 gfc_current_locus = where;
4125 dt->format_expr = NULL;
4126 m = gfc_match_expr (&dt->format_expr);
4127 if (m == MATCH_YES)
4128 {
4129 if (dt->format_expr
4130 && dt->format_expr->ts.type == BT_CHARACTER)
4131 {
4132 comma_flag = 1;
4133 dt->io_unit = default_unit (k);
4134 goto get_io_list;
4135 }
4136 else
4137 {
4138 gfc_free_expr (dt->format_expr);
4139 dt->format_expr = NULL;
4140 gfc_current_locus = control;
4141 }
4142 }
4143 else
4144 {
4145 gfc_clear_error ();
4146 gfc_undo_symbols ();
4147 gfc_free_expr (dt->format_expr);
4148 dt->format_expr = NULL;
4149 gfc_current_locus = control;
4150 }
4151 }
4152 }
4153 }
4154
4155 /* Match a control list */
4156 if (match_dt_element (k, dt) == MATCH_YES)
4157 goto next;
4158 if (match_dt_unit (k, dt) != MATCH_YES)
4159 goto loop;
4160
4161 if (gfc_match_char (')') == MATCH_YES)
4162 goto get_io_list;
4163 if (gfc_match_char (',') != MATCH_YES)
4164 goto syntax;
4165
4166 m = match_dt_element (k, dt);
4167 if (m == MATCH_YES)
4168 goto next;
4169 if (m == MATCH_ERROR)
4170 goto cleanup;
4171
4172 m = match_dt_format (dt);
4173 if (m == MATCH_YES)
4174 goto next;
4175 if (m == MATCH_ERROR)
4176 goto cleanup;
4177
4178 where = gfc_current_locus;
4179
4180 m = gfc_match_name (name);
4181 if (m == MATCH_YES)
4182 {
4183 gfc_find_symbol (name, NULL, 1, &sym);
4184 if (sym && sym->attr.flavor == FL_NAMELIST)
4185 {
4186 dt->namelist = sym;
4187 if (k == M_READ && check_namelist (sym))
4188 {
4189 m = MATCH_ERROR;
4190 goto cleanup;
4191 }
4192 goto next;
4193 }
4194 }
4195
4196 gfc_current_locus = where;
4197
4198 goto loop; /* No matches, try regular elements */
4199
4200 next:
4201 if (gfc_match_char (')') == MATCH_YES)
4202 goto get_io_list;
4203 if (gfc_match_char (',') != MATCH_YES)
4204 goto syntax;
4205
4206 loop:
4207 for (;;)
4208 {
4209 m = match_dt_element (k, dt);
4210 if (m == MATCH_NO)
4211 goto syntax;
4212 if (m == MATCH_ERROR)
4213 goto cleanup;
4214
4215 if (gfc_match_char (')') == MATCH_YES)
4216 break;
4217 if (gfc_match_char (',') != MATCH_YES)
4218 goto syntax;
4219 }
4220
4221 get_io_list:
4222
4223 /* Used in check_io_constraints, where no locus is available. */
4224 spec_end = gfc_current_locus;
4225
4226 /* Save the IO kind for later use. */
4227 dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k);
4228
4229 /* Optional leading comma (non-standard). We use a gfc_expr structure here
4230 to save the locus. This is used later when resolving transfer statements
4231 that might have a format expression without unit number. */
4232 if (!comma_flag && gfc_match_char (',') == MATCH_YES)
4233 dt->extra_comma = dt->dt_io_kind;
4234
4235 io_code = NULL;
4236 if (gfc_match_eos () != MATCH_YES)
4237 {
4238 if (comma_flag && gfc_match_char (',') != MATCH_YES)
4239 {
4240 gfc_error ("Expected comma in I/O list at %C");
4241 m = MATCH_ERROR;
4242 goto cleanup;
4243 }
4244
4245 m = match_io_list (k, &io_code);
4246 if (m == MATCH_ERROR)
4247 goto cleanup;
4248 if (m == MATCH_NO)
4249 goto syntax;
4250 }
4251
4252 /* See if we want to use defaults for missing exponents in real transfers. */
4253 if (flag_dec)
4254 dt->default_exp = 1;
4255
4256 /* A full IO statement has been matched. Check the constraints. spec_end is
4257 supplied for cases where no locus is supplied. */
4258 m = check_io_constraints (k, dt, io_code, &spec_end);
4259
4260 if (m == MATCH_ERROR)
4261 goto cleanup;
4262
4263 new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
4264 new_st.ext.dt = dt;
4265 new_st.block = gfc_get_code (new_st.op);
4266 new_st.block->next = io_code;
4267
4268 terminate_io (io_code);
4269
4270 return MATCH_YES;
4271
4272 syntax:
4273 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
4274 m = MATCH_ERROR;
4275
4276 cleanup:
4277 gfc_free_dt (dt);
4278 return m;
4279 }
4280
4281
4282 match
4283 gfc_match_read (void)
4284 {
4285 return match_io (M_READ);
4286 }
4287
4288
4289 match
4290 gfc_match_write (void)
4291 {
4292 return match_io (M_WRITE);
4293 }
4294
4295
4296 match
4297 gfc_match_print (void)
4298 {
4299 match m;
4300
4301 m = match_io (M_PRINT);
4302 if (m != MATCH_YES)
4303 return m;
4304
4305 if (gfc_pure (NULL))
4306 {
4307 gfc_error ("PRINT statement at %C not allowed within PURE procedure");
4308 return MATCH_ERROR;
4309 }
4310
4311 gfc_unset_implicit_pure (NULL);
4312
4313 return MATCH_YES;
4314 }
4315
4316
4317 /* Free a gfc_inquire structure. */
4318
4319 void
4320 gfc_free_inquire (gfc_inquire *inquire)
4321 {
4322
4323 if (inquire == NULL)
4324 return;
4325
4326 gfc_free_expr (inquire->unit);
4327 gfc_free_expr (inquire->file);
4328 gfc_free_expr (inquire->iomsg);
4329 gfc_free_expr (inquire->iostat);
4330 gfc_free_expr (inquire->exist);
4331 gfc_free_expr (inquire->opened);
4332 gfc_free_expr (inquire->number);
4333 gfc_free_expr (inquire->named);
4334 gfc_free_expr (inquire->name);
4335 gfc_free_expr (inquire->access);
4336 gfc_free_expr (inquire->sequential);
4337 gfc_free_expr (inquire->direct);
4338 gfc_free_expr (inquire->form);
4339 gfc_free_expr (inquire->formatted);
4340 gfc_free_expr (inquire->unformatted);
4341 gfc_free_expr (inquire->recl);
4342 gfc_free_expr (inquire->nextrec);
4343 gfc_free_expr (inquire->blank);
4344 gfc_free_expr (inquire->position);
4345 gfc_free_expr (inquire->action);
4346 gfc_free_expr (inquire->read);
4347 gfc_free_expr (inquire->write);
4348 gfc_free_expr (inquire->readwrite);
4349 gfc_free_expr (inquire->delim);
4350 gfc_free_expr (inquire->encoding);
4351 gfc_free_expr (inquire->pad);
4352 gfc_free_expr (inquire->iolength);
4353 gfc_free_expr (inquire->convert);
4354 gfc_free_expr (inquire->strm_pos);
4355 gfc_free_expr (inquire->asynchronous);
4356 gfc_free_expr (inquire->decimal);
4357 gfc_free_expr (inquire->pending);
4358 gfc_free_expr (inquire->id);
4359 gfc_free_expr (inquire->sign);
4360 gfc_free_expr (inquire->size);
4361 gfc_free_expr (inquire->round);
4362 gfc_free_expr (inquire->share);
4363 gfc_free_expr (inquire->cc);
4364 free (inquire);
4365 }
4366
4367
4368 /* Match an element of an INQUIRE statement. */
4369
4370 #define RETM if (m != MATCH_NO) return m;
4371
4372 static match
4373 match_inquire_element (gfc_inquire *inquire)
4374 {
4375 match m;
4376
4377 m = match_etag (&tag_unit, &inquire->unit);
4378 RETM m = match_etag (&tag_file, &inquire->file);
4379 RETM m = match_ltag (&tag_err, &inquire->err);
4380 RETM m = match_etag (&tag_iomsg, &inquire->iomsg);
4381 if (m == MATCH_YES && !check_char_variable (inquire->iomsg))
4382 return MATCH_ERROR;
4383 RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
4384 RETM m = match_vtag (&tag_exist, &inquire->exist);
4385 RETM m = match_vtag (&tag_opened, &inquire->opened);
4386 RETM m = match_vtag (&tag_named, &inquire->named);
4387 RETM m = match_vtag (&tag_name, &inquire->name);
4388 RETM m = match_out_tag (&tag_number, &inquire->number);
4389 RETM m = match_vtag (&tag_s_access, &inquire->access);
4390 RETM m = match_vtag (&tag_sequential, &inquire->sequential);
4391 RETM m = match_vtag (&tag_direct, &inquire->direct);
4392 RETM m = match_vtag (&tag_s_form, &inquire->form);
4393 RETM m = match_vtag (&tag_formatted, &inquire->formatted);
4394 RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
4395 RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
4396 RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
4397 RETM m = match_vtag (&tag_s_blank, &inquire->blank);
4398 RETM m = match_vtag (&tag_s_position, &inquire->position);
4399 RETM m = match_vtag (&tag_s_action, &inquire->action);
4400 RETM m = match_vtag (&tag_read, &inquire->read);
4401 RETM m = match_vtag (&tag_write, &inquire->write);
4402 RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
4403 RETM m = match_vtag (&tag_s_async, &inquire->asynchronous);
4404 if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", inquire->asynchronous))
4405 return MATCH_ERROR;
4406 RETM m = match_vtag (&tag_s_delim, &inquire->delim);
4407 RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
4408 RETM m = match_out_tag (&tag_size, &inquire->size);
4409 RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
4410 RETM m = match_vtag (&tag_s_round, &inquire->round);
4411 RETM m = match_vtag (&tag_s_sign, &inquire->sign);
4412 RETM m = match_vtag (&tag_s_pad, &inquire->pad);
4413 RETM m = match_out_tag (&tag_iolength, &inquire->iolength);
4414 RETM m = match_vtag (&tag_convert, &inquire->convert);
4415 RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
4416 RETM m = match_vtag (&tag_pending, &inquire->pending);
4417 RETM m = match_vtag (&tag_id, &inquire->id);
4418 RETM m = match_vtag (&tag_s_iqstream, &inquire->iqstream);
4419 RETM m = match_dec_vtag (&tag_v_share, &inquire->share);
4420 RETM m = match_dec_vtag (&tag_v_cc, &inquire->cc);
4421 RETM return MATCH_NO;
4422 }
4423
4424 #undef RETM
4425
4426
4427 match
4428 gfc_match_inquire (void)
4429 {
4430 gfc_inquire *inquire;
4431 gfc_code *code;
4432 match m;
4433 locus loc;
4434
4435 m = gfc_match_char ('(');
4436 if (m == MATCH_NO)
4437 return m;
4438
4439 inquire = XCNEW (gfc_inquire);
4440
4441 loc = gfc_current_locus;
4442
4443 m = match_inquire_element (inquire);
4444 if (m == MATCH_ERROR)
4445 goto cleanup;
4446 if (m == MATCH_NO)
4447 {
4448 m = gfc_match_expr (&inquire->unit);
4449 if (m == MATCH_ERROR)
4450 goto cleanup;
4451 if (m == MATCH_NO)
4452 goto syntax;
4453 }
4454
4455 /* See if we have the IOLENGTH form of the inquire statement. */
4456 if (inquire->iolength != NULL)
4457 {
4458 if (gfc_match_char (')') != MATCH_YES)
4459 goto syntax;
4460
4461 m = match_io_list (M_INQUIRE, &code);
4462 if (m == MATCH_ERROR)
4463 goto cleanup;
4464 if (m == MATCH_NO)
4465 goto syntax;
4466
4467 new_st.op = EXEC_IOLENGTH;
4468 new_st.expr1 = inquire->iolength;
4469 new_st.ext.inquire = inquire;
4470
4471 if (gfc_pure (NULL))
4472 {
4473 gfc_free_statements (code);
4474 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4475 return MATCH_ERROR;
4476 }
4477
4478 gfc_unset_implicit_pure (NULL);
4479
4480 new_st.block = gfc_get_code (EXEC_IOLENGTH);
4481 terminate_io (code);
4482 new_st.block->next = code;
4483 return MATCH_YES;
4484 }
4485
4486 /* At this point, we have the non-IOLENGTH inquire statement. */
4487 for (;;)
4488 {
4489 if (gfc_match_char (')') == MATCH_YES)
4490 break;
4491 if (gfc_match_char (',') != MATCH_YES)
4492 goto syntax;
4493
4494 m = match_inquire_element (inquire);
4495 if (m == MATCH_ERROR)
4496 goto cleanup;
4497 if (m == MATCH_NO)
4498 goto syntax;
4499
4500 if (inquire->iolength != NULL)
4501 {
4502 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
4503 goto cleanup;
4504 }
4505 }
4506
4507 if (gfc_match_eos () != MATCH_YES)
4508 goto syntax;
4509
4510 if (inquire->unit != NULL && inquire->file != NULL)
4511 {
4512 gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
4513 "UNIT specifiers", &loc);
4514 goto cleanup;
4515 }
4516
4517 if (inquire->unit == NULL && inquire->file == NULL)
4518 {
4519 gfc_error ("INQUIRE statement at %L requires either FILE or "
4520 "UNIT specifier", &loc);
4521 goto cleanup;
4522 }
4523
4524 if (inquire->unit != NULL && inquire->unit->expr_type == EXPR_CONSTANT
4525 && inquire->unit->ts.type == BT_INTEGER
4526 && ((mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT4)
4527 || (mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT)))
4528 {
4529 gfc_error ("UNIT number in INQUIRE statement at %L can not "
4530 "be %d", &loc, (int) mpz_get_si (inquire->unit->value.integer));
4531 goto cleanup;
4532 }
4533
4534 if (gfc_pure (NULL))
4535 {
4536 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4537 goto cleanup;
4538 }
4539
4540 gfc_unset_implicit_pure (NULL);
4541
4542 if (inquire->id != NULL && inquire->pending == NULL)
4543 {
4544 gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
4545 "the ID= specifier", &loc);
4546 goto cleanup;
4547 }
4548
4549 new_st.op = EXEC_INQUIRE;
4550 new_st.ext.inquire = inquire;
4551 return MATCH_YES;
4552
4553 syntax:
4554 gfc_syntax_error (ST_INQUIRE);
4555
4556 cleanup:
4557 gfc_free_inquire (inquire);
4558 return MATCH_ERROR;
4559 }
4560
4561
4562 /* Resolve everything in a gfc_inquire structure. */
4563
4564 bool
4565 gfc_resolve_inquire (gfc_inquire *inquire)
4566 {
4567 RESOLVE_TAG (&tag_unit, inquire->unit);
4568 RESOLVE_TAG (&tag_file, inquire->file);
4569 RESOLVE_TAG (&tag_id, inquire->id);
4570
4571 /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4572 contexts. Thus, use an extended RESOLVE_TAG macro for that. */
4573 #define INQUIRE_RESOLVE_TAG(tag, expr) \
4574 RESOLVE_TAG (tag, expr); \
4575 if (expr) \
4576 { \
4577 char context[64]; \
4578 sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
4579 if (gfc_check_vardef_context ((expr), false, false, false, \
4580 context) == false) \
4581 return false; \
4582 }
4583 INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
4584 INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat);
4585 INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist);
4586 INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened);
4587 INQUIRE_RESOLVE_TAG (&tag_number, inquire->number);
4588 INQUIRE_RESOLVE_TAG (&tag_named, inquire->named);
4589 INQUIRE_RESOLVE_TAG (&tag_name, inquire->name);
4590 INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access);
4591 INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential);
4592 INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct);
4593 INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form);
4594 INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted);
4595 INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
4596 INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl);
4597 INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
4598 INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank);
4599 INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position);
4600 INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action);
4601 INQUIRE_RESOLVE_TAG (&tag_read, inquire->read);
4602 INQUIRE_RESOLVE_TAG (&tag_write, inquire->write);
4603 INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
4604 INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim);
4605 INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad);
4606 INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
4607 INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4608 INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength);
4609 INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert);
4610 INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
4611 INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
4612 INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign);
4613 INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4614 INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending);
4615 INQUIRE_RESOLVE_TAG (&tag_size, inquire->size);
4616 INQUIRE_RESOLVE_TAG (&tag_s_decimal, inquire->decimal);
4617 INQUIRE_RESOLVE_TAG (&tag_s_iqstream, inquire->iqstream);
4618 INQUIRE_RESOLVE_TAG (&tag_v_share, inquire->share);
4619 INQUIRE_RESOLVE_TAG (&tag_v_cc, inquire->cc);
4620 #undef INQUIRE_RESOLVE_TAG
4621
4622 if (!gfc_reference_st_label (inquire->err, ST_LABEL_TARGET))
4623 return false;
4624
4625 return true;
4626 }
4627
4628
4629 void
4630 gfc_free_wait (gfc_wait *wait)
4631 {
4632 if (wait == NULL)
4633 return;
4634
4635 gfc_free_expr (wait->unit);
4636 gfc_free_expr (wait->iostat);
4637 gfc_free_expr (wait->iomsg);
4638 gfc_free_expr (wait->id);
4639 free (wait);
4640 }
4641
4642
4643 bool
4644 gfc_resolve_wait (gfc_wait *wait)
4645 {
4646 RESOLVE_TAG (&tag_unit, wait->unit);
4647 RESOLVE_TAG (&tag_iomsg, wait->iomsg);
4648 RESOLVE_TAG (&tag_iostat, wait->iostat);
4649 RESOLVE_TAG (&tag_id, wait->id);
4650
4651 if (!gfc_reference_st_label (wait->err, ST_LABEL_TARGET))
4652 return false;
4653
4654 if (!gfc_reference_st_label (wait->end, ST_LABEL_TARGET))
4655 return false;
4656
4657 return true;
4658 }
4659
4660 /* Match an element of a WAIT statement. */
4661
4662 #define RETM if (m != MATCH_NO) return m;
4663
4664 static match
4665 match_wait_element (gfc_wait *wait)
4666 {
4667 match m;
4668
4669 m = match_etag (&tag_unit, &wait->unit);
4670 RETM m = match_ltag (&tag_err, &wait->err);
4671 RETM m = match_ltag (&tag_end, &wait->end);
4672 RETM m = match_ltag (&tag_eor, &wait->eor);
4673 RETM m = match_etag (&tag_iomsg, &wait->iomsg);
4674 if (m == MATCH_YES && !check_char_variable (wait->iomsg))
4675 return MATCH_ERROR;
4676 RETM m = match_out_tag (&tag_iostat, &wait->iostat);
4677 RETM m = match_etag (&tag_id, &wait->id);
4678 RETM return MATCH_NO;
4679 }
4680
4681 #undef RETM
4682
4683
4684 match
4685 gfc_match_wait (void)
4686 {
4687 gfc_wait *wait;
4688 match m;
4689
4690 m = gfc_match_char ('(');
4691 if (m == MATCH_NO)
4692 return m;
4693
4694 wait = XCNEW (gfc_wait);
4695
4696 m = match_wait_element (wait);
4697 if (m == MATCH_ERROR)
4698 goto cleanup;
4699 if (m == MATCH_NO)
4700 {
4701 m = gfc_match_expr (&wait->unit);
4702 if (m == MATCH_ERROR)
4703 goto cleanup;
4704 if (m == MATCH_NO)
4705 goto syntax;
4706 }
4707
4708 for (;;)
4709 {
4710 if (gfc_match_char (')') == MATCH_YES)
4711 break;
4712 if (gfc_match_char (',') != MATCH_YES)
4713 goto syntax;
4714
4715 m = match_wait_element (wait);
4716 if (m == MATCH_ERROR)
4717 goto cleanup;
4718 if (m == MATCH_NO)
4719 goto syntax;
4720 }
4721
4722 if (!gfc_notify_std (GFC_STD_F2003, "WAIT at %C "
4723 "not allowed in Fortran 95"))
4724 goto cleanup;
4725
4726 if (gfc_pure (NULL))
4727 {
4728 gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4729 goto cleanup;
4730 }
4731
4732 gfc_unset_implicit_pure (NULL);
4733
4734 new_st.op = EXEC_WAIT;
4735 new_st.ext.wait = wait;
4736
4737 return MATCH_YES;
4738
4739 syntax:
4740 gfc_syntax_error (ST_WAIT);
4741
4742 cleanup:
4743 gfc_free_wait (wait);
4744 return MATCH_ERROR;
4745 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org