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