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