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