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