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