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