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