]> 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
Replace enum gfc_try with bool type.
[thirdparty/gcc.git] / gcc / fortran / io.c
1 /* Deal with I/O statements & related stuff.
2 Copyright (C) 2000-2013 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 (gfc_option.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 string"
554 " 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 if (gfc_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
1309 {
1310 gfc_error ("Variable %s cannot be assigned in PURE procedure at %C",
1311 tag->name);
1312 gfc_free_expr (result);
1313 return MATCH_ERROR;
1314 }
1315
1316 if (gfc_implicit_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
1317 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1318
1319 *v = result;
1320 return MATCH_YES;
1321 }
1322
1323
1324 /* Match I/O tags that cause variables to become redefined. */
1325
1326 static match
1327 match_out_tag (const io_tag *tag, gfc_expr **result)
1328 {
1329 match m;
1330
1331 m = match_vtag (tag, result);
1332 if (m == MATCH_YES)
1333 gfc_check_do_variable ((*result)->symtree);
1334
1335 return m;
1336 }
1337
1338
1339 /* Match a label I/O tag. */
1340
1341 static match
1342 match_ltag (const io_tag *tag, gfc_st_label ** label)
1343 {
1344 match m;
1345 gfc_st_label *old;
1346
1347 old = *label;
1348 m = gfc_match (tag->spec);
1349 if (m != MATCH_YES)
1350 return m;
1351
1352 m = gfc_match (tag->value, label);
1353 if (m != MATCH_YES)
1354 {
1355 gfc_error ("Invalid value for %s specification at %C", tag->name);
1356 return MATCH_ERROR;
1357 }
1358
1359 if (old)
1360 {
1361 gfc_error ("Duplicate %s label specification at %C", tag->name);
1362 return MATCH_ERROR;
1363 }
1364
1365 if (!gfc_reference_st_label (*label, ST_LABEL_TARGET))
1366 return MATCH_ERROR;
1367
1368 return m;
1369 }
1370
1371
1372 /* Resolution of the FORMAT tag, to be called from resolve_tag. */
1373
1374 static bool
1375 resolve_tag_format (const gfc_expr *e)
1376 {
1377 if (e->expr_type == EXPR_CONSTANT
1378 && (e->ts.type != BT_CHARACTER
1379 || e->ts.kind != gfc_default_character_kind))
1380 {
1381 gfc_error ("Constant expression in FORMAT tag at %L must be "
1382 "of type default CHARACTER", &e->where);
1383 return false;
1384 }
1385
1386 /* If e's rank is zero and e is not an element of an array, it should be
1387 of integer or character type. The integer variable should be
1388 ASSIGNED. */
1389 if (e->rank == 0
1390 && (e->expr_type != EXPR_VARIABLE
1391 || e->symtree == NULL
1392 || e->symtree->n.sym->as == NULL
1393 || e->symtree->n.sym->as->rank == 0))
1394 {
1395 if ((e->ts.type != BT_CHARACTER
1396 || e->ts.kind != gfc_default_character_kind)
1397 && e->ts.type != BT_INTEGER)
1398 {
1399 gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER "
1400 "or of INTEGER", &e->where);
1401 return false;
1402 }
1403 else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
1404 {
1405 if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGNED variable in "
1406 "FORMAT tag at %L", &e->where))
1407 return false;
1408 if (e->symtree->n.sym->attr.assign != 1)
1409 {
1410 gfc_error ("Variable '%s' at %L has not been assigned a "
1411 "format label", e->symtree->n.sym->name, &e->where);
1412 return false;
1413 }
1414 }
1415 else if (e->ts.type == BT_INTEGER)
1416 {
1417 gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
1418 "variable", gfc_basic_typename (e->ts.type), &e->where);
1419 return false;
1420 }
1421
1422 return true;
1423 }
1424
1425 /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
1426 It may be assigned an Hollerith constant. */
1427 if (e->ts.type != BT_CHARACTER)
1428 {
1429 if (!gfc_notify_std (GFC_STD_LEGACY, "Non-character in FORMAT tag "
1430 "at %L", &e->where))
1431 return false;
1432
1433 if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)
1434 {
1435 gfc_error ("Non-character assumed shape array element in FORMAT"
1436 " tag at %L", &e->where);
1437 return false;
1438 }
1439
1440 if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
1441 {
1442 gfc_error ("Non-character assumed size array element in FORMAT"
1443 " tag at %L", &e->where);
1444 return false;
1445 }
1446
1447 if (e->rank == 0 && e->symtree->n.sym->attr.pointer)
1448 {
1449 gfc_error ("Non-character pointer array element in FORMAT tag at %L",
1450 &e->where);
1451 return false;
1452 }
1453 }
1454
1455 return true;
1456 }
1457
1458
1459 /* Do expression resolution and type-checking on an expression tag. */
1460
1461 static bool
1462 resolve_tag (const io_tag *tag, gfc_expr *e)
1463 {
1464 if (e == NULL)
1465 return true;
1466
1467 if (!gfc_resolve_expr (e))
1468 return false;
1469
1470 if (tag == &tag_format)
1471 return resolve_tag_format (e);
1472
1473 if (e->ts.type != tag->type)
1474 {
1475 gfc_error ("%s tag at %L must be of type %s", tag->name,
1476 &e->where, gfc_basic_typename (tag->type));
1477 return false;
1478 }
1479
1480 if (e->ts.type == BT_CHARACTER && e->ts.kind != gfc_default_character_kind)
1481 {
1482 gfc_error ("%s tag at %L must be a character string of default kind",
1483 tag->name, &e->where);
1484 return false;
1485 }
1486
1487 if (e->rank != 0)
1488 {
1489 gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
1490 return false;
1491 }
1492
1493 if (tag == &tag_iomsg)
1494 {
1495 if (!gfc_notify_std (GFC_STD_F2003, "IOMSG tag at %L", &e->where))
1496 return false;
1497 }
1498
1499 if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength)
1500 && e->ts.kind != gfc_default_integer_kind)
1501 {
1502 if (!gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
1503 "INTEGER in %s tag at %L", tag->name, &e->where))
1504 return false;
1505 }
1506
1507 if (tag == &tag_exist && e->ts.kind != gfc_default_logical_kind)
1508 {
1509 if (!gfc_notify_std (GFC_STD_F2008, "Nondefault LOGICAL "
1510 "in %s tag at %L", tag->name, &e->where))
1511 return false;
1512 }
1513
1514 if (tag == &tag_newunit)
1515 {
1516 if (!gfc_notify_std (GFC_STD_F2008, "NEWUNIT specifier at %L",
1517 &e->where))
1518 return false;
1519 }
1520
1521 /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */
1522 if (tag == &tag_newunit || tag == &tag_iostat
1523 || tag == &tag_size || tag == &tag_iomsg)
1524 {
1525 char context[64];
1526
1527 sprintf (context, _("%s tag"), tag->name);
1528 if (!gfc_check_vardef_context (e, false, false, false, context))
1529 return false;
1530 }
1531
1532 if (tag == &tag_convert)
1533 {
1534 if (!gfc_notify_std (GFC_STD_GNU, "CONVERT tag at %L", &e->where))
1535 return false;
1536 }
1537
1538 return true;
1539 }
1540
1541
1542 /* Match a single tag of an OPEN statement. */
1543
1544 static match
1545 match_open_element (gfc_open *open)
1546 {
1547 match m;
1548
1549 m = match_etag (&tag_e_async, &open->asynchronous);
1550 if (m != MATCH_NO)
1551 return m;
1552 m = match_etag (&tag_unit, &open->unit);
1553 if (m != MATCH_NO)
1554 return m;
1555 m = match_out_tag (&tag_iomsg, &open->iomsg);
1556 if (m != MATCH_NO)
1557 return m;
1558 m = match_out_tag (&tag_iostat, &open->iostat);
1559 if (m != MATCH_NO)
1560 return m;
1561 m = match_etag (&tag_file, &open->file);
1562 if (m != MATCH_NO)
1563 return m;
1564 m = match_etag (&tag_status, &open->status);
1565 if (m != MATCH_NO)
1566 return m;
1567 m = match_etag (&tag_e_access, &open->access);
1568 if (m != MATCH_NO)
1569 return m;
1570 m = match_etag (&tag_e_form, &open->form);
1571 if (m != MATCH_NO)
1572 return m;
1573 m = match_etag (&tag_e_recl, &open->recl);
1574 if (m != MATCH_NO)
1575 return m;
1576 m = match_etag (&tag_e_blank, &open->blank);
1577 if (m != MATCH_NO)
1578 return m;
1579 m = match_etag (&tag_e_position, &open->position);
1580 if (m != MATCH_NO)
1581 return m;
1582 m = match_etag (&tag_e_action, &open->action);
1583 if (m != MATCH_NO)
1584 return m;
1585 m = match_etag (&tag_e_delim, &open->delim);
1586 if (m != MATCH_NO)
1587 return m;
1588 m = match_etag (&tag_e_pad, &open->pad);
1589 if (m != MATCH_NO)
1590 return m;
1591 m = match_etag (&tag_e_decimal, &open->decimal);
1592 if (m != MATCH_NO)
1593 return m;
1594 m = match_etag (&tag_e_encoding, &open->encoding);
1595 if (m != MATCH_NO)
1596 return m;
1597 m = match_etag (&tag_e_round, &open->round);
1598 if (m != MATCH_NO)
1599 return m;
1600 m = match_etag (&tag_e_sign, &open->sign);
1601 if (m != MATCH_NO)
1602 return m;
1603 m = match_ltag (&tag_err, &open->err);
1604 if (m != MATCH_NO)
1605 return m;
1606 m = match_etag (&tag_convert, &open->convert);
1607 if (m != MATCH_NO)
1608 return m;
1609 m = match_out_tag (&tag_newunit, &open->newunit);
1610 if (m != MATCH_NO)
1611 return m;
1612
1613 return MATCH_NO;
1614 }
1615
1616
1617 /* Free the gfc_open structure and all the expressions it contains. */
1618
1619 void
1620 gfc_free_open (gfc_open *open)
1621 {
1622 if (open == NULL)
1623 return;
1624
1625 gfc_free_expr (open->unit);
1626 gfc_free_expr (open->iomsg);
1627 gfc_free_expr (open->iostat);
1628 gfc_free_expr (open->file);
1629 gfc_free_expr (open->status);
1630 gfc_free_expr (open->access);
1631 gfc_free_expr (open->form);
1632 gfc_free_expr (open->recl);
1633 gfc_free_expr (open->blank);
1634 gfc_free_expr (open->position);
1635 gfc_free_expr (open->action);
1636 gfc_free_expr (open->delim);
1637 gfc_free_expr (open->pad);
1638 gfc_free_expr (open->decimal);
1639 gfc_free_expr (open->encoding);
1640 gfc_free_expr (open->round);
1641 gfc_free_expr (open->sign);
1642 gfc_free_expr (open->convert);
1643 gfc_free_expr (open->asynchronous);
1644 gfc_free_expr (open->newunit);
1645 free (open);
1646 }
1647
1648
1649 /* Resolve everything in a gfc_open structure. */
1650
1651 bool
1652 gfc_resolve_open (gfc_open *open)
1653 {
1654
1655 RESOLVE_TAG (&tag_unit, open->unit);
1656 RESOLVE_TAG (&tag_iomsg, open->iomsg);
1657 RESOLVE_TAG (&tag_iostat, open->iostat);
1658 RESOLVE_TAG (&tag_file, open->file);
1659 RESOLVE_TAG (&tag_status, open->status);
1660 RESOLVE_TAG (&tag_e_access, open->access);
1661 RESOLVE_TAG (&tag_e_form, open->form);
1662 RESOLVE_TAG (&tag_e_recl, open->recl);
1663 RESOLVE_TAG (&tag_e_blank, open->blank);
1664 RESOLVE_TAG (&tag_e_position, open->position);
1665 RESOLVE_TAG (&tag_e_action, open->action);
1666 RESOLVE_TAG (&tag_e_delim, open->delim);
1667 RESOLVE_TAG (&tag_e_pad, open->pad);
1668 RESOLVE_TAG (&tag_e_decimal, open->decimal);
1669 RESOLVE_TAG (&tag_e_encoding, open->encoding);
1670 RESOLVE_TAG (&tag_e_async, open->asynchronous);
1671 RESOLVE_TAG (&tag_e_round, open->round);
1672 RESOLVE_TAG (&tag_e_sign, open->sign);
1673 RESOLVE_TAG (&tag_convert, open->convert);
1674 RESOLVE_TAG (&tag_newunit, open->newunit);
1675
1676 if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET))
1677 return false;
1678
1679 return true;
1680 }
1681
1682
1683 /* Check if a given value for a SPECIFIER is either in the list of values
1684 allowed in F95 or F2003, issuing an error message and returning a zero
1685 value if it is not allowed. */
1686
1687 static int
1688 compare_to_allowed_values (const char *specifier, const char *allowed[],
1689 const char *allowed_f2003[],
1690 const char *allowed_gnu[], gfc_char_t *value,
1691 const char *statement, bool warn)
1692 {
1693 int i;
1694 unsigned int len;
1695
1696 len = gfc_wide_strlen (value);
1697 if (len > 0)
1698 {
1699 for (len--; len > 0; len--)
1700 if (value[len] != ' ')
1701 break;
1702 len++;
1703 }
1704
1705 for (i = 0; allowed[i]; i++)
1706 if (len == strlen (allowed[i])
1707 && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
1708 return 1;
1709
1710 for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
1711 if (len == strlen (allowed_f2003[i])
1712 && gfc_wide_strncasecmp (value, allowed_f2003[i],
1713 strlen (allowed_f2003[i])) == 0)
1714 {
1715 notification n = gfc_notification_std (GFC_STD_F2003);
1716
1717 if (n == WARNING || (warn && n == ERROR))
1718 {
1719 gfc_warning ("Fortran 2003: %s specifier in %s statement at %C "
1720 "has value '%s'", specifier, statement,
1721 allowed_f2003[i]);
1722 return 1;
1723 }
1724 else
1725 if (n == ERROR)
1726 {
1727 gfc_notify_std (GFC_STD_F2003, "%s specifier in "
1728 "%s statement at %C has value '%s'", specifier,
1729 statement, allowed_f2003[i]);
1730 return 0;
1731 }
1732
1733 /* n == SILENT */
1734 return 1;
1735 }
1736
1737 for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
1738 if (len == strlen (allowed_gnu[i])
1739 && gfc_wide_strncasecmp (value, allowed_gnu[i],
1740 strlen (allowed_gnu[i])) == 0)
1741 {
1742 notification n = gfc_notification_std (GFC_STD_GNU);
1743
1744 if (n == WARNING || (warn && n == ERROR))
1745 {
1746 gfc_warning ("Extension: %s specifier in %s statement at %C "
1747 "has value '%s'", specifier, statement,
1748 allowed_gnu[i]);
1749 return 1;
1750 }
1751 else
1752 if (n == ERROR)
1753 {
1754 gfc_notify_std (GFC_STD_GNU, "%s specifier in "
1755 "%s statement at %C has value '%s'", specifier,
1756 statement, allowed_gnu[i]);
1757 return 0;
1758 }
1759
1760 /* n == SILENT */
1761 return 1;
1762 }
1763
1764 if (warn)
1765 {
1766 char *s = gfc_widechar_to_char (value, -1);
1767 gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
1768 specifier, statement, s);
1769 free (s);
1770 return 1;
1771 }
1772 else
1773 {
1774 char *s = gfc_widechar_to_char (value, -1);
1775 gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
1776 specifier, statement, s);
1777 free (s);
1778 return 0;
1779 }
1780 }
1781
1782
1783 /* Match an OPEN statement. */
1784
1785 match
1786 gfc_match_open (void)
1787 {
1788 gfc_open *open;
1789 match m;
1790 bool warn;
1791
1792 m = gfc_match_char ('(');
1793 if (m == MATCH_NO)
1794 return m;
1795
1796 open = XCNEW (gfc_open);
1797
1798 m = match_open_element (open);
1799
1800 if (m == MATCH_ERROR)
1801 goto cleanup;
1802 if (m == MATCH_NO)
1803 {
1804 m = gfc_match_expr (&open->unit);
1805 if (m == MATCH_ERROR)
1806 goto cleanup;
1807 }
1808
1809 for (;;)
1810 {
1811 if (gfc_match_char (')') == MATCH_YES)
1812 break;
1813 if (gfc_match_char (',') != MATCH_YES)
1814 goto syntax;
1815
1816 m = match_open_element (open);
1817 if (m == MATCH_ERROR)
1818 goto cleanup;
1819 if (m == MATCH_NO)
1820 goto syntax;
1821 }
1822
1823 if (gfc_match_eos () == MATCH_NO)
1824 goto syntax;
1825
1826 if (gfc_pure (NULL))
1827 {
1828 gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1829 goto cleanup;
1830 }
1831
1832 if (gfc_implicit_pure (NULL))
1833 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1834
1835 warn = (open->err || open->iostat) ? true : false;
1836
1837 /* Checks on NEWUNIT specifier. */
1838 if (open->newunit)
1839 {
1840 if (open->unit)
1841 {
1842 gfc_error ("UNIT specifier not allowed with NEWUNIT at %C");
1843 goto cleanup;
1844 }
1845
1846 if (!(open->file || (open->status
1847 && gfc_wide_strncasecmp (open->status->value.character.string,
1848 "scratch", 7) == 0)))
1849 {
1850 gfc_error ("NEWUNIT specifier must have FILE= "
1851 "or STATUS='scratch' at %C");
1852 goto cleanup;
1853 }
1854 }
1855 else if (!open->unit)
1856 {
1857 gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified");
1858 goto cleanup;
1859 }
1860
1861 /* Checks on the ACCESS specifier. */
1862 if (open->access && open->access->expr_type == EXPR_CONSTANT)
1863 {
1864 static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
1865 static const char *access_f2003[] = { "STREAM", NULL };
1866 static const char *access_gnu[] = { "APPEND", NULL };
1867
1868 if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
1869 access_gnu,
1870 open->access->value.character.string,
1871 "OPEN", warn))
1872 goto cleanup;
1873 }
1874
1875 /* Checks on the ACTION specifier. */
1876 if (open->action && open->action->expr_type == EXPR_CONSTANT)
1877 {
1878 static const char *action[] = { "READ", "WRITE", "READWRITE", NULL };
1879
1880 if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
1881 open->action->value.character.string,
1882 "OPEN", warn))
1883 goto cleanup;
1884 }
1885
1886 /* Checks on the ASYNCHRONOUS specifier. */
1887 if (open->asynchronous)
1888 {
1889 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %C "
1890 "not allowed in Fortran 95"))
1891 goto cleanup;
1892
1893 if (open->asynchronous->expr_type == EXPR_CONSTANT)
1894 {
1895 static const char * asynchronous[] = { "YES", "NO", NULL };
1896
1897 if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous,
1898 NULL, NULL, open->asynchronous->value.character.string,
1899 "OPEN", warn))
1900 goto cleanup;
1901 }
1902 }
1903
1904 /* Checks on the BLANK specifier. */
1905 if (open->blank)
1906 {
1907 if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C "
1908 "not allowed in Fortran 95"))
1909 goto cleanup;
1910
1911 if (open->blank->expr_type == EXPR_CONSTANT)
1912 {
1913 static const char *blank[] = { "ZERO", "NULL", NULL };
1914
1915 if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
1916 open->blank->value.character.string,
1917 "OPEN", warn))
1918 goto cleanup;
1919 }
1920 }
1921
1922 /* Checks on the DECIMAL specifier. */
1923 if (open->decimal)
1924 {
1925 if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C "
1926 "not allowed in Fortran 95"))
1927 goto cleanup;
1928
1929 if (open->decimal->expr_type == EXPR_CONSTANT)
1930 {
1931 static const char * decimal[] = { "COMMA", "POINT", NULL };
1932
1933 if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
1934 open->decimal->value.character.string,
1935 "OPEN", warn))
1936 goto cleanup;
1937 }
1938 }
1939
1940 /* Checks on the DELIM specifier. */
1941 if (open->delim)
1942 {
1943 if (open->delim->expr_type == EXPR_CONSTANT)
1944 {
1945 static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
1946
1947 if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
1948 open->delim->value.character.string,
1949 "OPEN", warn))
1950 goto cleanup;
1951 }
1952 }
1953
1954 /* Checks on the ENCODING specifier. */
1955 if (open->encoding)
1956 {
1957 if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %C "
1958 "not allowed in Fortran 95"))
1959 goto cleanup;
1960
1961 if (open->encoding->expr_type == EXPR_CONSTANT)
1962 {
1963 static const char * encoding[] = { "DEFAULT", "UTF-8", NULL };
1964
1965 if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
1966 open->encoding->value.character.string,
1967 "OPEN", warn))
1968 goto cleanup;
1969 }
1970 }
1971
1972 /* Checks on the FORM specifier. */
1973 if (open->form && open->form->expr_type == EXPR_CONSTANT)
1974 {
1975 static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
1976
1977 if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
1978 open->form->value.character.string,
1979 "OPEN", warn))
1980 goto cleanup;
1981 }
1982
1983 /* Checks on the PAD specifier. */
1984 if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
1985 {
1986 static const char *pad[] = { "YES", "NO", NULL };
1987
1988 if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
1989 open->pad->value.character.string,
1990 "OPEN", warn))
1991 goto cleanup;
1992 }
1993
1994 /* Checks on the POSITION specifier. */
1995 if (open->position && open->position->expr_type == EXPR_CONSTANT)
1996 {
1997 static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
1998
1999 if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
2000 open->position->value.character.string,
2001 "OPEN", warn))
2002 goto cleanup;
2003 }
2004
2005 /* Checks on the ROUND specifier. */
2006 if (open->round)
2007 {
2008 if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C "
2009 "not allowed in Fortran 95"))
2010 goto cleanup;
2011
2012 if (open->round->expr_type == EXPR_CONSTANT)
2013 {
2014 static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
2015 "COMPATIBLE", "PROCESSOR_DEFINED",
2016 NULL };
2017
2018 if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
2019 open->round->value.character.string,
2020 "OPEN", warn))
2021 goto cleanup;
2022 }
2023 }
2024
2025 /* Checks on the SIGN specifier. */
2026 if (open->sign)
2027 {
2028 if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %C "
2029 "not allowed in Fortran 95"))
2030 goto cleanup;
2031
2032 if (open->sign->expr_type == EXPR_CONSTANT)
2033 {
2034 static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
2035 NULL };
2036
2037 if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
2038 open->sign->value.character.string,
2039 "OPEN", warn))
2040 goto cleanup;
2041 }
2042 }
2043
2044 #define warn_or_error(...) \
2045 { \
2046 if (warn) \
2047 gfc_warning (__VA_ARGS__); \
2048 else \
2049 { \
2050 gfc_error (__VA_ARGS__); \
2051 goto cleanup; \
2052 } \
2053 }
2054
2055 /* Checks on the RECL specifier. */
2056 if (open->recl && open->recl->expr_type == EXPR_CONSTANT
2057 && open->recl->ts.type == BT_INTEGER
2058 && mpz_sgn (open->recl->value.integer) != 1)
2059 {
2060 warn_or_error ("RECL in OPEN statement at %C must be positive");
2061 }
2062
2063 /* Checks on the STATUS specifier. */
2064 if (open->status && open->status->expr_type == EXPR_CONSTANT)
2065 {
2066 static const char *status[] = { "OLD", "NEW", "SCRATCH",
2067 "REPLACE", "UNKNOWN", NULL };
2068
2069 if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2070 open->status->value.character.string,
2071 "OPEN", warn))
2072 goto cleanup;
2073
2074 /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2075 the FILE= specifier shall appear. */
2076 if (open->file == NULL
2077 && (gfc_wide_strncasecmp (open->status->value.character.string,
2078 "replace", 7) == 0
2079 || gfc_wide_strncasecmp (open->status->value.character.string,
2080 "new", 3) == 0))
2081 {
2082 char *s = gfc_widechar_to_char (open->status->value.character.string,
2083 -1);
2084 warn_or_error ("The STATUS specified in OPEN statement at %C is "
2085 "'%s' and no FILE specifier is present", s);
2086 free (s);
2087 }
2088
2089 /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2090 the FILE= specifier shall not appear. */
2091 if (gfc_wide_strncasecmp (open->status->value.character.string,
2092 "scratch", 7) == 0 && open->file)
2093 {
2094 warn_or_error ("The STATUS specified in OPEN statement at %C "
2095 "cannot have the value SCRATCH if a FILE specifier "
2096 "is present");
2097 }
2098 }
2099
2100 /* Things that are not allowed for unformatted I/O. */
2101 if (open->form && open->form->expr_type == EXPR_CONSTANT
2102 && (open->delim || open->decimal || open->encoding || open->round
2103 || open->sign || open->pad || open->blank)
2104 && gfc_wide_strncasecmp (open->form->value.character.string,
2105 "unformatted", 11) == 0)
2106 {
2107 const char *spec = (open->delim ? "DELIM "
2108 : (open->pad ? "PAD " : open->blank
2109 ? "BLANK " : ""));
2110
2111 warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
2112 "unformatted I/O", spec);
2113 }
2114
2115 if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
2116 && gfc_wide_strncasecmp (open->access->value.character.string,
2117 "stream", 6) == 0)
2118 {
2119 warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
2120 "stream I/O");
2121 }
2122
2123 if (open->position
2124 && open->access && open->access->expr_type == EXPR_CONSTANT
2125 && !(gfc_wide_strncasecmp (open->access->value.character.string,
2126 "sequential", 10) == 0
2127 || gfc_wide_strncasecmp (open->access->value.character.string,
2128 "stream", 6) == 0
2129 || gfc_wide_strncasecmp (open->access->value.character.string,
2130 "append", 6) == 0))
2131 {
2132 warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
2133 "for stream or sequential ACCESS");
2134 }
2135
2136 #undef warn_or_error
2137
2138 new_st.op = EXEC_OPEN;
2139 new_st.ext.open = open;
2140 return MATCH_YES;
2141
2142 syntax:
2143 gfc_syntax_error (ST_OPEN);
2144
2145 cleanup:
2146 gfc_free_open (open);
2147 return MATCH_ERROR;
2148 }
2149
2150
2151 /* Free a gfc_close structure an all its expressions. */
2152
2153 void
2154 gfc_free_close (gfc_close *close)
2155 {
2156 if (close == NULL)
2157 return;
2158
2159 gfc_free_expr (close->unit);
2160 gfc_free_expr (close->iomsg);
2161 gfc_free_expr (close->iostat);
2162 gfc_free_expr (close->status);
2163 free (close);
2164 }
2165
2166
2167 /* Match elements of a CLOSE statement. */
2168
2169 static match
2170 match_close_element (gfc_close *close)
2171 {
2172 match m;
2173
2174 m = match_etag (&tag_unit, &close->unit);
2175 if (m != MATCH_NO)
2176 return m;
2177 m = match_etag (&tag_status, &close->status);
2178 if (m != MATCH_NO)
2179 return m;
2180 m = match_out_tag (&tag_iomsg, &close->iomsg);
2181 if (m != MATCH_NO)
2182 return m;
2183 m = match_out_tag (&tag_iostat, &close->iostat);
2184 if (m != MATCH_NO)
2185 return m;
2186 m = match_ltag (&tag_err, &close->err);
2187 if (m != MATCH_NO)
2188 return m;
2189
2190 return MATCH_NO;
2191 }
2192
2193
2194 /* Match a CLOSE statement. */
2195
2196 match
2197 gfc_match_close (void)
2198 {
2199 gfc_close *close;
2200 match m;
2201 bool warn;
2202
2203 m = gfc_match_char ('(');
2204 if (m == MATCH_NO)
2205 return m;
2206
2207 close = XCNEW (gfc_close);
2208
2209 m = match_close_element (close);
2210
2211 if (m == MATCH_ERROR)
2212 goto cleanup;
2213 if (m == MATCH_NO)
2214 {
2215 m = gfc_match_expr (&close->unit);
2216 if (m == MATCH_NO)
2217 goto syntax;
2218 if (m == MATCH_ERROR)
2219 goto cleanup;
2220 }
2221
2222 for (;;)
2223 {
2224 if (gfc_match_char (')') == MATCH_YES)
2225 break;
2226 if (gfc_match_char (',') != MATCH_YES)
2227 goto syntax;
2228
2229 m = match_close_element (close);
2230 if (m == MATCH_ERROR)
2231 goto cleanup;
2232 if (m == MATCH_NO)
2233 goto syntax;
2234 }
2235
2236 if (gfc_match_eos () == MATCH_NO)
2237 goto syntax;
2238
2239 if (gfc_pure (NULL))
2240 {
2241 gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2242 goto cleanup;
2243 }
2244
2245 if (gfc_implicit_pure (NULL))
2246 gfc_current_ns->proc_name->attr.implicit_pure = 0;
2247
2248 warn = (close->iostat || close->err) ? true : false;
2249
2250 /* Checks on the STATUS specifier. */
2251 if (close->status && close->status->expr_type == EXPR_CONSTANT)
2252 {
2253 static const char *status[] = { "KEEP", "DELETE", NULL };
2254
2255 if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2256 close->status->value.character.string,
2257 "CLOSE", warn))
2258 goto cleanup;
2259 }
2260
2261 new_st.op = EXEC_CLOSE;
2262 new_st.ext.close = close;
2263 return MATCH_YES;
2264
2265 syntax:
2266 gfc_syntax_error (ST_CLOSE);
2267
2268 cleanup:
2269 gfc_free_close (close);
2270 return MATCH_ERROR;
2271 }
2272
2273
2274 /* Resolve everything in a gfc_close structure. */
2275
2276 bool
2277 gfc_resolve_close (gfc_close *close)
2278 {
2279 RESOLVE_TAG (&tag_unit, close->unit);
2280 RESOLVE_TAG (&tag_iomsg, close->iomsg);
2281 RESOLVE_TAG (&tag_iostat, close->iostat);
2282 RESOLVE_TAG (&tag_status, close->status);
2283
2284 if (!gfc_reference_st_label (close->err, ST_LABEL_TARGET))
2285 return false;
2286
2287 if (close->unit == NULL)
2288 {
2289 /* Find a locus from one of the arguments to close, when UNIT is
2290 not specified. */
2291 locus loc = gfc_current_locus;
2292 if (close->status)
2293 loc = close->status->where;
2294 else if (close->iostat)
2295 loc = close->iostat->where;
2296 else if (close->iomsg)
2297 loc = close->iomsg->where;
2298 else if (close->err)
2299 loc = close->err->where;
2300
2301 gfc_error ("CLOSE statement at %L requires a UNIT number", &loc);
2302 return false;
2303 }
2304
2305 if (close->unit->expr_type == EXPR_CONSTANT
2306 && close->unit->ts.type == BT_INTEGER
2307 && mpz_sgn (close->unit->value.integer) < 0)
2308 {
2309 gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2310 &close->unit->where);
2311 }
2312
2313 return true;
2314 }
2315
2316
2317 /* Free a gfc_filepos structure. */
2318
2319 void
2320 gfc_free_filepos (gfc_filepos *fp)
2321 {
2322 gfc_free_expr (fp->unit);
2323 gfc_free_expr (fp->iomsg);
2324 gfc_free_expr (fp->iostat);
2325 free (fp);
2326 }
2327
2328
2329 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
2330
2331 static match
2332 match_file_element (gfc_filepos *fp)
2333 {
2334 match m;
2335
2336 m = match_etag (&tag_unit, &fp->unit);
2337 if (m != MATCH_NO)
2338 return m;
2339 m = match_out_tag (&tag_iomsg, &fp->iomsg);
2340 if (m != MATCH_NO)
2341 return m;
2342 m = match_out_tag (&tag_iostat, &fp->iostat);
2343 if (m != MATCH_NO)
2344 return m;
2345 m = match_ltag (&tag_err, &fp->err);
2346 if (m != MATCH_NO)
2347 return m;
2348
2349 return MATCH_NO;
2350 }
2351
2352
2353 /* Match the second half of the file-positioning statements, REWIND,
2354 BACKSPACE, ENDFILE, or the FLUSH statement. */
2355
2356 static match
2357 match_filepos (gfc_statement st, gfc_exec_op op)
2358 {
2359 gfc_filepos *fp;
2360 match m;
2361
2362 fp = XCNEW (gfc_filepos);
2363
2364 if (gfc_match_char ('(') == MATCH_NO)
2365 {
2366 m = gfc_match_expr (&fp->unit);
2367 if (m == MATCH_ERROR)
2368 goto cleanup;
2369 if (m == MATCH_NO)
2370 goto syntax;
2371
2372 goto done;
2373 }
2374
2375 m = match_file_element (fp);
2376 if (m == MATCH_ERROR)
2377 goto done;
2378 if (m == MATCH_NO)
2379 {
2380 m = gfc_match_expr (&fp->unit);
2381 if (m == MATCH_ERROR)
2382 goto done;
2383 if (m == MATCH_NO)
2384 goto syntax;
2385 }
2386
2387 for (;;)
2388 {
2389 if (gfc_match_char (')') == MATCH_YES)
2390 break;
2391 if (gfc_match_char (',') != MATCH_YES)
2392 goto syntax;
2393
2394 m = match_file_element (fp);
2395 if (m == MATCH_ERROR)
2396 goto cleanup;
2397 if (m == MATCH_NO)
2398 goto syntax;
2399 }
2400
2401 done:
2402 if (gfc_match_eos () != MATCH_YES)
2403 goto syntax;
2404
2405 if (gfc_pure (NULL))
2406 {
2407 gfc_error ("%s statement not allowed in PURE procedure at %C",
2408 gfc_ascii_statement (st));
2409
2410 goto cleanup;
2411 }
2412
2413 if (gfc_implicit_pure (NULL))
2414 gfc_current_ns->proc_name->attr.implicit_pure = 0;
2415
2416 new_st.op = op;
2417 new_st.ext.filepos = fp;
2418 return MATCH_YES;
2419
2420 syntax:
2421 gfc_syntax_error (st);
2422
2423 cleanup:
2424 gfc_free_filepos (fp);
2425 return MATCH_ERROR;
2426 }
2427
2428
2429 bool
2430 gfc_resolve_filepos (gfc_filepos *fp)
2431 {
2432 RESOLVE_TAG (&tag_unit, fp->unit);
2433 RESOLVE_TAG (&tag_iostat, fp->iostat);
2434 RESOLVE_TAG (&tag_iomsg, fp->iomsg);
2435 if (!gfc_reference_st_label (fp->err, ST_LABEL_TARGET))
2436 return false;
2437
2438 if (fp->unit->expr_type == EXPR_CONSTANT
2439 && fp->unit->ts.type == BT_INTEGER
2440 && mpz_sgn (fp->unit->value.integer) < 0)
2441 {
2442 gfc_error ("UNIT number in statement at %L must be non-negative",
2443 &fp->unit->where);
2444 }
2445
2446 return true;
2447 }
2448
2449
2450 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2451 and the FLUSH statement. */
2452
2453 match
2454 gfc_match_endfile (void)
2455 {
2456 return match_filepos (ST_END_FILE, EXEC_ENDFILE);
2457 }
2458
2459 match
2460 gfc_match_backspace (void)
2461 {
2462 return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
2463 }
2464
2465 match
2466 gfc_match_rewind (void)
2467 {
2468 return match_filepos (ST_REWIND, EXEC_REWIND);
2469 }
2470
2471 match
2472 gfc_match_flush (void)
2473 {
2474 if (!gfc_notify_std (GFC_STD_F2003, "FLUSH statement at %C"))
2475 return MATCH_ERROR;
2476
2477 return match_filepos (ST_FLUSH, EXEC_FLUSH);
2478 }
2479
2480 /******************** Data Transfer Statements *********************/
2481
2482 /* Return a default unit number. */
2483
2484 static gfc_expr *
2485 default_unit (io_kind k)
2486 {
2487 int unit;
2488
2489 if (k == M_READ)
2490 unit = 5;
2491 else
2492 unit = 6;
2493
2494 return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit);
2495 }
2496
2497
2498 /* Match a unit specification for a data transfer statement. */
2499
2500 static match
2501 match_dt_unit (io_kind k, gfc_dt *dt)
2502 {
2503 gfc_expr *e;
2504
2505 if (gfc_match_char ('*') == MATCH_YES)
2506 {
2507 if (dt->io_unit != NULL)
2508 goto conflict;
2509
2510 dt->io_unit = default_unit (k);
2511 return MATCH_YES;
2512 }
2513
2514 if (gfc_match_expr (&e) == MATCH_YES)
2515 {
2516 if (dt->io_unit != NULL)
2517 {
2518 gfc_free_expr (e);
2519 goto conflict;
2520 }
2521
2522 dt->io_unit = e;
2523 return MATCH_YES;
2524 }
2525
2526 return MATCH_NO;
2527
2528 conflict:
2529 gfc_error ("Duplicate UNIT specification at %C");
2530 return MATCH_ERROR;
2531 }
2532
2533
2534 /* Match a format specification. */
2535
2536 static match
2537 match_dt_format (gfc_dt *dt)
2538 {
2539 locus where;
2540 gfc_expr *e;
2541 gfc_st_label *label;
2542 match m;
2543
2544 where = gfc_current_locus;
2545
2546 if (gfc_match_char ('*') == MATCH_YES)
2547 {
2548 if (dt->format_expr != NULL || dt->format_label != NULL)
2549 goto conflict;
2550
2551 dt->format_label = &format_asterisk;
2552 return MATCH_YES;
2553 }
2554
2555 if ((m = gfc_match_st_label (&label)) == MATCH_YES)
2556 {
2557 char c;
2558
2559 /* Need to check if the format label is actually either an operand
2560 to a user-defined operator or is a kind type parameter. That is,
2561 print 2.ip.8 ! .ip. is a user-defined operator return CHARACTER.
2562 print 1_'(I0)', i ! 1_'(I0)' is a default character string. */
2563
2564 gfc_gobble_whitespace ();
2565 c = gfc_peek_ascii_char ();
2566 if (c == '.' || c == '_')
2567 gfc_current_locus = where;
2568 else
2569 {
2570 if (dt->format_expr != NULL || dt->format_label != NULL)
2571 {
2572 gfc_free_st_label (label);
2573 goto conflict;
2574 }
2575
2576 if (!gfc_reference_st_label (label, ST_LABEL_FORMAT))
2577 return MATCH_ERROR;
2578
2579 dt->format_label = label;
2580 return MATCH_YES;
2581 }
2582 }
2583 else if (m == MATCH_ERROR)
2584 /* The label was zero or too large. Emit the correct diagnosis. */
2585 return MATCH_ERROR;
2586
2587 if (gfc_match_expr (&e) == MATCH_YES)
2588 {
2589 if (dt->format_expr != NULL || dt->format_label != NULL)
2590 {
2591 gfc_free_expr (e);
2592 goto conflict;
2593 }
2594 dt->format_expr = e;
2595 return MATCH_YES;
2596 }
2597
2598 gfc_current_locus = where; /* The only case where we have to restore */
2599
2600 return MATCH_NO;
2601
2602 conflict:
2603 gfc_error ("Duplicate format specification at %C");
2604 return MATCH_ERROR;
2605 }
2606
2607
2608 /* Traverse a namelist that is part of a READ statement to make sure
2609 that none of the variables in the namelist are INTENT(IN). Returns
2610 nonzero if we find such a variable. */
2611
2612 static int
2613 check_namelist (gfc_symbol *sym)
2614 {
2615 gfc_namelist *p;
2616
2617 for (p = sym->namelist; p; p = p->next)
2618 if (p->sym->attr.intent == INTENT_IN)
2619 {
2620 gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
2621 p->sym->name, sym->name);
2622 return 1;
2623 }
2624
2625 return 0;
2626 }
2627
2628
2629 /* Match a single data transfer element. */
2630
2631 static match
2632 match_dt_element (io_kind k, gfc_dt *dt)
2633 {
2634 char name[GFC_MAX_SYMBOL_LEN + 1];
2635 gfc_symbol *sym;
2636 match m;
2637
2638 if (gfc_match (" unit =") == MATCH_YES)
2639 {
2640 m = match_dt_unit (k, dt);
2641 if (m != MATCH_NO)
2642 return m;
2643 }
2644
2645 if (gfc_match (" fmt =") == MATCH_YES)
2646 {
2647 m = match_dt_format (dt);
2648 if (m != MATCH_NO)
2649 return m;
2650 }
2651
2652 if (gfc_match (" nml = %n", name) == MATCH_YES)
2653 {
2654 if (dt->namelist != NULL)
2655 {
2656 gfc_error ("Duplicate NML specification at %C");
2657 return MATCH_ERROR;
2658 }
2659
2660 if (gfc_find_symbol (name, NULL, 1, &sym))
2661 return MATCH_ERROR;
2662
2663 if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
2664 {
2665 gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
2666 sym != NULL ? sym->name : name);
2667 return MATCH_ERROR;
2668 }
2669
2670 dt->namelist = sym;
2671 if (k == M_READ && check_namelist (sym))
2672 return MATCH_ERROR;
2673
2674 return MATCH_YES;
2675 }
2676
2677 m = match_etag (&tag_e_async, &dt->asynchronous);
2678 if (m != MATCH_NO)
2679 return m;
2680 m = match_etag (&tag_e_blank, &dt->blank);
2681 if (m != MATCH_NO)
2682 return m;
2683 m = match_etag (&tag_e_delim, &dt->delim);
2684 if (m != MATCH_NO)
2685 return m;
2686 m = match_etag (&tag_e_pad, &dt->pad);
2687 if (m != MATCH_NO)
2688 return m;
2689 m = match_etag (&tag_e_sign, &dt->sign);
2690 if (m != MATCH_NO)
2691 return m;
2692 m = match_etag (&tag_e_round, &dt->round);
2693 if (m != MATCH_NO)
2694 return m;
2695 m = match_out_tag (&tag_id, &dt->id);
2696 if (m != MATCH_NO)
2697 return m;
2698 m = match_etag (&tag_e_decimal, &dt->decimal);
2699 if (m != MATCH_NO)
2700 return m;
2701 m = match_etag (&tag_rec, &dt->rec);
2702 if (m != MATCH_NO)
2703 return m;
2704 m = match_etag (&tag_spos, &dt->pos);
2705 if (m != MATCH_NO)
2706 return m;
2707 m = match_out_tag (&tag_iomsg, &dt->iomsg);
2708 if (m != MATCH_NO)
2709 return m;
2710 m = match_out_tag (&tag_iostat, &dt->iostat);
2711 if (m != MATCH_NO)
2712 return m;
2713 m = match_ltag (&tag_err, &dt->err);
2714 if (m == MATCH_YES)
2715 dt->err_where = gfc_current_locus;
2716 if (m != MATCH_NO)
2717 return m;
2718 m = match_etag (&tag_advance, &dt->advance);
2719 if (m != MATCH_NO)
2720 return m;
2721 m = match_out_tag (&tag_size, &dt->size);
2722 if (m != MATCH_NO)
2723 return m;
2724
2725 m = match_ltag (&tag_end, &dt->end);
2726 if (m == MATCH_YES)
2727 {
2728 if (k == M_WRITE)
2729 {
2730 gfc_error ("END tag at %C not allowed in output statement");
2731 return MATCH_ERROR;
2732 }
2733 dt->end_where = gfc_current_locus;
2734 }
2735 if (m != MATCH_NO)
2736 return m;
2737
2738 m = match_ltag (&tag_eor, &dt->eor);
2739 if (m == MATCH_YES)
2740 dt->eor_where = gfc_current_locus;
2741 if (m != MATCH_NO)
2742 return m;
2743
2744 return MATCH_NO;
2745 }
2746
2747
2748 /* Free a data transfer structure and everything below it. */
2749
2750 void
2751 gfc_free_dt (gfc_dt *dt)
2752 {
2753 if (dt == NULL)
2754 return;
2755
2756 gfc_free_expr (dt->io_unit);
2757 gfc_free_expr (dt->format_expr);
2758 gfc_free_expr (dt->rec);
2759 gfc_free_expr (dt->advance);
2760 gfc_free_expr (dt->iomsg);
2761 gfc_free_expr (dt->iostat);
2762 gfc_free_expr (dt->size);
2763 gfc_free_expr (dt->pad);
2764 gfc_free_expr (dt->delim);
2765 gfc_free_expr (dt->sign);
2766 gfc_free_expr (dt->round);
2767 gfc_free_expr (dt->blank);
2768 gfc_free_expr (dt->decimal);
2769 gfc_free_expr (dt->pos);
2770 gfc_free_expr (dt->dt_io_kind);
2771 /* dt->extra_comma is a link to dt_io_kind if it is set. */
2772 free (dt);
2773 }
2774
2775
2776 /* Resolve everything in a gfc_dt structure. */
2777
2778 bool
2779 gfc_resolve_dt (gfc_dt *dt, locus *loc)
2780 {
2781 gfc_expr *e;
2782 io_kind k;
2783
2784 /* This is set in any case. */
2785 gcc_assert (dt->dt_io_kind);
2786 k = dt->dt_io_kind->value.iokind;
2787
2788 RESOLVE_TAG (&tag_format, dt->format_expr);
2789 RESOLVE_TAG (&tag_rec, dt->rec);
2790 RESOLVE_TAG (&tag_spos, dt->pos);
2791 RESOLVE_TAG (&tag_advance, dt->advance);
2792 RESOLVE_TAG (&tag_id, dt->id);
2793 RESOLVE_TAG (&tag_iomsg, dt->iomsg);
2794 RESOLVE_TAG (&tag_iostat, dt->iostat);
2795 RESOLVE_TAG (&tag_size, dt->size);
2796 RESOLVE_TAG (&tag_e_pad, dt->pad);
2797 RESOLVE_TAG (&tag_e_delim, dt->delim);
2798 RESOLVE_TAG (&tag_e_sign, dt->sign);
2799 RESOLVE_TAG (&tag_e_round, dt->round);
2800 RESOLVE_TAG (&tag_e_blank, dt->blank);
2801 RESOLVE_TAG (&tag_e_decimal, dt->decimal);
2802 RESOLVE_TAG (&tag_e_async, dt->asynchronous);
2803
2804 e = dt->io_unit;
2805 if (e == NULL)
2806 {
2807 gfc_error ("UNIT not specified at %L", loc);
2808 return false;
2809 }
2810
2811 if (gfc_resolve_expr (e)
2812 && (e->ts.type != BT_INTEGER
2813 && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
2814 {
2815 /* If there is no extra comma signifying the "format" form of the IO
2816 statement, then this must be an error. */
2817 if (!dt->extra_comma)
2818 {
2819 gfc_error ("UNIT specification at %L must be an INTEGER expression "
2820 "or a CHARACTER variable", &e->where);
2821 return false;
2822 }
2823 else
2824 {
2825 /* At this point, we have an extra comma. If io_unit has arrived as
2826 type character, we assume its really the "format" form of the I/O
2827 statement. We set the io_unit to the default unit and format to
2828 the character expression. See F95 Standard section 9.4. */
2829 if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
2830 {
2831 dt->format_expr = dt->io_unit;
2832 dt->io_unit = default_unit (k);
2833
2834 /* Nullify this pointer now so that a warning/error is not
2835 triggered below for the "Extension". */
2836 dt->extra_comma = NULL;
2837 }
2838
2839 if (k == M_WRITE)
2840 {
2841 gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
2842 &dt->extra_comma->where);
2843 return false;
2844 }
2845 }
2846 }
2847
2848 if (e->ts.type == BT_CHARACTER)
2849 {
2850 if (gfc_has_vector_index (e))
2851 {
2852 gfc_error ("Internal unit with vector subscript at %L", &e->where);
2853 return false;
2854 }
2855
2856 /* If we are writing, make sure the internal unit can be changed. */
2857 gcc_assert (k != M_PRINT);
2858 if (k == M_WRITE
2859 && !gfc_check_vardef_context (e, false, false, false,
2860 _("internal unit in WRITE")))
2861 return false;
2862 }
2863
2864 if (e->rank && e->ts.type != BT_CHARACTER)
2865 {
2866 gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
2867 return false;
2868 }
2869
2870 if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER
2871 && mpz_sgn (e->value.integer) < 0)
2872 {
2873 gfc_error ("UNIT number in statement at %L must be non-negative",
2874 &e->where);
2875 return false;
2876 }
2877
2878 /* If we are reading and have a namelist, check that all namelist symbols
2879 can appear in a variable definition context. */
2880 if (k == M_READ && dt->namelist)
2881 {
2882 gfc_namelist* n;
2883 for (n = dt->namelist->namelist; n; n = n->next)
2884 {
2885 gfc_expr* e;
2886 bool t;
2887
2888 e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
2889 t = gfc_check_vardef_context (e, false, false, false, NULL);
2890 gfc_free_expr (e);
2891
2892 if (!t)
2893 {
2894 gfc_error ("NAMELIST '%s' in READ statement at %L contains"
2895 " the symbol '%s' which may not appear in a"
2896 " variable definition context",
2897 dt->namelist->name, loc, n->sym->name);
2898 return false;
2899 }
2900 }
2901 }
2902
2903 if (dt->extra_comma
2904 && !gfc_notify_std (GFC_STD_GNU, "Comma before i/o item list at %L",
2905 &dt->extra_comma->where))
2906 return false;
2907
2908 if (dt->err)
2909 {
2910 if (!gfc_reference_st_label (dt->err, ST_LABEL_TARGET))
2911 return false;
2912 if (dt->err->defined == ST_LABEL_UNKNOWN)
2913 {
2914 gfc_error ("ERR tag label %d at %L not defined",
2915 dt->err->value, &dt->err_where);
2916 return false;
2917 }
2918 }
2919
2920 if (dt->end)
2921 {
2922 if (!gfc_reference_st_label (dt->end, ST_LABEL_TARGET))
2923 return false;
2924 if (dt->end->defined == ST_LABEL_UNKNOWN)
2925 {
2926 gfc_error ("END tag label %d at %L not defined",
2927 dt->end->value, &dt->end_where);
2928 return false;
2929 }
2930 }
2931
2932 if (dt->eor)
2933 {
2934 if (!gfc_reference_st_label (dt->eor, ST_LABEL_TARGET))
2935 return false;
2936 if (dt->eor->defined == ST_LABEL_UNKNOWN)
2937 {
2938 gfc_error ("EOR tag label %d at %L not defined",
2939 dt->eor->value, &dt->eor_where);
2940 return false;
2941 }
2942 }
2943
2944 /* Check the format label actually exists. */
2945 if (dt->format_label && dt->format_label != &format_asterisk
2946 && dt->format_label->defined == ST_LABEL_UNKNOWN)
2947 {
2948 gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
2949 &dt->format_label->where);
2950 return false;
2951 }
2952
2953 return true;
2954 }
2955
2956
2957 /* Given an io_kind, return its name. */
2958
2959 static const char *
2960 io_kind_name (io_kind k)
2961 {
2962 const char *name;
2963
2964 switch (k)
2965 {
2966 case M_READ:
2967 name = "READ";
2968 break;
2969 case M_WRITE:
2970 name = "WRITE";
2971 break;
2972 case M_PRINT:
2973 name = "PRINT";
2974 break;
2975 case M_INQUIRE:
2976 name = "INQUIRE";
2977 break;
2978 default:
2979 gfc_internal_error ("io_kind_name(): bad I/O-kind");
2980 }
2981
2982 return name;
2983 }
2984
2985
2986 /* Match an IO iteration statement of the form:
2987
2988 ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
2989
2990 which is equivalent to a single IO element. This function is
2991 mutually recursive with match_io_element(). */
2992
2993 static match match_io_element (io_kind, gfc_code **);
2994
2995 static match
2996 match_io_iterator (io_kind k, gfc_code **result)
2997 {
2998 gfc_code *head, *tail, *new_code;
2999 gfc_iterator *iter;
3000 locus old_loc;
3001 match m;
3002 int n;
3003
3004 iter = NULL;
3005 head = NULL;
3006 old_loc = gfc_current_locus;
3007
3008 if (gfc_match_char ('(') != MATCH_YES)
3009 return MATCH_NO;
3010
3011 m = match_io_element (k, &head);
3012 tail = head;
3013
3014 if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
3015 {
3016 m = MATCH_NO;
3017 goto cleanup;
3018 }
3019
3020 /* Can't be anything but an IO iterator. Build a list. */
3021 iter = gfc_get_iterator ();
3022
3023 for (n = 1;; n++)
3024 {
3025 m = gfc_match_iterator (iter, 0);
3026 if (m == MATCH_ERROR)
3027 goto cleanup;
3028 if (m == MATCH_YES)
3029 {
3030 gfc_check_do_variable (iter->var->symtree);
3031 break;
3032 }
3033
3034 m = match_io_element (k, &new_code);
3035 if (m == MATCH_ERROR)
3036 goto cleanup;
3037 if (m == MATCH_NO)
3038 {
3039 if (n > 2)
3040 goto syntax;
3041 goto cleanup;
3042 }
3043
3044 tail = gfc_append_code (tail, new_code);
3045
3046 if (gfc_match_char (',') != MATCH_YES)
3047 {
3048 if (n > 2)
3049 goto syntax;
3050 m = MATCH_NO;
3051 goto cleanup;
3052 }
3053 }
3054
3055 if (gfc_match_char (')') != MATCH_YES)
3056 goto syntax;
3057
3058 new_code = gfc_get_code ();
3059 new_code->op = EXEC_DO;
3060 new_code->ext.iterator = iter;
3061
3062 new_code->block = gfc_get_code ();
3063 new_code->block->op = EXEC_DO;
3064 new_code->block->next = head;
3065
3066 *result = new_code;
3067 return MATCH_YES;
3068
3069 syntax:
3070 gfc_error ("Syntax error in I/O iterator at %C");
3071 m = MATCH_ERROR;
3072
3073 cleanup:
3074 gfc_free_iterator (iter, 1);
3075 gfc_free_statements (head);
3076 gfc_current_locus = old_loc;
3077 return m;
3078 }
3079
3080
3081 /* Match a single element of an IO list, which is either a single
3082 expression or an IO Iterator. */
3083
3084 static match
3085 match_io_element (io_kind k, gfc_code **cpp)
3086 {
3087 gfc_expr *expr;
3088 gfc_code *cp;
3089 match m;
3090
3091 expr = NULL;
3092
3093 m = match_io_iterator (k, cpp);
3094 if (m == MATCH_YES)
3095 return MATCH_YES;
3096
3097 if (k == M_READ)
3098 {
3099 m = gfc_match_variable (&expr, 0);
3100 if (m == MATCH_NO)
3101 gfc_error ("Expected variable in READ statement at %C");
3102 }
3103 else
3104 {
3105 m = gfc_match_expr (&expr);
3106 if (m == MATCH_NO)
3107 gfc_error ("Expected expression in %s statement at %C",
3108 io_kind_name (k));
3109 }
3110
3111 if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree))
3112 m = MATCH_ERROR;
3113
3114 if (m != MATCH_YES)
3115 {
3116 gfc_free_expr (expr);
3117 return MATCH_ERROR;
3118 }
3119
3120 cp = gfc_get_code ();
3121 cp->op = EXEC_TRANSFER;
3122 cp->expr1 = expr;
3123 if (k != M_INQUIRE)
3124 cp->ext.dt = current_dt;
3125
3126 *cpp = cp;
3127 return MATCH_YES;
3128 }
3129
3130
3131 /* Match an I/O list, building gfc_code structures as we go. */
3132
3133 static match
3134 match_io_list (io_kind k, gfc_code **head_p)
3135 {
3136 gfc_code *head, *tail, *new_code;
3137 match m;
3138
3139 *head_p = head = tail = NULL;
3140 if (gfc_match_eos () == MATCH_YES)
3141 return MATCH_YES;
3142
3143 for (;;)
3144 {
3145 m = match_io_element (k, &new_code);
3146 if (m == MATCH_ERROR)
3147 goto cleanup;
3148 if (m == MATCH_NO)
3149 goto syntax;
3150
3151 tail = gfc_append_code (tail, new_code);
3152 if (head == NULL)
3153 head = new_code;
3154
3155 if (gfc_match_eos () == MATCH_YES)
3156 break;
3157 if (gfc_match_char (',') != MATCH_YES)
3158 goto syntax;
3159 }
3160
3161 *head_p = head;
3162 return MATCH_YES;
3163
3164 syntax:
3165 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3166
3167 cleanup:
3168 gfc_free_statements (head);
3169 return MATCH_ERROR;
3170 }
3171
3172
3173 /* Attach the data transfer end node. */
3174
3175 static void
3176 terminate_io (gfc_code *io_code)
3177 {
3178 gfc_code *c;
3179
3180 if (io_code == NULL)
3181 io_code = new_st.block;
3182
3183 c = gfc_get_code ();
3184 c->op = EXEC_DT_END;
3185
3186 /* Point to structure that is already there */
3187 c->ext.dt = new_st.ext.dt;
3188 gfc_append_code (io_code, c);
3189 }
3190
3191
3192 /* Check the constraints for a data transfer statement. The majority of the
3193 constraints appearing in 9.4 of the standard appear here. Some are handled
3194 in resolve_tag and others in gfc_resolve_dt. */
3195
3196 static match
3197 check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
3198 locus *spec_end)
3199 {
3200 #define io_constraint(condition,msg,arg)\
3201 if (condition) \
3202 {\
3203 gfc_error(msg,arg);\
3204 m = MATCH_ERROR;\
3205 }
3206
3207 match m;
3208 gfc_expr *expr;
3209 gfc_symbol *sym = NULL;
3210 bool warn, unformatted;
3211
3212 warn = (dt->err || dt->iostat) ? true : false;
3213 unformatted = dt->format_expr == NULL && dt->format_label == NULL
3214 && dt->namelist == NULL;
3215
3216 m = MATCH_YES;
3217
3218 expr = dt->io_unit;
3219 if (expr && expr->expr_type == EXPR_VARIABLE
3220 && expr->ts.type == BT_CHARACTER)
3221 {
3222 sym = expr->symtree->n.sym;
3223
3224 io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
3225 "Internal file at %L must not be INTENT(IN)",
3226 &expr->where);
3227
3228 io_constraint (gfc_has_vector_index (dt->io_unit),
3229 "Internal file incompatible with vector subscript at %L",
3230 &expr->where);
3231
3232 io_constraint (dt->rec != NULL,
3233 "REC tag at %L is incompatible with internal file",
3234 &dt->rec->where);
3235
3236 io_constraint (dt->pos != NULL,
3237 "POS tag at %L is incompatible with internal file",
3238 &dt->pos->where);
3239
3240 io_constraint (unformatted,
3241 "Unformatted I/O not allowed with internal unit at %L",
3242 &dt->io_unit->where);
3243
3244 io_constraint (dt->asynchronous != NULL,
3245 "ASYNCHRONOUS tag at %L not allowed with internal file",
3246 &dt->asynchronous->where);
3247
3248 if (dt->namelist != NULL)
3249 {
3250 if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with "
3251 "namelist", &expr->where))
3252 m = MATCH_ERROR;
3253 }
3254
3255 io_constraint (dt->advance != NULL,
3256 "ADVANCE tag at %L is incompatible with internal file",
3257 &dt->advance->where);
3258 }
3259
3260 if (expr && expr->ts.type != BT_CHARACTER)
3261 {
3262
3263 io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE),
3264 "IO UNIT in %s statement at %C must be "
3265 "an internal file in a PURE procedure",
3266 io_kind_name (k));
3267
3268 if (gfc_implicit_pure (NULL) && (k == M_READ || k == M_WRITE))
3269 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3270
3271 }
3272
3273 if (k != M_READ)
3274 {
3275 io_constraint (dt->end, "END tag not allowed with output at %L",
3276 &dt->end_where);
3277
3278 io_constraint (dt->eor, "EOR tag not allowed with output at %L",
3279 &dt->eor_where);
3280
3281 io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L",
3282 &dt->blank->where);
3283
3284 io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
3285 &dt->pad->where);
3286
3287 io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
3288 &dt->size->where);
3289 }
3290 else
3291 {
3292 io_constraint (dt->size && dt->advance == NULL,
3293 "SIZE tag at %L requires an ADVANCE tag",
3294 &dt->size->where);
3295
3296 io_constraint (dt->eor && dt->advance == NULL,
3297 "EOR tag at %L requires an ADVANCE tag",
3298 &dt->eor_where);
3299 }
3300
3301 if (dt->asynchronous)
3302 {
3303 static const char * asynchronous[] = { "YES", "NO", NULL };
3304
3305 if (!gfc_reduce_init_expr (dt->asynchronous))
3306 {
3307 gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3308 "expression", &dt->asynchronous->where);
3309 return MATCH_ERROR;
3310 }
3311
3312 if (!compare_to_allowed_values
3313 ("ASYNCHRONOUS", asynchronous, NULL, NULL,
3314 dt->asynchronous->value.character.string,
3315 io_kind_name (k), warn))
3316 return MATCH_ERROR;
3317 }
3318
3319 if (dt->id)
3320 {
3321 bool not_yes
3322 = !dt->asynchronous
3323 || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
3324 || gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
3325 "yes", 3) != 0;
3326 io_constraint (not_yes,
3327 "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3328 "specifier", &dt->id->where);
3329 }
3330
3331 if (dt->decimal)
3332 {
3333 if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C "
3334 "not allowed in Fortran 95"))
3335 return MATCH_ERROR;
3336
3337 if (dt->decimal->expr_type == EXPR_CONSTANT)
3338 {
3339 static const char * decimal[] = { "COMMA", "POINT", NULL };
3340
3341 if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
3342 dt->decimal->value.character.string,
3343 io_kind_name (k), warn))
3344 return MATCH_ERROR;
3345
3346 io_constraint (unformatted,
3347 "the DECIMAL= specifier at %L must be with an "
3348 "explicit format expression", &dt->decimal->where);
3349 }
3350 }
3351
3352 if (dt->blank)
3353 {
3354 if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C "
3355 "not allowed in Fortran 95"))
3356 return MATCH_ERROR;
3357
3358 if (dt->blank->expr_type == EXPR_CONSTANT)
3359 {
3360 static const char * blank[] = { "NULL", "ZERO", NULL };
3361
3362 if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
3363 dt->blank->value.character.string,
3364 io_kind_name (k), warn))
3365 return MATCH_ERROR;
3366
3367 io_constraint (unformatted,
3368 "the BLANK= specifier at %L must be with an "
3369 "explicit format expression", &dt->blank->where);
3370 }
3371 }
3372
3373 if (dt->pad)
3374 {
3375 if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %C "
3376 "not allowed in Fortran 95"))
3377 return MATCH_ERROR;
3378
3379 if (dt->pad->expr_type == EXPR_CONSTANT)
3380 {
3381 static const char * pad[] = { "YES", "NO", NULL };
3382
3383 if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
3384 dt->pad->value.character.string,
3385 io_kind_name (k), warn))
3386 return MATCH_ERROR;
3387
3388 io_constraint (unformatted,
3389 "the PAD= specifier at %L must be with an "
3390 "explicit format expression", &dt->pad->where);
3391 }
3392 }
3393
3394 if (dt->round)
3395 {
3396 if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C "
3397 "not allowed in Fortran 95"))
3398 return MATCH_ERROR;
3399
3400 if (dt->round->expr_type == EXPR_CONSTANT)
3401 {
3402 static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
3403 "COMPATIBLE", "PROCESSOR_DEFINED",
3404 NULL };
3405
3406 if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
3407 dt->round->value.character.string,
3408 io_kind_name (k), warn))
3409 return MATCH_ERROR;
3410 }
3411 }
3412
3413 if (dt->sign)
3414 {
3415 /* When implemented, change the following to use gfc_notify_std F2003.
3416 if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C "
3417 "not allowed in Fortran 95") == false)
3418 return MATCH_ERROR; */
3419 if (dt->sign->expr_type == EXPR_CONSTANT)
3420 {
3421 static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3422 NULL };
3423
3424 if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
3425 dt->sign->value.character.string,
3426 io_kind_name (k), warn))
3427 return MATCH_ERROR;
3428
3429 io_constraint (unformatted,
3430 "SIGN= specifier at %L must be with an "
3431 "explicit format expression", &dt->sign->where);
3432
3433 io_constraint (k == M_READ,
3434 "SIGN= specifier at %L not allowed in a "
3435 "READ statement", &dt->sign->where);
3436 }
3437 }
3438
3439 if (dt->delim)
3440 {
3441 if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %C "
3442 "not allowed in Fortran 95"))
3443 return MATCH_ERROR;
3444
3445 if (dt->delim->expr_type == EXPR_CONSTANT)
3446 {
3447 static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
3448
3449 if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
3450 dt->delim->value.character.string,
3451 io_kind_name (k), warn))
3452 return MATCH_ERROR;
3453
3454 io_constraint (k == M_READ,
3455 "DELIM= specifier at %L not allowed in a "
3456 "READ statement", &dt->delim->where);
3457
3458 io_constraint (dt->format_label != &format_asterisk
3459 && dt->namelist == NULL,
3460 "DELIM= specifier at %L must have FMT=*",
3461 &dt->delim->where);
3462
3463 io_constraint (unformatted && dt->namelist == NULL,
3464 "DELIM= specifier at %L must be with FMT=* or "
3465 "NML= specifier ", &dt->delim->where);
3466 }
3467 }
3468
3469 if (dt->namelist)
3470 {
3471 io_constraint (io_code && dt->namelist,
3472 "NAMELIST cannot be followed by IO-list at %L",
3473 &io_code->loc);
3474
3475 io_constraint (dt->format_expr,
3476 "IO spec-list cannot contain both NAMELIST group name "
3477 "and format specification at %L",
3478 &dt->format_expr->where);
3479
3480 io_constraint (dt->format_label,
3481 "IO spec-list cannot contain both NAMELIST group name "
3482 "and format label at %L", spec_end);
3483
3484 io_constraint (dt->rec,
3485 "NAMELIST IO is not allowed with a REC= specifier "
3486 "at %L", &dt->rec->where);
3487
3488 io_constraint (dt->advance,
3489 "NAMELIST IO is not allowed with a ADVANCE= specifier "
3490 "at %L", &dt->advance->where);
3491 }
3492
3493 if (dt->rec)
3494 {
3495 io_constraint (dt->end,
3496 "An END tag is not allowed with a "
3497 "REC= specifier at %L", &dt->end_where);
3498
3499 io_constraint (dt->format_label == &format_asterisk,
3500 "FMT=* is not allowed with a REC= specifier "
3501 "at %L", spec_end);
3502
3503 io_constraint (dt->pos,
3504 "POS= is not allowed with REC= specifier "
3505 "at %L", &dt->pos->where);
3506 }
3507
3508 if (dt->advance)
3509 {
3510 int not_yes, not_no;
3511 expr = dt->advance;
3512
3513 io_constraint (dt->format_label == &format_asterisk,
3514 "List directed format(*) is not allowed with a "
3515 "ADVANCE= specifier at %L.", &expr->where);
3516
3517 io_constraint (unformatted,
3518 "the ADVANCE= specifier at %L must appear with an "
3519 "explicit format expression", &expr->where);
3520
3521 if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
3522 {
3523 const gfc_char_t *advance = expr->value.character.string;
3524 not_no = gfc_wide_strlen (advance) != 2
3525 || gfc_wide_strncasecmp (advance, "no", 2) != 0;
3526 not_yes = gfc_wide_strlen (advance) != 3
3527 || gfc_wide_strncasecmp (advance, "yes", 3) != 0;
3528 }
3529 else
3530 {
3531 not_no = 0;
3532 not_yes = 0;
3533 }
3534
3535 io_constraint (not_no && not_yes,
3536 "ADVANCE= specifier at %L must have value = "
3537 "YES or NO.", &expr->where);
3538
3539 io_constraint (dt->size && not_no && k == M_READ,
3540 "SIZE tag at %L requires an ADVANCE = 'NO'",
3541 &dt->size->where);
3542
3543 io_constraint (dt->eor && not_no && k == M_READ,
3544 "EOR tag at %L requires an ADVANCE = 'NO'",
3545 &dt->eor_where);
3546 }
3547
3548 expr = dt->format_expr;
3549 if (!gfc_simplify_expr (expr, 0)
3550 || !check_format_string (expr, k == M_READ))
3551 return MATCH_ERROR;
3552
3553 return m;
3554 }
3555 #undef io_constraint
3556
3557
3558 /* Match a READ, WRITE or PRINT statement. */
3559
3560 static match
3561 match_io (io_kind k)
3562 {
3563 char name[GFC_MAX_SYMBOL_LEN + 1];
3564 gfc_code *io_code;
3565 gfc_symbol *sym;
3566 int comma_flag;
3567 locus where;
3568 locus spec_end;
3569 gfc_dt *dt;
3570 match m;
3571
3572 where = gfc_current_locus;
3573 comma_flag = 0;
3574 current_dt = dt = XCNEW (gfc_dt);
3575 m = gfc_match_char ('(');
3576 if (m == MATCH_NO)
3577 {
3578 where = gfc_current_locus;
3579 if (k == M_WRITE)
3580 goto syntax;
3581 else if (k == M_PRINT)
3582 {
3583 /* Treat the non-standard case of PRINT namelist. */
3584 if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
3585 && gfc_match_name (name) == MATCH_YES)
3586 {
3587 gfc_find_symbol (name, NULL, 1, &sym);
3588 if (sym && sym->attr.flavor == FL_NAMELIST)
3589 {
3590 if (!gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
3591 "%C is an extension"))
3592 {
3593 m = MATCH_ERROR;
3594 goto cleanup;
3595 }
3596
3597 dt->io_unit = default_unit (k);
3598 dt->namelist = sym;
3599 goto get_io_list;
3600 }
3601 else
3602 gfc_current_locus = where;
3603 }
3604 }
3605
3606 if (gfc_current_form == FORM_FREE)
3607 {
3608 char c = gfc_peek_ascii_char ();
3609 if (c != ' ' && c != '*' && c != '\'' && c != '"')
3610 {
3611 m = MATCH_NO;
3612 goto cleanup;
3613 }
3614 }
3615
3616 m = match_dt_format (dt);
3617 if (m == MATCH_ERROR)
3618 goto cleanup;
3619 if (m == MATCH_NO)
3620 goto syntax;
3621
3622 comma_flag = 1;
3623 dt->io_unit = default_unit (k);
3624 goto get_io_list;
3625 }
3626 else
3627 {
3628 /* Before issuing an error for a malformed 'print (1,*)' type of
3629 error, check for a default-char-expr of the form ('(I0)'). */
3630 if (k == M_PRINT && m == MATCH_YES)
3631 {
3632 /* Reset current locus to get the initial '(' in an expression. */
3633 gfc_current_locus = where;
3634 dt->format_expr = NULL;
3635 m = match_dt_format (dt);
3636
3637 if (m == MATCH_ERROR)
3638 goto cleanup;
3639 if (m == MATCH_NO || dt->format_expr == NULL)
3640 goto syntax;
3641
3642 comma_flag = 1;
3643 dt->io_unit = default_unit (k);
3644 goto get_io_list;
3645 }
3646 }
3647
3648 /* Match a control list */
3649 if (match_dt_element (k, dt) == MATCH_YES)
3650 goto next;
3651 if (match_dt_unit (k, dt) != MATCH_YES)
3652 goto loop;
3653
3654 if (gfc_match_char (')') == MATCH_YES)
3655 goto get_io_list;
3656 if (gfc_match_char (',') != MATCH_YES)
3657 goto syntax;
3658
3659 m = match_dt_element (k, dt);
3660 if (m == MATCH_YES)
3661 goto next;
3662 if (m == MATCH_ERROR)
3663 goto cleanup;
3664
3665 m = match_dt_format (dt);
3666 if (m == MATCH_YES)
3667 goto next;
3668 if (m == MATCH_ERROR)
3669 goto cleanup;
3670
3671 where = gfc_current_locus;
3672
3673 m = gfc_match_name (name);
3674 if (m == MATCH_YES)
3675 {
3676 gfc_find_symbol (name, NULL, 1, &sym);
3677 if (sym && sym->attr.flavor == FL_NAMELIST)
3678 {
3679 dt->namelist = sym;
3680 if (k == M_READ && check_namelist (sym))
3681 {
3682 m = MATCH_ERROR;
3683 goto cleanup;
3684 }
3685 goto next;
3686 }
3687 }
3688
3689 gfc_current_locus = where;
3690
3691 goto loop; /* No matches, try regular elements */
3692
3693 next:
3694 if (gfc_match_char (')') == MATCH_YES)
3695 goto get_io_list;
3696 if (gfc_match_char (',') != MATCH_YES)
3697 goto syntax;
3698
3699 loop:
3700 for (;;)
3701 {
3702 m = match_dt_element (k, dt);
3703 if (m == MATCH_NO)
3704 goto syntax;
3705 if (m == MATCH_ERROR)
3706 goto cleanup;
3707
3708 if (gfc_match_char (')') == MATCH_YES)
3709 break;
3710 if (gfc_match_char (',') != MATCH_YES)
3711 goto syntax;
3712 }
3713
3714 get_io_list:
3715
3716 /* Used in check_io_constraints, where no locus is available. */
3717 spec_end = gfc_current_locus;
3718
3719 /* Save the IO kind for later use. */
3720 dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k);
3721
3722 /* Optional leading comma (non-standard). We use a gfc_expr structure here
3723 to save the locus. This is used later when resolving transfer statements
3724 that might have a format expression without unit number. */
3725 if (!comma_flag && gfc_match_char (',') == MATCH_YES)
3726 dt->extra_comma = dt->dt_io_kind;
3727
3728 io_code = NULL;
3729 if (gfc_match_eos () != MATCH_YES)
3730 {
3731 if (comma_flag && gfc_match_char (',') != MATCH_YES)
3732 {
3733 gfc_error ("Expected comma in I/O list at %C");
3734 m = MATCH_ERROR;
3735 goto cleanup;
3736 }
3737
3738 m = match_io_list (k, &io_code);
3739 if (m == MATCH_ERROR)
3740 goto cleanup;
3741 if (m == MATCH_NO)
3742 goto syntax;
3743 }
3744
3745 /* A full IO statement has been matched. Check the constraints. spec_end is
3746 supplied for cases where no locus is supplied. */
3747 m = check_io_constraints (k, dt, io_code, &spec_end);
3748
3749 if (m == MATCH_ERROR)
3750 goto cleanup;
3751
3752 new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
3753 new_st.ext.dt = dt;
3754 new_st.block = gfc_get_code ();
3755 new_st.block->op = new_st.op;
3756 new_st.block->next = io_code;
3757
3758 terminate_io (io_code);
3759
3760 return MATCH_YES;
3761
3762 syntax:
3763 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3764 m = MATCH_ERROR;
3765
3766 cleanup:
3767 gfc_free_dt (dt);
3768 return m;
3769 }
3770
3771
3772 match
3773 gfc_match_read (void)
3774 {
3775 return match_io (M_READ);
3776 }
3777
3778
3779 match
3780 gfc_match_write (void)
3781 {
3782 return match_io (M_WRITE);
3783 }
3784
3785
3786 match
3787 gfc_match_print (void)
3788 {
3789 match m;
3790
3791 m = match_io (M_PRINT);
3792 if (m != MATCH_YES)
3793 return m;
3794
3795 if (gfc_pure (NULL))
3796 {
3797 gfc_error ("PRINT statement at %C not allowed within PURE procedure");
3798 return MATCH_ERROR;
3799 }
3800
3801 if (gfc_implicit_pure (NULL))
3802 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3803
3804 return MATCH_YES;
3805 }
3806
3807
3808 /* Free a gfc_inquire structure. */
3809
3810 void
3811 gfc_free_inquire (gfc_inquire *inquire)
3812 {
3813
3814 if (inquire == NULL)
3815 return;
3816
3817 gfc_free_expr (inquire->unit);
3818 gfc_free_expr (inquire->file);
3819 gfc_free_expr (inquire->iomsg);
3820 gfc_free_expr (inquire->iostat);
3821 gfc_free_expr (inquire->exist);
3822 gfc_free_expr (inquire->opened);
3823 gfc_free_expr (inquire->number);
3824 gfc_free_expr (inquire->named);
3825 gfc_free_expr (inquire->name);
3826 gfc_free_expr (inquire->access);
3827 gfc_free_expr (inquire->sequential);
3828 gfc_free_expr (inquire->direct);
3829 gfc_free_expr (inquire->form);
3830 gfc_free_expr (inquire->formatted);
3831 gfc_free_expr (inquire->unformatted);
3832 gfc_free_expr (inquire->recl);
3833 gfc_free_expr (inquire->nextrec);
3834 gfc_free_expr (inquire->blank);
3835 gfc_free_expr (inquire->position);
3836 gfc_free_expr (inquire->action);
3837 gfc_free_expr (inquire->read);
3838 gfc_free_expr (inquire->write);
3839 gfc_free_expr (inquire->readwrite);
3840 gfc_free_expr (inquire->delim);
3841 gfc_free_expr (inquire->encoding);
3842 gfc_free_expr (inquire->pad);
3843 gfc_free_expr (inquire->iolength);
3844 gfc_free_expr (inquire->convert);
3845 gfc_free_expr (inquire->strm_pos);
3846 gfc_free_expr (inquire->asynchronous);
3847 gfc_free_expr (inquire->decimal);
3848 gfc_free_expr (inquire->pending);
3849 gfc_free_expr (inquire->id);
3850 gfc_free_expr (inquire->sign);
3851 gfc_free_expr (inquire->size);
3852 gfc_free_expr (inquire->round);
3853 free (inquire);
3854 }
3855
3856
3857 /* Match an element of an INQUIRE statement. */
3858
3859 #define RETM if (m != MATCH_NO) return m;
3860
3861 static match
3862 match_inquire_element (gfc_inquire *inquire)
3863 {
3864 match m;
3865
3866 m = match_etag (&tag_unit, &inquire->unit);
3867 RETM m = match_etag (&tag_file, &inquire->file);
3868 RETM m = match_ltag (&tag_err, &inquire->err);
3869 RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg);
3870 RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
3871 RETM m = match_vtag (&tag_exist, &inquire->exist);
3872 RETM m = match_vtag (&tag_opened, &inquire->opened);
3873 RETM m = match_vtag (&tag_named, &inquire->named);
3874 RETM m = match_vtag (&tag_name, &inquire->name);
3875 RETM m = match_out_tag (&tag_number, &inquire->number);
3876 RETM m = match_vtag (&tag_s_access, &inquire->access);
3877 RETM m = match_vtag (&tag_sequential, &inquire->sequential);
3878 RETM m = match_vtag (&tag_direct, &inquire->direct);
3879 RETM m = match_vtag (&tag_s_form, &inquire->form);
3880 RETM m = match_vtag (&tag_formatted, &inquire->formatted);
3881 RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
3882 RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
3883 RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
3884 RETM m = match_vtag (&tag_s_blank, &inquire->blank);
3885 RETM m = match_vtag (&tag_s_position, &inquire->position);
3886 RETM m = match_vtag (&tag_s_action, &inquire->action);
3887 RETM m = match_vtag (&tag_read, &inquire->read);
3888 RETM m = match_vtag (&tag_write, &inquire->write);
3889 RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
3890 RETM m = match_vtag (&tag_s_async, &inquire->asynchronous);
3891 RETM m = match_vtag (&tag_s_delim, &inquire->delim);
3892 RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
3893 RETM m = match_vtag (&tag_size, &inquire->size);
3894 RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
3895 RETM m = match_vtag (&tag_s_round, &inquire->round);
3896 RETM m = match_vtag (&tag_s_sign, &inquire->sign);
3897 RETM m = match_vtag (&tag_s_pad, &inquire->pad);
3898 RETM m = match_vtag (&tag_iolength, &inquire->iolength);
3899 RETM m = match_vtag (&tag_convert, &inquire->convert);
3900 RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
3901 RETM m = match_vtag (&tag_pending, &inquire->pending);
3902 RETM m = match_vtag (&tag_id, &inquire->id);
3903 RETM m = match_vtag (&tag_s_iqstream, &inquire->iqstream);
3904 RETM return MATCH_NO;
3905 }
3906
3907 #undef RETM
3908
3909
3910 match
3911 gfc_match_inquire (void)
3912 {
3913 gfc_inquire *inquire;
3914 gfc_code *code;
3915 match m;
3916 locus loc;
3917
3918 m = gfc_match_char ('(');
3919 if (m == MATCH_NO)
3920 return m;
3921
3922 inquire = XCNEW (gfc_inquire);
3923
3924 loc = gfc_current_locus;
3925
3926 m = match_inquire_element (inquire);
3927 if (m == MATCH_ERROR)
3928 goto cleanup;
3929 if (m == MATCH_NO)
3930 {
3931 m = gfc_match_expr (&inquire->unit);
3932 if (m == MATCH_ERROR)
3933 goto cleanup;
3934 if (m == MATCH_NO)
3935 goto syntax;
3936 }
3937
3938 /* See if we have the IOLENGTH form of the inquire statement. */
3939 if (inquire->iolength != NULL)
3940 {
3941 if (gfc_match_char (')') != MATCH_YES)
3942 goto syntax;
3943
3944 m = match_io_list (M_INQUIRE, &code);
3945 if (m == MATCH_ERROR)
3946 goto cleanup;
3947 if (m == MATCH_NO)
3948 goto syntax;
3949
3950 new_st.op = EXEC_IOLENGTH;
3951 new_st.expr1 = inquire->iolength;
3952 new_st.ext.inquire = inquire;
3953
3954 if (gfc_pure (NULL))
3955 {
3956 gfc_free_statements (code);
3957 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3958 return MATCH_ERROR;
3959 }
3960
3961 if (gfc_implicit_pure (NULL))
3962 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3963
3964 new_st.block = gfc_get_code ();
3965 new_st.block->op = EXEC_IOLENGTH;
3966 terminate_io (code);
3967 new_st.block->next = code;
3968 return MATCH_YES;
3969 }
3970
3971 /* At this point, we have the non-IOLENGTH inquire statement. */
3972 for (;;)
3973 {
3974 if (gfc_match_char (')') == MATCH_YES)
3975 break;
3976 if (gfc_match_char (',') != MATCH_YES)
3977 goto syntax;
3978
3979 m = match_inquire_element (inquire);
3980 if (m == MATCH_ERROR)
3981 goto cleanup;
3982 if (m == MATCH_NO)
3983 goto syntax;
3984
3985 if (inquire->iolength != NULL)
3986 {
3987 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
3988 goto cleanup;
3989 }
3990 }
3991
3992 if (gfc_match_eos () != MATCH_YES)
3993 goto syntax;
3994
3995 if (inquire->unit != NULL && inquire->file != NULL)
3996 {
3997 gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
3998 "UNIT specifiers", &loc);
3999 goto cleanup;
4000 }
4001
4002 if (inquire->unit == NULL && inquire->file == NULL)
4003 {
4004 gfc_error ("INQUIRE statement at %L requires either FILE or "
4005 "UNIT specifier", &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 if (gfc_implicit_pure (NULL))
4016 gfc_current_ns->proc_name->attr.implicit_pure = 0;
4017
4018 if (inquire->id != NULL && inquire->pending == NULL)
4019 {
4020 gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
4021 "the ID= specifier", &loc);
4022 goto cleanup;
4023 }
4024
4025 new_st.op = EXEC_INQUIRE;
4026 new_st.ext.inquire = inquire;
4027 return MATCH_YES;
4028
4029 syntax:
4030 gfc_syntax_error (ST_INQUIRE);
4031
4032 cleanup:
4033 gfc_free_inquire (inquire);
4034 return MATCH_ERROR;
4035 }
4036
4037
4038 /* Resolve everything in a gfc_inquire structure. */
4039
4040 bool
4041 gfc_resolve_inquire (gfc_inquire *inquire)
4042 {
4043 RESOLVE_TAG (&tag_unit, inquire->unit);
4044 RESOLVE_TAG (&tag_file, inquire->file);
4045 RESOLVE_TAG (&tag_id, inquire->id);
4046
4047 /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4048 contexts. Thus, use an extended RESOLVE_TAG macro for that. */
4049 #define INQUIRE_RESOLVE_TAG(tag, expr) \
4050 RESOLVE_TAG (tag, expr); \
4051 if (expr) \
4052 { \
4053 char context[64]; \
4054 sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
4055 if (gfc_check_vardef_context ((expr), false, false, false, \
4056 context) == false) \
4057 return false; \
4058 }
4059 INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
4060 INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat);
4061 INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist);
4062 INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened);
4063 INQUIRE_RESOLVE_TAG (&tag_number, inquire->number);
4064 INQUIRE_RESOLVE_TAG (&tag_named, inquire->named);
4065 INQUIRE_RESOLVE_TAG (&tag_name, inquire->name);
4066 INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access);
4067 INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential);
4068 INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct);
4069 INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form);
4070 INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted);
4071 INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
4072 INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl);
4073 INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
4074 INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank);
4075 INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position);
4076 INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action);
4077 INQUIRE_RESOLVE_TAG (&tag_read, inquire->read);
4078 INQUIRE_RESOLVE_TAG (&tag_write, inquire->write);
4079 INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
4080 INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim);
4081 INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad);
4082 INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
4083 INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4084 INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength);
4085 INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert);
4086 INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
4087 INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
4088 INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign);
4089 INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4090 INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending);
4091 INQUIRE_RESOLVE_TAG (&tag_size, inquire->size);
4092 INQUIRE_RESOLVE_TAG (&tag_s_decimal, inquire->decimal);
4093 INQUIRE_RESOLVE_TAG (&tag_s_iqstream, inquire->iqstream);
4094 #undef INQUIRE_RESOLVE_TAG
4095
4096 if (!gfc_reference_st_label (inquire->err, ST_LABEL_TARGET))
4097 return false;
4098
4099 return true;
4100 }
4101
4102
4103 void
4104 gfc_free_wait (gfc_wait *wait)
4105 {
4106 if (wait == NULL)
4107 return;
4108
4109 gfc_free_expr (wait->unit);
4110 gfc_free_expr (wait->iostat);
4111 gfc_free_expr (wait->iomsg);
4112 gfc_free_expr (wait->id);
4113 free (wait);
4114 }
4115
4116
4117 bool
4118 gfc_resolve_wait (gfc_wait *wait)
4119 {
4120 RESOLVE_TAG (&tag_unit, wait->unit);
4121 RESOLVE_TAG (&tag_iomsg, wait->iomsg);
4122 RESOLVE_TAG (&tag_iostat, wait->iostat);
4123 RESOLVE_TAG (&tag_id, wait->id);
4124
4125 if (!gfc_reference_st_label (wait->err, ST_LABEL_TARGET))
4126 return false;
4127
4128 if (!gfc_reference_st_label (wait->end, ST_LABEL_TARGET))
4129 return false;
4130
4131 return true;
4132 }
4133
4134 /* Match an element of a WAIT statement. */
4135
4136 #define RETM if (m != MATCH_NO) return m;
4137
4138 static match
4139 match_wait_element (gfc_wait *wait)
4140 {
4141 match m;
4142
4143 m = match_etag (&tag_unit, &wait->unit);
4144 RETM m = match_ltag (&tag_err, &wait->err);
4145 RETM m = match_ltag (&tag_end, &wait->eor);
4146 RETM m = match_ltag (&tag_eor, &wait->end);
4147 RETM m = match_out_tag (&tag_iomsg, &wait->iomsg);
4148 RETM m = match_out_tag (&tag_iostat, &wait->iostat);
4149 RETM m = match_etag (&tag_id, &wait->id);
4150 RETM return MATCH_NO;
4151 }
4152
4153 #undef RETM
4154
4155
4156 match
4157 gfc_match_wait (void)
4158 {
4159 gfc_wait *wait;
4160 match m;
4161
4162 m = gfc_match_char ('(');
4163 if (m == MATCH_NO)
4164 return m;
4165
4166 wait = XCNEW (gfc_wait);
4167
4168 m = match_wait_element (wait);
4169 if (m == MATCH_ERROR)
4170 goto cleanup;
4171 if (m == MATCH_NO)
4172 {
4173 m = gfc_match_expr (&wait->unit);
4174 if (m == MATCH_ERROR)
4175 goto cleanup;
4176 if (m == MATCH_NO)
4177 goto syntax;
4178 }
4179
4180 for (;;)
4181 {
4182 if (gfc_match_char (')') == MATCH_YES)
4183 break;
4184 if (gfc_match_char (',') != MATCH_YES)
4185 goto syntax;
4186
4187 m = match_wait_element (wait);
4188 if (m == MATCH_ERROR)
4189 goto cleanup;
4190 if (m == MATCH_NO)
4191 goto syntax;
4192 }
4193
4194 if (!gfc_notify_std (GFC_STD_F2003, "WAIT at %C "
4195 "not allowed in Fortran 95"))
4196 goto cleanup;
4197
4198 if (gfc_pure (NULL))
4199 {
4200 gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4201 goto cleanup;
4202 }
4203
4204 if (gfc_implicit_pure (NULL))
4205 gfc_current_ns->proc_name->attr.implicit_pure = 0;
4206
4207 new_st.op = EXEC_WAIT;
4208 new_st.ext.wait = wait;
4209
4210 return MATCH_YES;
4211
4212 syntax:
4213 gfc_syntax_error (ST_WAIT);
4214
4215 cleanup:
4216 gfc_free_wait (wait);
4217 return MATCH_ERROR;
4218 }
Mirror of https://gcc.gnu.org/git/gcc.git