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