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