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