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