?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2013-12-29 Janus Weil <janus@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / io.c
blobcc5ce12781ea79a79b331575bd114110a72b8efa
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 (EXEC_DO);
3059 new_code->ext.iterator = iter;
3060
3061 new_code->block = gfc_get_code (EXEC_DO);
3062 new_code->block->next = head;
3063
3064 *result = new_code;
3065 return MATCH_YES;
3066
3067 syntax:
3068 gfc_error ("Syntax error in I/O iterator at %C");
3069 m = MATCH_ERROR;
3070
3071 cleanup:
3072 gfc_free_iterator (iter, 1);
3073 gfc_free_statements (head);
3074 gfc_current_locus = old_loc;
3075 return m;
3076 }
3077
3078
3079 /* Match a single element of an IO list, which is either a single
3080 expression or an IO Iterator. */
3081
3082 static match
3083 match_io_element (io_kind k, gfc_code **cpp)
3084 {
3085 gfc_expr *expr;
3086 gfc_code *cp;
3087 match m;
3088
3089 expr = NULL;
3090
3091 m = match_io_iterator (k, cpp);
3092 if (m == MATCH_YES)
3093 return MATCH_YES;
3094
3095 if (k == M_READ)
3096 {
3097 m = gfc_match_variable (&expr, 0);
3098 if (m == MATCH_NO)
3099 gfc_error ("Expected variable in READ statement at %C");
3100 }
3101 else
3102 {
3103 m = gfc_match_expr (&expr);
3104 if (m == MATCH_NO)
3105 gfc_error ("Expected expression in %s statement at %C",
3106 io_kind_name (k));
3107 }
3108
3109 if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree))
3110 m = MATCH_ERROR;
3111
3112 if (m != MATCH_YES)
3113 {
3114 gfc_free_expr (expr);
3115 return MATCH_ERROR;
3116 }
3117
3118 cp = gfc_get_code (EXEC_TRANSFER);
3119 cp->expr1 = expr;
3120 if (k != M_INQUIRE)
3121 cp->ext.dt = current_dt;
3122
3123 *cpp = cp;
3124 return MATCH_YES;
3125 }
3126
3127
3128 /* Match an I/O list, building gfc_code structures as we go. */
3129
3130 static match
3131 match_io_list (io_kind k, gfc_code **head_p)
3132 {
3133 gfc_code *head, *tail, *new_code;
3134 match m;
3135
3136 *head_p = head = tail = NULL;
3137 if (gfc_match_eos () == MATCH_YES)
3138 return MATCH_YES;
3139
3140 for (;;)
3141 {
3142 m = match_io_element (k, &new_code);
3143 if (m == MATCH_ERROR)
3144 goto cleanup;
3145 if (m == MATCH_NO)
3146 goto syntax;
3147
3148 tail = gfc_append_code (tail, new_code);
3149 if (head == NULL)
3150 head = new_code;
3151
3152 if (gfc_match_eos () == MATCH_YES)
3153 break;
3154 if (gfc_match_char (',') != MATCH_YES)
3155 goto syntax;
3156 }
3157
3158 *head_p = head;
3159 return MATCH_YES;
3160
3161 syntax:
3162 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3163
3164 cleanup:
3165 gfc_free_statements (head);
3166 return MATCH_ERROR;
3167 }
3168
3169
3170 /* Attach the data transfer end node. */
3171
3172 static void
3173 terminate_io (gfc_code *io_code)
3174 {
3175 gfc_code *c;
3176
3177 if (io_code == NULL)
3178 io_code = new_st.block;
3179
3180 c = gfc_get_code (EXEC_DT_END);
3181
3182 /* Point to structure that is already there */
3183 c->ext.dt = new_st.ext.dt;
3184 gfc_append_code (io_code, c);
3185 }
3186
3187
3188 /* Check the constraints for a data transfer statement. The majority of the
3189 constraints appearing in 9.4 of the standard appear here. Some are handled
3190 in resolve_tag and others in gfc_resolve_dt. */
3191
3192 static match
3193 check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
3194 locus *spec_end)
3195 {
3196 #define io_constraint(condition,msg,arg)\
3197 if (condition) \
3198 {\
3199 gfc_error(msg,arg);\
3200 m = MATCH_ERROR;\
3201 }
3202
3203 match m;
3204 gfc_expr *expr;
3205 gfc_symbol *sym = NULL;
3206 bool warn, unformatted;
3207
3208 warn = (dt->err || dt->iostat) ? true : false;
3209 unformatted = dt->format_expr == NULL && dt->format_label == NULL
3210 && dt->namelist == NULL;
3211
3212 m = MATCH_YES;
3213
3214 expr = dt->io_unit;
3215 if (expr && expr->expr_type == EXPR_VARIABLE
3216 && expr->ts.type == BT_CHARACTER)
3217 {
3218 sym = expr->symtree->n.sym;
3219
3220 io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
3221 "Internal file at %L must not be INTENT(IN)",
3222 &expr->where);
3223
3224 io_constraint (gfc_has_vector_index (dt->io_unit),
3225 "Internal file incompatible with vector subscript at %L",
3226 &expr->where);
3227
3228 io_constraint (dt->rec != NULL,
3229 "REC tag at %L is incompatible with internal file",
3230 &dt->rec->where);
3231
3232 io_constraint (dt->pos != NULL,
3233 "POS tag at %L is incompatible with internal file",
3234 &dt->pos->where);
3235
3236 io_constraint (unformatted,
3237 "Unformatted I/O not allowed with internal unit at %L",
3238 &dt->io_unit->where);
3239
3240 io_constraint (dt->asynchronous != NULL,
3241 "ASYNCHRONOUS tag at %L not allowed with internal file",
3242 &dt->asynchronous->where);
3243
3244 if (dt->namelist != NULL)
3245 {
3246 if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with "
3247 "namelist", &expr->where))
3248 m = MATCH_ERROR;
3249 }
3250
3251 io_constraint (dt->advance != NULL,
3252 "ADVANCE tag at %L is incompatible with internal file",
3253 &dt->advance->where);
3254 }
3255
3256 if (expr && expr->ts.type != BT_CHARACTER)
3257 {
3258
3259 io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE),
3260 "IO UNIT in %s statement at %C must be "
3261 "an internal file in a PURE procedure",
3262 io_kind_name (k));
3263
3264 if (gfc_implicit_pure (NULL) && (k == M_READ || k == M_WRITE))
3265 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3266
3267 }
3268
3269 if (k != M_READ)
3270 {
3271 io_constraint (dt->end, "END tag not allowed with output at %L",
3272 &dt->end_where);
3273
3274 io_constraint (dt->eor, "EOR tag not allowed with output at %L",
3275 &dt->eor_where);
3276
3277 io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L",
3278 &dt->blank->where);
3279
3280 io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
3281 &dt->pad->where);
3282
3283 io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
3284 &dt->size->where);
3285 }
3286 else
3287 {
3288 io_constraint (dt->size && dt->advance == NULL,
3289 "SIZE tag at %L requires an ADVANCE tag",
3290 &dt->size->where);
3291
3292 io_constraint (dt->eor && dt->advance == NULL,
3293 "EOR tag at %L requires an ADVANCE tag",
3294 &dt->eor_where);
3295 }
3296
3297 if (dt->asynchronous)
3298 {
3299 static const char * asynchronous[] = { "YES", "NO", NULL };
3300
3301 if (!gfc_reduce_init_expr (dt->asynchronous))
3302 {
3303 gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3304 "expression", &dt->asynchronous->where);
3305 return MATCH_ERROR;
3306 }
3307
3308 if (!compare_to_allowed_values
3309 ("ASYNCHRONOUS", asynchronous, NULL, NULL,
3310 dt->asynchronous->value.character.string,
3311 io_kind_name (k), warn))
3312 return MATCH_ERROR;
3313 }
3314
3315 if (dt->id)
3316 {
3317 bool not_yes
3318 = !dt->asynchronous
3319 || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
3320 || gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
3321 "yes", 3) != 0;
3322 io_constraint (not_yes,
3323 "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3324 "specifier", &dt->id->where);
3325 }
3326
3327 if (dt->decimal)
3328 {
3329 if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C "
3330 "not allowed in Fortran 95"))
3331 return MATCH_ERROR;
3332
3333 if (dt->decimal->expr_type == EXPR_CONSTANT)
3334 {
3335 static const char * decimal[] = { "COMMA", "POINT", NULL };
3336
3337 if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
3338 dt->decimal->value.character.string,
3339 io_kind_name (k), warn))
3340 return MATCH_ERROR;
3341
3342 io_constraint (unformatted,
3343 "the DECIMAL= specifier at %L must be with an "
3344 "explicit format expression", &dt->decimal->where);
3345 }
3346 }
3347
3348 if (dt->blank)
3349 {
3350 if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C "
3351 "not allowed in Fortran 95"))
3352 return MATCH_ERROR;
3353
3354 if (dt->blank->expr_type == EXPR_CONSTANT)
3355 {
3356 static const char * blank[] = { "NULL", "ZERO", NULL };
3357
3358 if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
3359 dt->blank->value.character.string,
3360 io_kind_name (k), warn))
3361 return MATCH_ERROR;
3362
3363 io_constraint (unformatted,
3364 "the BLANK= specifier at %L must be with an "
3365 "explicit format expression", &dt->blank->where);
3366 }
3367 }
3368
3369 if (dt->pad)
3370 {
3371 if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %C "
3372 "not allowed in Fortran 95"))
3373 return MATCH_ERROR;
3374
3375 if (dt->pad->expr_type == EXPR_CONSTANT)
3376 {
3377 static const char * pad[] = { "YES", "NO", NULL };
3378
3379 if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
3380 dt->pad->value.character.string,
3381 io_kind_name (k), warn))
3382 return MATCH_ERROR;
3383
3384 io_constraint (unformatted,
3385 "the PAD= specifier at %L must be with an "
3386 "explicit format expression", &dt->pad->where);
3387 }
3388 }
3389
3390 if (dt->round)
3391 {
3392 if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C "
3393 "not allowed in Fortran 95"))
3394 return MATCH_ERROR;
3395
3396 if (dt->round->expr_type == EXPR_CONSTANT)
3397 {
3398 static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
3399 "COMPATIBLE", "PROCESSOR_DEFINED",
3400 NULL };
3401
3402 if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
3403 dt->round->value.character.string,
3404 io_kind_name (k), warn))
3405 return MATCH_ERROR;
3406 }
3407 }
3408
3409 if (dt->sign)
3410 {
3411 /* When implemented, change the following to use gfc_notify_std F2003.
3412 if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C "
3413 "not allowed in Fortran 95") == false)
3414 return MATCH_ERROR; */
3415 if (dt->sign->expr_type == EXPR_CONSTANT)
3416 {
3417 static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3418 NULL };
3419
3420 if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
3421 dt->sign->value.character.string,
3422 io_kind_name (k), warn))
3423 return MATCH_ERROR;
3424
3425 io_constraint (unformatted,
3426 "SIGN= specifier at %L must be with an "
3427 "explicit format expression", &dt->sign->where);
3428
3429 io_constraint (k == M_READ,
3430 "SIGN= specifier at %L not allowed in a "
3431 "READ statement", &dt->sign->where);
3432 }
3433 }
3434
3435 if (dt->delim)
3436 {
3437 if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %C "
3438 "not allowed in Fortran 95"))
3439 return MATCH_ERROR;
3440
3441 if (dt->delim->expr_type == EXPR_CONSTANT)
3442 {
3443 static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
3444
3445 if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
3446 dt->delim->value.character.string,
3447 io_kind_name (k), warn))
3448 return MATCH_ERROR;
3449
3450 io_constraint (k == M_READ,
3451 "DELIM= specifier at %L not allowed in a "
3452 "READ statement", &dt->delim->where);
3453
3454 io_constraint (dt->format_label != &format_asterisk
3455 && dt->namelist == NULL,
3456 "DELIM= specifier at %L must have FMT=*",
3457 &dt->delim->where);
3458
3459 io_constraint (unformatted && dt->namelist == NULL,
3460 "DELIM= specifier at %L must be with FMT=* or "
3461 "NML= specifier ", &dt->delim->where);
3462 }
3463 }
3464
3465 if (dt->namelist)
3466 {
3467 io_constraint (io_code && dt->namelist,
3468 "NAMELIST cannot be followed by IO-list at %L",
3469 &io_code->loc);
3470
3471 io_constraint (dt->format_expr,
3472 "IO spec-list cannot contain both NAMELIST group name "
3473 "and format specification at %L",
3474 &dt->format_expr->where);
3475
3476 io_constraint (dt->format_label,
3477 "IO spec-list cannot contain both NAMELIST group name "
3478 "and format label at %L", spec_end);
3479
3480 io_constraint (dt->rec,
3481 "NAMELIST IO is not allowed with a REC= specifier "
3482 "at %L", &dt->rec->where);
3483
3484 io_constraint (dt->advance,
3485 "NAMELIST IO is not allowed with a ADVANCE= specifier "
3486 "at %L", &dt->advance->where);
3487 }
3488
3489 if (dt->rec)
3490 {
3491 io_constraint (dt->end,
3492 "An END tag is not allowed with a "
3493 "REC= specifier at %L", &dt->end_where);
3494
3495 io_constraint (dt->format_label == &format_asterisk,
3496 "FMT=* is not allowed with a REC= specifier "
3497 "at %L", spec_end);
3498
3499 io_constraint (dt->pos,
3500 "POS= is not allowed with REC= specifier "
3501 "at %L", &dt->pos->where);
3502 }
3503
3504 if (dt->advance)
3505 {
3506 int not_yes, not_no;
3507 expr = dt->advance;
3508
3509 io_constraint (dt->format_label == &format_asterisk,
3510 "List directed format(*) is not allowed with a "
3511 "ADVANCE= specifier at %L.", &expr->where);
3512
3513 io_constraint (unformatted,
3514 "the ADVANCE= specifier at %L must appear with an "
3515 "explicit format expression", &expr->where);
3516
3517 if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
3518 {
3519 const gfc_char_t *advance = expr->value.character.string;
3520 not_no = gfc_wide_strlen (advance) != 2
3521 || gfc_wide_strncasecmp (advance, "no", 2) != 0;
3522 not_yes = gfc_wide_strlen (advance) != 3
3523 || gfc_wide_strncasecmp (advance, "yes", 3) != 0;
3524 }
3525 else
3526 {
3527 not_no = 0;
3528 not_yes = 0;
3529 }
3530
3531 io_constraint (not_no && not_yes,
3532 "ADVANCE= specifier at %L must have value = "
3533 "YES or NO.", &expr->where);
3534
3535 io_constraint (dt->size && not_no && k == M_READ,
3536 "SIZE tag at %L requires an ADVANCE = 'NO'",
3537 &dt->size->where);
3538
3539 io_constraint (dt->eor && not_no && k == M_READ,
3540 "EOR tag at %L requires an ADVANCE = 'NO'",
3541 &dt->eor_where);
3542 }
3543
3544 expr = dt->format_expr;
3545 if (!gfc_simplify_expr (expr, 0)
3546 || !check_format_string (expr, k == M_READ))
3547 return MATCH_ERROR;
3548
3549 return m;
3550 }
3551 #undef io_constraint
3552
3553
3554 /* Match a READ, WRITE or PRINT statement. */
3555
3556 static match
3557 match_io (io_kind k)
3558 {
3559 char name[GFC_MAX_SYMBOL_LEN + 1];
3560 gfc_code *io_code;
3561 gfc_symbol *sym;
3562 int comma_flag;
3563 locus where;
3564 locus spec_end;
3565 gfc_dt *dt;
3566 match m;
3567
3568 where = gfc_current_locus;
3569 comma_flag = 0;
3570 current_dt = dt = XCNEW (gfc_dt);
3571 m = gfc_match_char ('(');
3572 if (m == MATCH_NO)
3573 {
3574 where = gfc_current_locus;
3575 if (k == M_WRITE)
3576 goto syntax;
3577 else if (k == M_PRINT)
3578 {
3579 /* Treat the non-standard case of PRINT namelist. */
3580 if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
3581 && gfc_match_name (name) == MATCH_YES)
3582 {
3583 gfc_find_symbol (name, NULL, 1, &sym);
3584 if (sym && sym->attr.flavor == FL_NAMELIST)
3585 {
3586 if (!gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
3587 "%C is an extension"))
3588 {
3589 m = MATCH_ERROR;
3590 goto cleanup;
3591 }
3592
3593 dt->io_unit = default_unit (k);
3594 dt->namelist = sym;
3595 goto get_io_list;
3596 }
3597 else
3598 gfc_current_locus = where;
3599 }
3600 }
3601
3602 if (gfc_current_form == FORM_FREE)
3603 {
3604 char c = gfc_peek_ascii_char ();
3605 if (c != ' ' && c != '*' && c != '\'' && c != '"')
3606 {
3607 m = MATCH_NO;
3608 goto cleanup;
3609 }
3610 }
3611
3612 m = match_dt_format (dt);
3613 if (m == MATCH_ERROR)
3614 goto cleanup;
3615 if (m == MATCH_NO)
3616 goto syntax;
3617
3618 comma_flag = 1;
3619 dt->io_unit = default_unit (k);
3620 goto get_io_list;
3621 }
3622 else
3623 {
3624 /* Before issuing an error for a malformed 'print (1,*)' type of
3625 error, check for a default-char-expr of the form ('(I0)'). */
3626 if (k == M_PRINT && m == MATCH_YES)
3627 {
3628 /* Reset current locus to get the initial '(' in an expression. */
3629 gfc_current_locus = where;
3630 dt->format_expr = NULL;
3631 m = match_dt_format (dt);
3632
3633 if (m == MATCH_ERROR)
3634 goto cleanup;
3635 if (m == MATCH_NO || dt->format_expr == NULL)
3636 goto syntax;
3637
3638 comma_flag = 1;
3639 dt->io_unit = default_unit (k);
3640 goto get_io_list;
3641 }
3642 }
3643
3644 /* Match a control list */
3645 if (match_dt_element (k, dt) == MATCH_YES)
3646 goto next;
3647 if (match_dt_unit (k, dt) != MATCH_YES)
3648 goto loop;
3649
3650 if (gfc_match_char (')') == MATCH_YES)
3651 goto get_io_list;
3652 if (gfc_match_char (',') != MATCH_YES)
3653 goto syntax;
3654
3655 m = match_dt_element (k, dt);
3656 if (m == MATCH_YES)
3657 goto next;
3658 if (m == MATCH_ERROR)
3659 goto cleanup;
3660
3661 m = match_dt_format (dt);
3662 if (m == MATCH_YES)
3663 goto next;
3664 if (m == MATCH_ERROR)
3665 goto cleanup;
3666
3667 where = gfc_current_locus;
3668
3669 m = gfc_match_name (name);
3670 if (m == MATCH_YES)
3671 {
3672 gfc_find_symbol (name, NULL, 1, &sym);
3673 if (sym && sym->attr.flavor == FL_NAMELIST)
3674 {
3675 dt->namelist = sym;
3676 if (k == M_READ && check_namelist (sym))
3677 {
3678 m = MATCH_ERROR;
3679 goto cleanup;
3680 }
3681 goto next;
3682 }
3683 }
3684
3685 gfc_current_locus = where;
3686
3687 goto loop; /* No matches, try regular elements */
3688
3689 next:
3690 if (gfc_match_char (')') == MATCH_YES)
3691 goto get_io_list;
3692 if (gfc_match_char (',') != MATCH_YES)
3693 goto syntax;
3694
3695 loop:
3696 for (;;)
3697 {
3698 m = match_dt_element (k, dt);
3699 if (m == MATCH_NO)
3700 goto syntax;
3701 if (m == MATCH_ERROR)
3702 goto cleanup;
3703
3704 if (gfc_match_char (')') == MATCH_YES)
3705 break;
3706 if (gfc_match_char (',') != MATCH_YES)
3707 goto syntax;
3708 }
3709
3710 get_io_list:
3711
3712 /* Used in check_io_constraints, where no locus is available. */
3713 spec_end = gfc_current_locus;
3714
3715 /* Save the IO kind for later use. */
3716 dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k);
3717
3718 /* Optional leading comma (non-standard). We use a gfc_expr structure here
3719 to save the locus. This is used later when resolving transfer statements
3720 that might have a format expression without unit number. */
3721 if (!comma_flag && gfc_match_char (',') == MATCH_YES)
3722 dt->extra_comma = dt->dt_io_kind;
3723
3724 io_code = NULL;
3725 if (gfc_match_eos () != MATCH_YES)
3726 {
3727 if (comma_flag && gfc_match_char (',') != MATCH_YES)
3728 {
3729 gfc_error ("Expected comma in I/O list at %C");
3730 m = MATCH_ERROR;
3731 goto cleanup;
3732 }
3733
3734 m = match_io_list (k, &io_code);
3735 if (m == MATCH_ERROR)
3736 goto cleanup;
3737 if (m == MATCH_NO)
3738 goto syntax;
3739 }
3740
3741 /* A full IO statement has been matched. Check the constraints. spec_end is
3742 supplied for cases where no locus is supplied. */
3743 m = check_io_constraints (k, dt, io_code, &spec_end);
3744
3745 if (m == MATCH_ERROR)
3746 goto cleanup;
3747
3748 new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
3749 new_st.ext.dt = dt;
3750 new_st.block = gfc_get_code (new_st.op);
3751 new_st.block->next = io_code;
3752
3753 terminate_io (io_code);
3754
3755 return MATCH_YES;
3756
3757 syntax:
3758 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3759 m = MATCH_ERROR;
3760
3761 cleanup:
3762 gfc_free_dt (dt);
3763 return m;
3764 }
3765
3766
3767 match
3768 gfc_match_read (void)
3769 {
3770 return match_io (M_READ);
3771 }
3772
3773
3774 match
3775 gfc_match_write (void)
3776 {
3777 return match_io (M_WRITE);
3778 }
3779
3780
3781 match
3782 gfc_match_print (void)
3783 {
3784 match m;
3785
3786 m = match_io (M_PRINT);
3787 if (m != MATCH_YES)
3788 return m;
3789
3790 if (gfc_pure (NULL))
3791 {
3792 gfc_error ("PRINT statement at %C not allowed within PURE procedure");
3793 return MATCH_ERROR;
3794 }
3795
3796 if (gfc_implicit_pure (NULL))
3797 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3798
3799 return MATCH_YES;
3800 }
3801
3802
3803 /* Free a gfc_inquire structure. */
3804
3805 void
3806 gfc_free_inquire (gfc_inquire *inquire)
3807 {
3808
3809 if (inquire == NULL)
3810 return;
3811
3812 gfc_free_expr (inquire->unit);
3813 gfc_free_expr (inquire->file);
3814 gfc_free_expr (inquire->iomsg);
3815 gfc_free_expr (inquire->iostat);
3816 gfc_free_expr (inquire->exist);
3817 gfc_free_expr (inquire->opened);
3818 gfc_free_expr (inquire->number);
3819 gfc_free_expr (inquire->named);
3820 gfc_free_expr (inquire->name);
3821 gfc_free_expr (inquire->access);
3822 gfc_free_expr (inquire->sequential);
3823 gfc_free_expr (inquire->direct);
3824 gfc_free_expr (inquire->form);
3825 gfc_free_expr (inquire->formatted);
3826 gfc_free_expr (inquire->unformatted);
3827 gfc_free_expr (inquire->recl);
3828 gfc_free_expr (inquire->nextrec);
3829 gfc_free_expr (inquire->blank);
3830 gfc_free_expr (inquire->position);
3831 gfc_free_expr (inquire->action);
3832 gfc_free_expr (inquire->read);
3833 gfc_free_expr (inquire->write);
3834 gfc_free_expr (inquire->readwrite);
3835 gfc_free_expr (inquire->delim);
3836 gfc_free_expr (inquire->encoding);
3837 gfc_free_expr (inquire->pad);
3838 gfc_free_expr (inquire->iolength);
3839 gfc_free_expr (inquire->convert);
3840 gfc_free_expr (inquire->strm_pos);
3841 gfc_free_expr (inquire->asynchronous);
3842 gfc_free_expr (inquire->decimal);
3843 gfc_free_expr (inquire->pending);
3844 gfc_free_expr (inquire->id);
3845 gfc_free_expr (inquire->sign);
3846 gfc_free_expr (inquire->size);
3847 gfc_free_expr (inquire->round);
3848 free (inquire);
3849 }
3850
3851
3852 /* Match an element of an INQUIRE statement. */
3853
3854 #define RETM if (m != MATCH_NO) return m;
3855
3856 static match
3857 match_inquire_element (gfc_inquire *inquire)
3858 {
3859 match m;
3860
3861 m = match_etag (&tag_unit, &inquire->unit);
3862 RETM m = match_etag (&tag_file, &inquire->file);
3863 RETM m = match_ltag (&tag_err, &inquire->err);
3864 RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg);
3865 RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
3866 RETM m = match_vtag (&tag_exist, &inquire->exist);
3867 RETM m = match_vtag (&tag_opened, &inquire->opened);
3868 RETM m = match_vtag (&tag_named, &inquire->named);
3869 RETM m = match_vtag (&tag_name, &inquire->name);
3870 RETM m = match_out_tag (&tag_number, &inquire->number);
3871 RETM m = match_vtag (&tag_s_access, &inquire->access);
3872 RETM m = match_vtag (&tag_sequential, &inquire->sequential);
3873 RETM m = match_vtag (&tag_direct, &inquire->direct);
3874 RETM m = match_vtag (&tag_s_form, &inquire->form);
3875 RETM m = match_vtag (&tag_formatted, &inquire->formatted);
3876 RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
3877 RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
3878 RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
3879 RETM m = match_vtag (&tag_s_blank, &inquire->blank);
3880 RETM m = match_vtag (&tag_s_position, &inquire->position);
3881 RETM m = match_vtag (&tag_s_action, &inquire->action);
3882 RETM m = match_vtag (&tag_read, &inquire->read);
3883 RETM m = match_vtag (&tag_write, &inquire->write);
3884 RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
3885 RETM m = match_vtag (&tag_s_async, &inquire->asynchronous);
3886 RETM m = match_vtag (&tag_s_delim, &inquire->delim);
3887 RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
3888 RETM m = match_out_tag (&tag_size, &inquire->size);
3889 RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
3890 RETM m = match_vtag (&tag_s_round, &inquire->round);
3891 RETM m = match_vtag (&tag_s_sign, &inquire->sign);
3892 RETM m = match_vtag (&tag_s_pad, &inquire->pad);
3893 RETM m = match_out_tag (&tag_iolength, &inquire->iolength);
3894 RETM m = match_vtag (&tag_convert, &inquire->convert);
3895 RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
3896 RETM m = match_vtag (&tag_pending, &inquire->pending);
3897 RETM m = match_vtag (&tag_id, &inquire->id);
3898 RETM m = match_vtag (&tag_s_iqstream, &inquire->iqstream);
3899 RETM return MATCH_NO;
3900 }
3901
3902 #undef RETM
3903
3904
3905 match
3906 gfc_match_inquire (void)
3907 {
3908 gfc_inquire *inquire;
3909 gfc_code *code;
3910 match m;
3911 locus loc;
3912
3913 m = gfc_match_char ('(');
3914 if (m == MATCH_NO)
3915 return m;
3916
3917 inquire = XCNEW (gfc_inquire);
3918
3919 loc = gfc_current_locus;
3920
3921 m = match_inquire_element (inquire);
3922 if (m == MATCH_ERROR)
3923 goto cleanup;
3924 if (m == MATCH_NO)
3925 {
3926 m = gfc_match_expr (&inquire->unit);
3927 if (m == MATCH_ERROR)
3928 goto cleanup;
3929 if (m == MATCH_NO)
3930 goto syntax;
3931 }
3932
3933 /* See if we have the IOLENGTH form of the inquire statement. */
3934 if (inquire->iolength != NULL)
3935 {
3936 if (gfc_match_char (')') != MATCH_YES)
3937 goto syntax;
3938
3939 m = match_io_list (M_INQUIRE, &code);
3940 if (m == MATCH_ERROR)
3941 goto cleanup;
3942 if (m == MATCH_NO)
3943 goto syntax;
3944
3945 new_st.op = EXEC_IOLENGTH;
3946 new_st.expr1 = inquire->iolength;
3947 new_st.ext.inquire = inquire;
3948
3949 if (gfc_pure (NULL))
3950 {
3951 gfc_free_statements (code);
3952 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3953 return MATCH_ERROR;
3954 }
3955
3956 if (gfc_implicit_pure (NULL))
3957 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3958
3959 new_st.block = gfc_get_code (EXEC_IOLENGTH);
3960 terminate_io (code);
3961 new_st.block->next = code;
3962 return MATCH_YES;
3963 }
3964
3965 /* At this point, we have the non-IOLENGTH inquire statement. */
3966 for (;;)
3967 {
3968 if (gfc_match_char (')') == MATCH_YES)
3969 break;
3970 if (gfc_match_char (',') != MATCH_YES)
3971 goto syntax;
3972
3973 m = match_inquire_element (inquire);
3974 if (m == MATCH_ERROR)
3975 goto cleanup;
3976 if (m == MATCH_NO)
3977 goto syntax;
3978
3979 if (inquire->iolength != NULL)
3980 {
3981 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
3982 goto cleanup;
3983 }
3984 }
3985
3986 if (gfc_match_eos () != MATCH_YES)
3987 goto syntax;
3988
3989 if (inquire->unit != NULL && inquire->file != NULL)
3990 {
3991 gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
3992 "UNIT specifiers", &loc);
3993 goto cleanup;
3994 }
3995
3996 if (inquire->unit == NULL && inquire->file == NULL)
3997 {
3998 gfc_error ("INQUIRE statement at %L requires either FILE or "
3999 "UNIT specifier", &loc);
4000 goto cleanup;
4001 }
4002
4003 if (gfc_pure (NULL))
4004 {
4005 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4006 goto cleanup;
4007 }
4008
4009 if (gfc_implicit_pure (NULL))
4010 gfc_current_ns->proc_name->attr.implicit_pure = 0;
4011
4012 if (inquire->id != NULL && inquire->pending == NULL)
4013 {
4014 gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
4015 "the ID= specifier", &loc);
4016 goto cleanup;
4017 }
4018
4019 new_st.op = EXEC_INQUIRE;
4020 new_st.ext.inquire = inquire;
4021 return MATCH_YES;
4022
4023 syntax:
4024 gfc_syntax_error (ST_INQUIRE);
4025
4026 cleanup:
4027 gfc_free_inquire (inquire);
4028 return MATCH_ERROR;
4029 }
4030
4031
4032 /* Resolve everything in a gfc_inquire structure. */
4033
4034 bool
4035 gfc_resolve_inquire (gfc_inquire *inquire)
4036 {
4037 RESOLVE_TAG (&tag_unit, inquire->unit);
4038 RESOLVE_TAG (&tag_file, inquire->file);
4039 RESOLVE_TAG (&tag_id, inquire->id);
4040
4041 /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4042 contexts. Thus, use an extended RESOLVE_TAG macro for that. */
4043 #define INQUIRE_RESOLVE_TAG(tag, expr) \
4044 RESOLVE_TAG (tag, expr); \
4045 if (expr) \
4046 { \
4047 char context[64]; \
4048 sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
4049 if (gfc_check_vardef_context ((expr), false, false, false, \
4050 context) == false) \
4051 return false; \
4052 }
4053 INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
4054 INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat);
4055 INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist);
4056 INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened);
4057 INQUIRE_RESOLVE_TAG (&tag_number, inquire->number);
4058 INQUIRE_RESOLVE_TAG (&tag_named, inquire->named);
4059 INQUIRE_RESOLVE_TAG (&tag_name, inquire->name);
4060 INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access);
4061 INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential);
4062 INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct);
4063 INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form);
4064 INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted);
4065 INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
4066 INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl);
4067 INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
4068 INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank);
4069 INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position);
4070 INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action);
4071 INQUIRE_RESOLVE_TAG (&tag_read, inquire->read);
4072 INQUIRE_RESOLVE_TAG (&tag_write, inquire->write);
4073 INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
4074 INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim);
4075 INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad);
4076 INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
4077 INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4078 INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength);
4079 INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert);
4080 INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
4081 INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
4082 INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign);
4083 INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4084 INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending);
4085 INQUIRE_RESOLVE_TAG (&tag_size, inquire->size);
4086 INQUIRE_RESOLVE_TAG (&tag_s_decimal, inquire->decimal);
4087 INQUIRE_RESOLVE_TAG (&tag_s_iqstream, inquire->iqstream);
4088 #undef INQUIRE_RESOLVE_TAG
4089
4090 if (!gfc_reference_st_label (inquire->err, ST_LABEL_TARGET))
4091 return false;
4092
4093 return true;
4094 }
4095
4096
4097 void
4098 gfc_free_wait (gfc_wait *wait)
4099 {
4100 if (wait == NULL)
4101 return;
4102
4103 gfc_free_expr (wait->unit);
4104 gfc_free_expr (wait->iostat);
4105 gfc_free_expr (wait->iomsg);
4106 gfc_free_expr (wait->id);
4107 free (wait);
4108 }
4109
4110
4111 bool
4112 gfc_resolve_wait (gfc_wait *wait)
4113 {
4114 RESOLVE_TAG (&tag_unit, wait->unit);
4115 RESOLVE_TAG (&tag_iomsg, wait->iomsg);
4116 RESOLVE_TAG (&tag_iostat, wait->iostat);
4117 RESOLVE_TAG (&tag_id, wait->id);
4118
4119 if (!gfc_reference_st_label (wait->err, ST_LABEL_TARGET))
4120 return false;
4121
4122 if (!gfc_reference_st_label (wait->end, ST_LABEL_TARGET))
4123 return false;
4124
4125 return true;
4126 }
4127
4128 /* Match an element of a WAIT statement. */
4129
4130 #define RETM if (m != MATCH_NO) return m;
4131
4132 static match
4133 match_wait_element (gfc_wait *wait)
4134 {
4135 match m;
4136
4137 m = match_etag (&tag_unit, &wait->unit);
4138 RETM m = match_ltag (&tag_err, &wait->err);
4139 RETM m = match_ltag (&tag_end, &wait->eor);
4140 RETM m = match_ltag (&tag_eor, &wait->end);
4141 RETM m = match_out_tag (&tag_iomsg, &wait->iomsg);
4142 RETM m = match_out_tag (&tag_iostat, &wait->iostat);
4143 RETM m = match_etag (&tag_id, &wait->id);
4144 RETM return MATCH_NO;
4145 }
4146
4147 #undef RETM
4148
4149
4150 match
4151 gfc_match_wait (void)
4152 {
4153 gfc_wait *wait;
4154 match m;
4155
4156 m = gfc_match_char ('(');
4157 if (m == MATCH_NO)
4158 return m;
4159
4160 wait = XCNEW (gfc_wait);
4161
4162 m = match_wait_element (wait);
4163 if (m == MATCH_ERROR)
4164 goto cleanup;
4165 if (m == MATCH_NO)
4166 {
4167 m = gfc_match_expr (&wait->unit);
4168 if (m == MATCH_ERROR)
4169 goto cleanup;
4170 if (m == MATCH_NO)
4171 goto syntax;
4172 }
4173
4174 for (;;)
4175 {
4176 if (gfc_match_char (')') == MATCH_YES)
4177 break;
4178 if (gfc_match_char (',') != MATCH_YES)
4179 goto syntax;
4180
4181 m = match_wait_element (wait);
4182 if (m == MATCH_ERROR)
4183 goto cleanup;
4184 if (m == MATCH_NO)
4185 goto syntax;
4186 }
4187
4188 if (!gfc_notify_std (GFC_STD_F2003, "WAIT at %C "
4189 "not allowed in Fortran 95"))
4190 goto cleanup;
4191
4192 if (gfc_pure (NULL))
4193 {
4194 gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4195 goto cleanup;
4196 }
4197
4198 if (gfc_implicit_pure (NULL))
4199 gfc_current_ns->proc_name->attr.implicit_pure = 0;
4200
4201 new_st.op = EXEC_WAIT;
4202 new_st.ext.wait = wait;
4203
4204 return MATCH_YES;
4205
4206 syntax:
4207 gfc_syntax_error (ST_WAIT);
4208
4209 cleanup:
4210 gfc_free_wait (wait);
4211 return MATCH_ERROR;
4212 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org