?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Skip several gcc.dg/builtin-dynamic-object-size tests on hppa*-*-hpux*
[official-gcc.git] / gcc / fortran / io.cc
blob6fd69f7c9a8fc3ba176a4ff589942b7c68d4a361
1 /* Deal with I/O statements & related stuff.
2 Copyright (C) 2000-2024 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
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
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
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
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 *
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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 static bool
2014 check_open_constraints (gfc_open *open, locus *where);
2015
2016 /* Resolve everything in a gfc_open structure. */
2017
2018 bool
2019 gfc_resolve_open (gfc_open *open, locus *where)
2020 {
2021 RESOLVE_TAG (&tag_unit, open->unit);
2022 RESOLVE_TAG (&tag_iomsg, open->iomsg);
2023 RESOLVE_TAG (&tag_iostat, open->iostat);
2024 RESOLVE_TAG (&tag_file, open->file);
2025 RESOLVE_TAG (&tag_status, open->status);
2026 RESOLVE_TAG (&tag_e_access, open->access);
2027 RESOLVE_TAG (&tag_e_form, open->form);
2028 RESOLVE_TAG (&tag_e_recl, open->recl);
2029 RESOLVE_TAG (&tag_e_blank, open->blank);
2030 RESOLVE_TAG (&tag_e_position, open->position);
2031 RESOLVE_TAG (&tag_e_action, open->action);
2032 RESOLVE_TAG (&tag_e_delim, open->delim);
2033 RESOLVE_TAG (&tag_e_pad, open->pad);
2034 RESOLVE_TAG (&tag_e_decimal, open->decimal);
2035 RESOLVE_TAG (&tag_e_encoding, open->encoding);
2036 RESOLVE_TAG (&tag_e_async, open->asynchronous);
2037 RESOLVE_TAG (&tag_e_round, open->round);
2038 RESOLVE_TAG (&tag_e_sign, open->sign);
2039 RESOLVE_TAG (&tag_convert, open->convert);
2040 RESOLVE_TAG (&tag_newunit, open->newunit);
2041 RESOLVE_TAG (&tag_e_share, open->share);
2042 RESOLVE_TAG (&tag_cc, open->cc);
2043
2044 if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET))
2045 return false;
2046
2047 return check_open_constraints (open, where);
2048 }
2049
2050
2051 /* Check if a given value for a SPECIFIER is either in the list of values
2052 allowed in F95 or F2003, issuing an error message and returning a zero
2053 value if it is not allowed. */
2054
2055
2056 static bool
2057 compare_to_allowed_values (const char *specifier, const char *allowed[],
2058 const char *allowed_f2003[],
2059 const char *allowed_gnu[], gfc_char_t *value,
2060 const char *statement, bool warn, locus *where,
2061 int *num = NULL)
2062 {
2063 int i;
2064 unsigned int len;
2065
2066 len = gfc_wide_strlen (value);
2067 if (len > 0)
2068 {
2069 for (len--; len > 0; len--)
2070 if (value[len] != ' ')
2071 break;
2072 len++;
2073 }
2074
2075 for (i = 0; allowed[i]; i++)
2076 if (len == strlen (allowed[i])
2077 && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
2078 {
2079 if (num)
2080 *num = i;
2081 return 1;
2082 }
2083
2084 if (!where)
2085 where = &gfc_current_locus;
2086
2087 for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
2088 if (len == strlen (allowed_f2003[i])
2089 && gfc_wide_strncasecmp (value, allowed_f2003[i],
2090 strlen (allowed_f2003[i])) == 0)
2091 {
2092 notification n = gfc_notification_std (GFC_STD_F2003);
2093
2094 if (n == WARNING || (warn && n == ERROR))
2095 {
2096 gfc_warning (0, "Fortran 2003: %s specifier in %s statement at %L "
2097 "has value %qs", specifier, statement, where,
2098 allowed_f2003[i]);
2099 return 1;
2100 }
2101 else
2102 if (n == ERROR)
2103 {
2104 gfc_notify_std (GFC_STD_F2003, "%s specifier in "
2105 "%s statement at %L has value %qs", specifier,
2106 statement, where, allowed_f2003[i]);
2107 return 0;
2108 }
2109
2110 /* n == SILENT */
2111 return 1;
2112 }
2113
2114 for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
2115 if (len == strlen (allowed_gnu[i])
2116 && gfc_wide_strncasecmp (value, allowed_gnu[i],
2117 strlen (allowed_gnu[i])) == 0)
2118 {
2119 notification n = gfc_notification_std (GFC_STD_GNU);
2120
2121 if (n == WARNING || (warn && n == ERROR))
2122 {
2123 gfc_warning (0, "Extension: %s specifier in %s statement at %L "
2124 "has value %qs", specifier, statement, where,
2125 allowed_gnu[i]);
2126 return 1;
2127 }
2128 else
2129 if (n == ERROR)
2130 {
2131 gfc_notify_std (GFC_STD_GNU, "%s specifier in "
2132 "%s statement at %L has value %qs", specifier,
2133 statement, where, allowed_gnu[i]);
2134 return 0;
2135 }
2136
2137 /* n == SILENT */
2138 return 1;
2139 }
2140
2141 if (warn)
2142 {
2143 char *s = gfc_widechar_to_char (value, -1);
2144 gfc_warning (0,
2145 "%s specifier in %s statement at %L has invalid value %qs",
2146 specifier, statement, where, s);
2147 free (s);
2148 return 1;
2149 }
2150 else
2151 {
2152 char *s = gfc_widechar_to_char (value, -1);
2153 gfc_error ("%s specifier in %s statement at %L has invalid value %qs",
2154 specifier, statement, where, s);
2155 free (s);
2156 return 0;
2157 }
2158 }
2159
2160
2161 /* Check constraints on the OPEN statement.
2162 Similar to check_io_constraints for data transfer statements.
2163 At this point all tags have already been resolved via resolve_tag, which,
2164 among other things, verifies that BT_CHARACTER tags are of default kind. */
2165
2166 static bool
2167 check_open_constraints (gfc_open *open, locus *where)
2168 {
2169 #define warn_or_error(...) \
2170 { \
2171 if (warn) \
2172 gfc_warning (0, __VA_ARGS__); \
2173 else \
2174 { \
2175 gfc_error (__VA_ARGS__); \
2176 return false; \
2177 } \
2178 }
2179
2180 bool warn = (open->err || open->iostat) ? true : false;
2181
2182 /* Checks on the ACCESS specifier. */
2183 if (open->access && open->access->expr_type == EXPR_CONSTANT)
2184 {
2185 static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
2186 static const char *access_f2003[] = { "STREAM", NULL };
2187 static const char *access_gnu[] = { "APPEND", NULL };
2188
2189 if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
2190 access_gnu,
2191 open->access->value.character.string,
2192 "OPEN", warn, &open->access->where))
2193 return false;
2194 }
2195
2196 /* Checks on the ACTION specifier. */
2197 if (open->action && open->action->expr_type == EXPR_CONSTANT)
2198 {
2199 gfc_char_t *str = open->action->value.character.string;
2200 static const char *action[] = { "READ", "WRITE", "READWRITE", NULL };
2201
2202 if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
2203 str, "OPEN", warn, &open->action->where))
2204 return false;
2205
2206 /* With READONLY, only allow ACTION='READ'. */
2207 if (open->readonly && (gfc_wide_strlen (str) != 4
2208 || gfc_wide_strncasecmp (str, "READ", 4) != 0))
2209 {
2210 gfc_error ("ACTION type conflicts with READONLY specifier at %L",
2211 &open->action->where);
2212 return false;
2213 }
2214 }
2215
2216 /* If we see READONLY and no ACTION, set ACTION='READ'. */
2217 else if (open->readonly && open->action == NULL)
2218 {
2219 open->action = gfc_get_character_expr (gfc_default_character_kind,
2220 &gfc_current_locus, "read", 4);
2221 }
2222
2223 /* Checks on the ASYNCHRONOUS specifier. */
2224 if (open->asynchronous)
2225 {
2226 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %L "
2227 "not allowed in Fortran 95",
2228 &open->asynchronous->where))
2229 return false;
2230
2231 if (open->asynchronous->expr_type == EXPR_CONSTANT)
2232 {
2233 static const char * asynchronous[] = { "YES", "NO", NULL };
2234
2235 if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous,
2236 NULL, NULL, open->asynchronous->value.character.string,
2237 "OPEN", warn, &open->asynchronous->where))
2238 return false;
2239 }
2240 }
2241
2242 /* Checks on the BLANK specifier. */
2243 if (open->blank)
2244 {
2245 if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L "
2246 "not allowed in Fortran 95", &open->blank->where))
2247 return false;
2248
2249 if (open->blank->expr_type == EXPR_CONSTANT)
2250 {
2251 static const char *blank[] = { "ZERO", "NULL", NULL };
2252
2253 if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
2254 open->blank->value.character.string,
2255 "OPEN", warn, &open->blank->where))
2256 return false;
2257 }
2258 }
2259
2260 /* Checks on the CARRIAGECONTROL specifier. */
2261 if (open->cc && open->cc->expr_type == EXPR_CONSTANT)
2262 {
2263 static const char *cc[] = { "LIST", "FORTRAN", "NONE", NULL };
2264 if (!compare_to_allowed_values ("CARRIAGECONTROL", cc, NULL, NULL,
2265 open->cc->value.character.string,
2266 "OPEN", warn, &open->cc->where))
2267 return false;
2268 }
2269
2270 /* Checks on the DECIMAL specifier. */
2271 if (open->decimal)
2272 {
2273 if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L "
2274 "not allowed in Fortran 95", &open->decimal->where))
2275 return false;
2276
2277 if (open->decimal->expr_type == EXPR_CONSTANT)
2278 {
2279 static const char * decimal[] = { "COMMA", "POINT", NULL };
2280
2281 if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
2282 open->decimal->value.character.string,
2283 "OPEN", warn, &open->decimal->where))
2284 return false;
2285 }
2286 }
2287
2288 /* Checks on the DELIM specifier. */
2289 if (open->delim)
2290 {
2291 if (open->delim->expr_type == EXPR_CONSTANT)
2292 {
2293 static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
2294
2295 if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
2296 open->delim->value.character.string,
2297 "OPEN", warn, &open->delim->where))
2298 return false;
2299 }
2300 }
2301
2302 /* Checks on the ENCODING specifier. */
2303 if (open->encoding)
2304 {
2305 if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %L "
2306 "not allowed in Fortran 95", &open->encoding->where))
2307 return false;
2308
2309 if (open->encoding->expr_type == EXPR_CONSTANT)
2310 {
2311 static const char * encoding[] = { "DEFAULT", "UTF-8", NULL };
2312
2313 if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
2314 open->encoding->value.character.string,
2315 "OPEN", warn, &open->encoding->where))
2316 return false;
2317 }
2318 }
2319
2320 /* Checks on the FORM specifier. */
2321 if (open->form && open->form->expr_type == EXPR_CONSTANT)
2322 {
2323 static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
2324
2325 if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
2326 open->form->value.character.string,
2327 "OPEN", warn, &open->form->where))
2328 return false;
2329 }
2330
2331 /* Checks on the PAD specifier. */
2332 if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
2333 {
2334 static const char *pad[] = { "YES", "NO", NULL };
2335
2336 if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
2337 open->pad->value.character.string,
2338 "OPEN", warn, &open->pad->where))
2339 return false;
2340 }
2341
2342 /* Checks on the POSITION specifier. */
2343 if (open->position && open->position->expr_type == EXPR_CONSTANT)
2344 {
2345 static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
2346
2347 if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
2348 open->position->value.character.string,
2349 "OPEN", warn, &open->position->where))
2350 return false;
2351 }
2352
2353 /* Checks on the ROUND specifier. */
2354 if (open->round)
2355 {
2356 if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L "
2357 "not allowed in Fortran 95", &open->round->where))
2358 return false;
2359
2360 if (open->round->expr_type == EXPR_CONSTANT)
2361 {
2362 static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
2363 "COMPATIBLE", "PROCESSOR_DEFINED",
2364 NULL };
2365
2366 if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
2367 open->round->value.character.string,
2368 "OPEN", warn, &open->round->where))
2369 return false;
2370 }
2371 }
2372
2373 /* Checks on the SHARE specifier. */
2374 if (open->share && open->share->expr_type == EXPR_CONSTANT)
2375 {
2376 static const char *share[] = { "DENYNONE", "DENYRW", NULL };
2377 if (!compare_to_allowed_values ("SHARE", share, NULL, NULL,
2378 open->share->value.character.string,
2379 "OPEN", warn, &open->share->where))
2380 return false;
2381 }
2382
2383 /* Checks on the SIGN specifier. */
2384 if (open->sign)
2385 {
2386 if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %L "
2387 "not allowed in Fortran 95", &open->sign->where))
2388 return false;
2389
2390 if (open->sign->expr_type == EXPR_CONSTANT)
2391 {
2392 static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
2393 NULL };
2394
2395 if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
2396 open->sign->value.character.string,
2397 "OPEN", warn, &open->sign->where))
2398 return false;
2399 }
2400 }
2401
2402 /* Checks on the RECL specifier. */
2403 if (open->recl && open->recl->expr_type == EXPR_CONSTANT
2404 && open->recl->ts.type == BT_INTEGER
2405 && mpz_sgn (open->recl->value.integer) != 1)
2406 {
2407 warn_or_error (G_("RECL in OPEN statement at %L must be positive"),
2408 &open->recl->where);
2409 }
2410
2411 /* Checks on the STATUS specifier. */
2412 if (open->status && open->status->expr_type == EXPR_CONSTANT)
2413 {
2414 static const char *status[] = { "OLD", "NEW", "SCRATCH",
2415 "REPLACE", "UNKNOWN", NULL };
2416
2417 if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2418 open->status->value.character.string,
2419 "OPEN", warn, &open->status->where))
2420 return false;
2421
2422 /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2423 the FILE= specifier shall appear. */
2424 if (open->file == NULL
2425 && (gfc_wide_strncasecmp (open->status->value.character.string,
2426 "replace", 7) == 0
2427 || gfc_wide_strncasecmp (open->status->value.character.string,
2428 "new", 3) == 0))
2429 {
2430 char *s = gfc_widechar_to_char (open->status->value.character.string,
2431 -1);
2432 warn_or_error (G_("The STATUS specified in OPEN statement at %L is "
2433 "%qs and no FILE specifier is present"),
2434 &open->status->where, s);
2435 free (s);
2436 }
2437
2438 /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2439 the FILE= specifier shall not appear. */
2440 if (gfc_wide_strncasecmp (open->status->value.character.string,
2441 "scratch", 7) == 0 && open->file)
2442 {
2443 warn_or_error (G_("The STATUS specified in OPEN statement at %L "
2444 "cannot have the value SCRATCH if a FILE specifier "
2445 "is present"), &open->status->where);
2446 }
2447 }
2448
2449 /* Checks on NEWUNIT specifier. */
2450 if (open->newunit)
2451 {
2452 if (open->unit)
2453 {
2454 gfc_error ("UNIT specifier not allowed with NEWUNIT at %L",
2455 &open->newunit->where);
2456 return false;
2457 }
2458
2459 if (!open->file &&
2460 (!open->status ||
2461 (open->status->expr_type == EXPR_CONSTANT
2462 && gfc_wide_strncasecmp (open->status->value.character.string,
2463 "scratch", 7) != 0)))
2464 {
2465 gfc_error ("NEWUNIT specifier must have FILE= "
2466 "or STATUS='scratch' at %L", &open->newunit->where);
2467 return false;
2468 }
2469 }
2470 else if (!open->unit)
2471 {
2472 gfc_error ("OPEN statement at %L must have UNIT or NEWUNIT specified",
2473 where);
2474 return false;
2475 }
2476
2477 /* Things that are not allowed for unformatted I/O. */
2478 if (open->form && open->form->expr_type == EXPR_CONSTANT
2479 && (open->delim || open->decimal || open->encoding || open->round
2480 || open->sign || open->pad || open->blank)
2481 && gfc_wide_strncasecmp (open->form->value.character.string,
2482 "unformatted", 11) == 0)
2483 {
2484 locus *loc;
2485 const char *spec;
2486 if (open->delim)
2487 {
2488 loc = &open->delim->where;
2489 spec = "DELIM ";
2490 }
2491 else if (open->pad)
2492 {
2493 loc = &open->pad->where;
2494 spec = "PAD ";
2495 }
2496 else if (open->blank)
2497 {
2498 loc = &open->blank->where;
2499 spec = "BLANK ";
2500 }
2501 else
2502 {
2503 loc = where;
2504 spec = "";
2505 }
2506
2507 warn_or_error (G_("%sspecifier at %L not allowed in OPEN statement for "
2508 "unformatted I/O"), spec, loc);
2509 }
2510
2511 if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
2512 && gfc_wide_strncasecmp (open->access->value.character.string,
2513 "stream", 6) == 0)
2514 {
2515 warn_or_error (G_("RECL specifier not allowed in OPEN statement at %L for "
2516 "stream I/O"), &open->recl->where);
2517 }
2518
2519 if (open->position
2520 && open->access && open->access->expr_type == EXPR_CONSTANT
2521 && !(gfc_wide_strncasecmp (open->access->value.character.string,
2522 "sequential", 10) == 0
2523 || gfc_wide_strncasecmp (open->access->value.character.string,
2524 "stream", 6) == 0
2525 || gfc_wide_strncasecmp (open->access->value.character.string,
2526 "append", 6) == 0))
2527 {
2528 warn_or_error (G_("POSITION specifier in OPEN statement at %L only allowed "
2529 "for stream or sequential ACCESS"), &open->position->where);
2530 }
2531
2532 return true;
2533 #undef warn_or_error
2534 }
2535
2536
2537 /* Match an OPEN statement. */
2538
2539 match
2540 gfc_match_open (void)
2541 {
2542 gfc_open *open;
2543 match m;
2544
2545 m = gfc_match_char ('(');
2546 if (m == MATCH_NO)
2547 return m;
2548
2549 open = XCNEW (gfc_open);
2550
2551 m = match_open_element (open);
2552
2553 if (m == MATCH_ERROR)
2554 goto cleanup;
2555 if (m == MATCH_NO)
2556 {
2557 m = gfc_match_expr (&open->unit);
2558 if (m == MATCH_ERROR)
2559 goto cleanup;
2560 }
2561
2562 for (;;)
2563 {
2564 if (gfc_match_char (')') == MATCH_YES)
2565 break;
2566 if (gfc_match_char (',') != MATCH_YES)
2567 goto syntax;
2568
2569 m = match_open_element (open);
2570 if (m == MATCH_ERROR)
2571 goto cleanup;
2572 if (m == MATCH_NO)
2573 goto syntax;
2574 }
2575
2576 if (gfc_match_eos () == MATCH_NO)
2577 goto syntax;
2578
2579 if (gfc_pure (NULL))
2580 {
2581 gfc_error ("OPEN statement not allowed in PURE procedure at %C");
2582 goto cleanup;
2583 }
2584
2585 gfc_unset_implicit_pure (NULL);
2586
2587 new_st.op = EXEC_OPEN;
2588 new_st.ext.open = open;
2589 return MATCH_YES;
2590
2591 syntax:
2592 gfc_syntax_error (ST_OPEN);
2593
2594 cleanup:
2595 gfc_free_open (open);
2596 return MATCH_ERROR;
2597 }
2598
2599
2600 /* Free a gfc_close structure an all its expressions. */
2601
2602 void
2603 gfc_free_close (gfc_close *close)
2604 {
2605 if (close == NULL)
2606 return;
2607
2608 gfc_free_expr (close->unit);
2609 gfc_free_expr (close->iomsg);
2610 gfc_free_expr (close->iostat);
2611 gfc_free_expr (close->status);
2612 free (close);
2613 }
2614
2615
2616 /* Match elements of a CLOSE statement. */
2617
2618 static match
2619 match_close_element (gfc_close *close)
2620 {
2621 match m;
2622
2623 m = match_etag (&tag_unit, &close->unit);
2624 if (m != MATCH_NO)
2625 return m;
2626 m = match_etag (&tag_status, &close->status);
2627 if (m != MATCH_NO)
2628 return m;
2629 m = match_etag (&tag_iomsg, &close->iomsg);
2630 if (m != MATCH_NO)
2631 return m;
2632 m = match_out_tag (&tag_iostat, &close->iostat);
2633 if (m != MATCH_NO)
2634 return m;
2635 m = match_ltag (&tag_err, &close->err);
2636 if (m != MATCH_NO)
2637 return m;
2638
2639 return MATCH_NO;
2640 }
2641
2642
2643 /* Match a CLOSE statement. */
2644
2645 match
2646 gfc_match_close (void)
2647 {
2648 gfc_close *close;
2649 match m;
2650
2651 m = gfc_match_char ('(');
2652 if (m == MATCH_NO)
2653 return m;
2654
2655 close = XCNEW (gfc_close);
2656
2657 m = match_close_element (close);
2658
2659 if (m == MATCH_ERROR)
2660 goto cleanup;
2661 if (m == MATCH_NO)
2662 {
2663 m = gfc_match_expr (&close->unit);
2664 if (m == MATCH_NO)
2665 goto syntax;
2666 if (m == MATCH_ERROR)
2667 goto cleanup;
2668 }
2669
2670 for (;;)
2671 {
2672 if (gfc_match_char (')') == MATCH_YES)
2673 break;
2674 if (gfc_match_char (',') != MATCH_YES)
2675 goto syntax;
2676
2677 m = match_close_element (close);
2678 if (m == MATCH_ERROR)
2679 goto cleanup;
2680 if (m == MATCH_NO)
2681 goto syntax;
2682 }
2683
2684 if (gfc_match_eos () == MATCH_NO)
2685 goto syntax;
2686
2687 if (gfc_pure (NULL))
2688 {
2689 gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2690 goto cleanup;
2691 }
2692
2693 gfc_unset_implicit_pure (NULL);
2694
2695 new_st.op = EXEC_CLOSE;
2696 new_st.ext.close = close;
2697 return MATCH_YES;
2698
2699 syntax:
2700 gfc_syntax_error (ST_CLOSE);
2701
2702 cleanup:
2703 gfc_free_close (close);
2704 return MATCH_ERROR;
2705 }
2706
2707
2708 static bool
2709 check_close_constraints (gfc_close *close, locus *where)
2710 {
2711 bool warn = (close->iostat || close->err) ? true : false;
2712
2713 if (close->unit == NULL)
2714 {
2715 gfc_error ("CLOSE statement at %L requires a UNIT number", where);
2716 return false;
2717 }
2718
2719 if (close->unit->expr_type == EXPR_CONSTANT
2720 && close->unit->ts.type == BT_INTEGER
2721 && mpz_sgn (close->unit->value.integer) < 0)
2722 {
2723 gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2724 &close->unit->where);
2725 }
2726
2727 /* Checks on the STATUS specifier. */
2728 if (close->status && close->status->expr_type == EXPR_CONSTANT)
2729 {
2730 static const char *status[] = { "KEEP", "DELETE", NULL };
2731
2732 if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2733 close->status->value.character.string,
2734 "CLOSE", warn, &close->status->where))
2735 return false;
2736 }
2737
2738 return true;
2739 }
2740
2741 /* Resolve everything in a gfc_close structure. */
2742
2743 bool
2744 gfc_resolve_close (gfc_close *close, locus *where)
2745 {
2746 RESOLVE_TAG (&tag_unit, close->unit);
2747 RESOLVE_TAG (&tag_iomsg, close->iomsg);
2748 RESOLVE_TAG (&tag_iostat, close->iostat);
2749 RESOLVE_TAG (&tag_status, close->status);
2750
2751 if (!gfc_reference_st_label (close->err, ST_LABEL_TARGET))
2752 return false;
2753
2754 return check_close_constraints (close, where);
2755 }
2756
2757
2758 /* Free a gfc_filepos structure. */
2759
2760 void
2761 gfc_free_filepos (gfc_filepos *fp)
2762 {
2763 gfc_free_expr (fp->unit);
2764 gfc_free_expr (fp->iomsg);
2765 gfc_free_expr (fp->iostat);
2766 free (fp);
2767 }
2768
2769
2770 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
2771
2772 static match
2773 match_file_element (gfc_filepos *fp)
2774 {
2775 match m;
2776
2777 m = match_etag (&tag_unit, &fp->unit);
2778 if (m != MATCH_NO)
2779 return m;
2780 m = match_etag (&tag_iomsg, &fp->iomsg);
2781 if (m != MATCH_NO)
2782 return m;
2783 m = match_out_tag (&tag_iostat, &fp->iostat);
2784 if (m != MATCH_NO)
2785 return m;
2786 m = match_ltag (&tag_err, &fp->err);
2787 if (m != MATCH_NO)
2788 return m;
2789
2790 return MATCH_NO;
2791 }
2792
2793
2794 /* Match the second half of the file-positioning statements, REWIND,
2795 BACKSPACE, ENDFILE, or the FLUSH statement. */
2796
2797 static match
2798 match_filepos (gfc_statement st, gfc_exec_op op)
2799 {
2800 gfc_filepos *fp;
2801 match m;
2802
2803 fp = XCNEW (gfc_filepos);
2804
2805 if (gfc_match_char ('(') == MATCH_NO)
2806 {
2807 m = gfc_match_expr (&fp->unit);
2808 if (m == MATCH_ERROR)
2809 goto cleanup;
2810 if (m == MATCH_NO)
2811 goto syntax;
2812
2813 goto done;
2814 }
2815
2816 m = match_file_element (fp);
2817 if (m == MATCH_ERROR)
2818 goto cleanup;
2819 if (m == MATCH_NO)
2820 {
2821 m = gfc_match_expr (&fp->unit);
2822 if (m == MATCH_ERROR || m == MATCH_NO)
2823 goto syntax;
2824 }
2825
2826 for (;;)
2827 {
2828 if (gfc_match_char (')') == MATCH_YES)
2829 break;
2830 if (gfc_match_char (',') != MATCH_YES)
2831 goto syntax;
2832
2833 m = match_file_element (fp);
2834 if (m == MATCH_ERROR)
2835 goto cleanup;
2836 if (m == MATCH_NO)
2837 goto syntax;
2838 }
2839
2840 done:
2841 if (gfc_match_eos () != MATCH_YES)
2842 goto syntax;
2843
2844 if (gfc_pure (NULL))
2845 {
2846 gfc_error ("%s statement not allowed in PURE procedure at %C",
2847 gfc_ascii_statement (st));
2848
2849 goto cleanup;
2850 }
2851
2852 gfc_unset_implicit_pure (NULL);
2853
2854 new_st.op = op;
2855 new_st.ext.filepos = fp;
2856 return MATCH_YES;
2857
2858 syntax:
2859 gfc_syntax_error (st);
2860
2861 cleanup:
2862 gfc_free_filepos (fp);
2863 return MATCH_ERROR;
2864 }
2865
2866
2867 bool
2868 gfc_resolve_filepos (gfc_filepos *fp, locus *where)
2869 {
2870 RESOLVE_TAG (&tag_unit, fp->unit);
2871 RESOLVE_TAG (&tag_iostat, fp->iostat);
2872 RESOLVE_TAG (&tag_iomsg, fp->iomsg);
2873
2874 if (!fp->unit && (fp->iostat || fp->iomsg || fp->err))
2875 {
2876 gfc_error ("UNIT number missing in statement at %L", where);
2877 return false;
2878 }
2879
2880 if (!gfc_reference_st_label (fp->err, ST_LABEL_TARGET))
2881 return false;
2882
2883 if (fp->unit->expr_type == EXPR_CONSTANT
2884 && fp->unit->ts.type == BT_INTEGER
2885 && mpz_sgn (fp->unit->value.integer) < 0)
2886 {
2887 gfc_error ("UNIT number in statement at %L must be non-negative",
2888 &fp->unit->where);
2889 return false;
2890 }
2891
2892 return true;
2893 }
2894
2895
2896 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2897 and the FLUSH statement. */
2898
2899 match
2900 gfc_match_endfile (void)
2901 {
2902 return match_filepos (ST_END_FILE, EXEC_ENDFILE);
2903 }
2904
2905 match
2906 gfc_match_backspace (void)
2907 {
2908 return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
2909 }
2910
2911 match
2912 gfc_match_rewind (void)
2913 {
2914 return match_filepos (ST_REWIND, EXEC_REWIND);
2915 }
2916
2917 match
2918 gfc_match_flush (void)
2919 {
2920 if (!gfc_notify_std (GFC_STD_F2003, "FLUSH statement at %C"))
2921 return MATCH_ERROR;
2922
2923 return match_filepos (ST_FLUSH, EXEC_FLUSH);
2924 }
2925
2926 /******************** Data Transfer Statements *********************/
2927
2928 /* Return a default unit number. */
2929
2930 static gfc_expr *
2931 default_unit (io_kind k)
2932 {
2933 int unit;
2934
2935 if (k == M_READ)
2936 unit = 5;
2937 else
2938 unit = 6;
2939
2940 return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit);
2941 }
2942
2943
2944 /* Match a unit specification for a data transfer statement. */
2945
2946 static match
2947 match_dt_unit (io_kind k, gfc_dt *dt)
2948 {
2949 gfc_expr *e;
2950 char c;
2951
2952 if (gfc_match_char ('*') == MATCH_YES)
2953 {
2954 if (dt->io_unit != NULL)
2955 goto conflict;
2956
2957 dt->io_unit = default_unit (k);
2958
2959 c = gfc_peek_ascii_char ();
2960 if (c == ')')
2961 gfc_error_now ("Missing format with default unit at %C");
2962
2963 return MATCH_YES;
2964 }
2965
2966 if (gfc_match_expr (&e) == MATCH_YES)
2967 {
2968 if (dt->io_unit != NULL)
2969 {
2970 gfc_free_expr (e);
2971 goto conflict;
2972 }
2973
2974 dt->io_unit = e;
2975 return MATCH_YES;
2976 }
2977
2978 return MATCH_NO;
2979
2980 conflict:
2981 gfc_error ("Duplicate UNIT specification at %C");
2982 return MATCH_ERROR;
2983 }
2984
2985
2986 /* Match a format specification. */
2987
2988 static match
2989 match_dt_format (gfc_dt *dt)
2990 {
2991 locus where;
2992 gfc_expr *e;
2993 gfc_st_label *label;
2994 match m;
2995
2996 where = gfc_current_locus;
2997
2998 if (gfc_match_char ('*') == MATCH_YES)
2999 {
3000 if (dt->format_expr != NULL || dt->format_label != NULL)
3001 goto conflict;
3002
3003 dt->format_label = &format_asterisk;
3004 return MATCH_YES;
3005 }
3006
3007 if ((m = gfc_match_st_label (&label)) == MATCH_YES)
3008 {
3009 char c;
3010
3011 /* Need to check if the format label is actually either an operand
3012 to a user-defined operator or is a kind type parameter. That is,
3013 print 2.ip.8 ! .ip. is a user-defined operator return CHARACTER.
3014 print 1_'(I0)', i ! 1_'(I0)' is a default character string. */
3015
3016 gfc_gobble_whitespace ();
3017 c = gfc_peek_ascii_char ();
3018 if (c == '.' || c == '_')
3019 gfc_current_locus = where;
3020 else
3021 {
3022 if (dt->format_expr != NULL || dt->format_label != NULL)
3023 {
3024 gfc_free_st_label (label);
3025 goto conflict;
3026 }
3027
3028 if (!gfc_reference_st_label (label, ST_LABEL_FORMAT))
3029 return MATCH_ERROR;
3030
3031 dt->format_label = label;
3032 return MATCH_YES;
3033 }
3034 }
3035 else if (m == MATCH_ERROR)
3036 /* The label was zero or too large. Emit the correct diagnosis. */
3037 return MATCH_ERROR;
3038
3039 if (gfc_match_expr (&e) == MATCH_YES)
3040 {
3041 if (dt->format_expr != NULL || dt->format_label != NULL)
3042 {
3043 gfc_free_expr (e);
3044 goto conflict;
3045 }
3046 dt->format_expr = e;
3047 return MATCH_YES;
3048 }
3049
3050 gfc_current_locus = where; /* The only case where we have to restore */
3051
3052 return MATCH_NO;
3053
3054 conflict:
3055 gfc_error ("Duplicate format specification at %C");
3056 return MATCH_ERROR;
3057 }
3058
3059 /* Check for formatted read and write DTIO procedures. */
3060
3061 static bool
3062 dtio_procs_present (gfc_symbol *sym, io_kind k)
3063 {
3064 gfc_symbol *derived;
3065
3066 if (sym && sym->ts.u.derived)
3067 {
3068 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
3069 derived = CLASS_DATA (sym)->ts.u.derived;
3070 else if (sym->ts.type == BT_DERIVED)
3071 derived = sym->ts.u.derived;
3072 else
3073 return false;
3074 if ((k == M_WRITE || k == M_PRINT) &&
3075 (gfc_find_specific_dtio_proc (derived, true, true) != NULL))
3076 return true;
3077 if ((k == M_READ) &&
3078 (gfc_find_specific_dtio_proc (derived, false, true) != NULL))
3079 return true;
3080 }
3081 return false;
3082 }
3083
3084 /* Traverse a namelist that is part of a READ statement to make sure
3085 that none of the variables in the namelist are INTENT(IN). Returns
3086 nonzero if we find such a variable. */
3087
3088 static int
3089 check_namelist (gfc_symbol *sym)
3090 {
3091 gfc_namelist *p;
3092
3093 for (p = sym->namelist; p; p = p->next)
3094 if (p->sym->attr.intent == INTENT_IN)
3095 {
3096 gfc_error ("Symbol %qs in namelist %qs is INTENT(IN) at %C",
3097 p->sym->name, sym->name);
3098 return 1;
3099 }
3100
3101 return 0;
3102 }
3103
3104
3105 /* Match a single data transfer element. */
3106
3107 static match
3108 match_dt_element (io_kind k, gfc_dt *dt)
3109 {
3110 char name[GFC_MAX_SYMBOL_LEN + 1];
3111 gfc_symbol *sym;
3112 match m;
3113
3114 if (gfc_match (" unit =") == MATCH_YES)
3115 {
3116 m = match_dt_unit (k, dt);
3117 if (m != MATCH_NO)
3118 return m;
3119 }
3120
3121 if (gfc_match (" fmt =") == MATCH_YES)
3122 {
3123 m = match_dt_format (dt);
3124 if (m != MATCH_NO)
3125 return m;
3126 }
3127
3128 if (gfc_match (" nml = %n", name) == MATCH_YES)
3129 {
3130 if (dt->namelist != NULL)
3131 {
3132 gfc_error ("Duplicate NML specification at %C");
3133 return MATCH_ERROR;
3134 }
3135
3136 if (gfc_find_symbol (name, NULL, 1, &sym))
3137 return MATCH_ERROR;
3138
3139 if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
3140 {
3141 gfc_error ("Symbol %qs at %C must be a NAMELIST group name",
3142 sym != NULL ? sym->name : name);
3143 return MATCH_ERROR;
3144 }
3145
3146 dt->namelist = sym;
3147 if (k == M_READ && check_namelist (sym))
3148 return MATCH_ERROR;
3149
3150 return MATCH_YES;
3151 }
3152
3153 m = match_etag (&tag_e_async, &dt->asynchronous);
3154 if (m != MATCH_NO)
3155 return m;
3156 m = match_etag (&tag_e_blank, &dt->blank);
3157 if (m != MATCH_NO)
3158 return m;
3159 m = match_etag (&tag_e_delim, &dt->delim);
3160 if (m != MATCH_NO)
3161 return m;
3162 m = match_etag (&tag_e_pad, &dt->pad);
3163 if (m != MATCH_NO)
3164 return m;
3165 m = match_etag (&tag_e_sign, &dt->sign);
3166 if (m != MATCH_NO)
3167 return m;
3168 m = match_etag (&tag_e_round, &dt->round);
3169 if (m != MATCH_NO)
3170 return m;
3171 m = match_out_tag (&tag_id, &dt->id);
3172 if (m != MATCH_NO)
3173 return m;
3174 m = match_etag (&tag_e_decimal, &dt->decimal);
3175 if (m != MATCH_NO)
3176 return m;
3177 m = match_etag (&tag_rec, &dt->rec);
3178 if (m != MATCH_NO)
3179 return m;
3180 m = match_etag (&tag_spos, &dt->pos);
3181 if (m != MATCH_NO)
3182 return m;
3183 m = match_etag (&tag_iomsg, &dt->iomsg);
3184 if (m != MATCH_NO)
3185 return m;
3186
3187 m = match_out_tag (&tag_iostat, &dt->iostat);
3188 if (m != MATCH_NO)
3189 return m;
3190 m = match_ltag (&tag_err, &dt->err);
3191 if (m == MATCH_YES)
3192 dt->err_where = gfc_current_locus;
3193 if (m != MATCH_NO)
3194 return m;
3195 m = match_etag (&tag_advance, &dt->advance);
3196 if (m != MATCH_NO)
3197 return m;
3198 m = match_out_tag (&tag_size, &dt->size);
3199 if (m != MATCH_NO)
3200 return m;
3201
3202 m = match_ltag (&tag_end, &dt->end);
3203 if (m == MATCH_YES)
3204 {
3205 if (k == M_WRITE)
3206 {
3207 gfc_error ("END tag at %C not allowed in output statement");
3208 return MATCH_ERROR;
3209 }
3210 dt->end_where = gfc_current_locus;
3211 }
3212 if (m != MATCH_NO)
3213 return m;
3214
3215 m = match_ltag (&tag_eor, &dt->eor);
3216 if (m == MATCH_YES)
3217 dt->eor_where = gfc_current_locus;
3218 if (m != MATCH_NO)
3219 return m;
3220
3221 return MATCH_NO;
3222 }
3223
3224
3225 /* Free a data transfer structure and everything below it. */
3226
3227 void
3228 gfc_free_dt (gfc_dt *dt)
3229 {
3230 if (dt == NULL)
3231 return;
3232
3233 gfc_free_expr (dt->io_unit);
3234 gfc_free_expr (dt->format_expr);
3235 gfc_free_expr (dt->rec);
3236 gfc_free_expr (dt->advance);
3237 gfc_free_expr (dt->iomsg);
3238 gfc_free_expr (dt->iostat);
3239 gfc_free_expr (dt->size);
3240 gfc_free_expr (dt->pad);
3241 gfc_free_expr (dt->delim);
3242 gfc_free_expr (dt->sign);
3243 gfc_free_expr (dt->round);
3244 gfc_free_expr (dt->blank);
3245 gfc_free_expr (dt->decimal);
3246 gfc_free_expr (dt->pos);
3247 gfc_free_expr (dt->dt_io_kind);
3248 /* dt->extra_comma is a link to dt_io_kind if it is set. */
3249 free (dt);
3250 }
3251
3252
3253 static const char *
3254 io_kind_name (io_kind k);
3255
3256 static bool
3257 check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
3258 locus *spec_end);
3259
3260 /* Resolve everything in a gfc_dt structure. */
3261
3262 bool
3263 gfc_resolve_dt (gfc_code *dt_code, gfc_dt *dt, locus *loc)
3264 {
3265 gfc_expr *e;
3266 io_kind k;
3267
3268 /* This is set in any case. */
3269 gcc_assert (dt->dt_io_kind);
3270 k = dt->dt_io_kind->value.iokind;
3271
3272 RESOLVE_TAG (&tag_format, dt->format_expr);
3273 RESOLVE_TAG (&tag_rec, dt->rec);
3274 RESOLVE_TAG (&tag_spos, dt->pos);
3275 RESOLVE_TAG (&tag_advance, dt->advance);
3276 RESOLVE_TAG (&tag_id, dt->id);
3277 RESOLVE_TAG (&tag_iomsg, dt->iomsg);
3278 RESOLVE_TAG (&tag_iostat, dt->iostat);
3279 RESOLVE_TAG (&tag_size, dt->size);
3280 RESOLVE_TAG (&tag_e_pad, dt->pad);
3281 RESOLVE_TAG (&tag_e_delim, dt->delim);
3282 RESOLVE_TAG (&tag_e_sign, dt->sign);
3283 RESOLVE_TAG (&tag_e_round, dt->round);
3284 RESOLVE_TAG (&tag_e_blank, dt->blank);
3285 RESOLVE_TAG (&tag_e_decimal, dt->decimal);
3286 RESOLVE_TAG (&tag_e_async, dt->asynchronous);
3287
3288 /* Check I/O constraints.
3289 To validate NAMELIST we need to check if we were also given an I/O list,
3290 which is stored in code->block->next with op EXEC_TRANSFER.
3291 Note that the I/O list was already resolved from resolve_transfer. */
3292 gfc_code *io_code = NULL;
3293 if (dt_code && dt_code->block && dt_code->block->next
3294 && dt_code->block->next->op == EXEC_TRANSFER)
3295 io_code = dt_code->block->next;
3296
3297 if (!check_io_constraints (k, dt, io_code, loc))
3298 return false;
3299
3300 e = dt->io_unit;
3301 if (e == NULL)
3302 {
3303 gfc_error ("UNIT not specified at %L", loc);
3304 return false;
3305 }
3306
3307 if (e->symtree && e->symtree->n.sym->attr.flavor == FL_PARAMETER
3308 && e->ts.type == BT_CHARACTER)
3309 {
3310 gfc_error ("UNIT specification at %L must "
3311 "not be a character PARAMETER", &e->where);
3312 return false;
3313 }
3314
3315 if (gfc_resolve_expr (e)
3316 && (e->ts.type != BT_INTEGER
3317 && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
3318 {
3319 /* If there is no extra comma signifying the "format" form of the IO
3320 statement, then this must be an error. */
3321 if (!dt->extra_comma)
3322 {
3323 gfc_error ("UNIT specification at %L must be an INTEGER expression "
3324 "or a CHARACTER variable", &e->where);
3325 return false;
3326 }
3327 else
3328 {
3329 /* At this point, we have an extra comma. If io_unit has arrived as
3330 type character, we assume its really the "format" form of the I/O
3331 statement. We set the io_unit to the default unit and format to
3332 the character expression. See F95 Standard section 9.4. */
3333 if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
3334 {
3335 dt->format_expr = dt->io_unit;
3336 dt->io_unit = default_unit (k);
3337
3338 /* Nullify this pointer now so that a warning/error is not
3339 triggered below for the "Extension". */
3340 dt->extra_comma = NULL;
3341 }
3342
3343 if (k == M_WRITE)
3344 {
3345 gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
3346 &dt->extra_comma->where);
3347 return false;
3348 }
3349 }
3350 }
3351
3352 if (e->ts.type == BT_CHARACTER)
3353 {
3354 if (gfc_has_vector_index (e))
3355 {
3356 gfc_error ("Internal unit with vector subscript at %L", &e->where);
3357 return false;
3358 }
3359
3360 /* If we are writing, make sure the internal unit can be changed. */
3361 gcc_assert (k != M_PRINT);
3362 if (k == M_WRITE
3363 && !gfc_check_vardef_context (e, false, false, false,
3364 _("internal unit in WRITE")))
3365 return false;
3366 }
3367
3368 if (e->rank && e->ts.type != BT_CHARACTER)
3369 {
3370 gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
3371 return false;
3372 }
3373
3374 if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER
3375 && mpz_sgn (e->value.integer) < 0)
3376 {
3377 gfc_error ("UNIT number in statement at %L must be non-negative",
3378 &e->where);
3379 return false;
3380 }
3381
3382 /* If we are reading and have a namelist, check that all namelist symbols
3383 can appear in a variable definition context. */
3384 if (dt->namelist)
3385 {
3386 gfc_namelist* n;
3387 for (n = dt->namelist->namelist; n; n = n->next)
3388 {
3389 gfc_expr* e;
3390 bool t;
3391
3392 if (k == M_READ)
3393 {
3394 e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
3395 t = gfc_check_vardef_context (e, false, false, false, NULL);
3396 gfc_free_expr (e);
3397
3398 if (!t)
3399 {
3400 gfc_error ("NAMELIST %qs in READ statement at %L contains"
3401 " the symbol %qs which may not appear in a"
3402 " variable definition context",
3403 dt->namelist->name, loc, n->sym->name);
3404 return false;
3405 }
3406 }
3407
3408 t = dtio_procs_present (n->sym, k);
3409
3410 if (n->sym->ts.type == BT_CLASS && !t)
3411 {
3412 gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
3413 "polymorphic and requires a defined input/output "
3414 "procedure", n->sym->name, dt->namelist->name, loc);
3415 return false;
3416 }
3417
3418 if ((n->sym->ts.type == BT_DERIVED)
3419 && (n->sym->ts.u.derived->attr.alloc_comp
3420 || n->sym->ts.u.derived->attr.pointer_comp))
3421 {
3422 if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
3423 "namelist %qs at %L with ALLOCATABLE "
3424 "or POINTER components", n->sym->name,
3425 dt->namelist->name, loc))
3426 return false;
3427
3428 if (!t)
3429 {
3430 gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
3431 "ALLOCATABLE or POINTER components and thus requires "
3432 "a defined input/output procedure", n->sym->name,
3433 dt->namelist->name, loc);
3434 return false;
3435 }
3436 }
3437 }
3438 }
3439
3440 if (dt->extra_comma
3441 && !gfc_notify_std (GFC_STD_LEGACY, "Comma before i/o item list at %L",
3442 &dt->extra_comma->where))
3443 return false;
3444
3445 if (dt->err)
3446 {
3447 if (!gfc_reference_st_label (dt->err, ST_LABEL_TARGET))
3448 return false;
3449 if (dt->err->defined == ST_LABEL_UNKNOWN)
3450 {
3451 gfc_error ("ERR tag label %d at %L not defined",
3452 dt->err->value, &dt->err_where);
3453 return false;
3454 }
3455 }
3456
3457 if (dt->end)
3458 {
3459 if (!gfc_reference_st_label (dt->end, ST_LABEL_TARGET))
3460 return false;
3461 if (dt->end->defined == ST_LABEL_UNKNOWN)
3462 {
3463 gfc_error ("END tag label %d at %L not defined",
3464 dt->end->value, &dt->end_where);
3465 return false;
3466 }
3467 }
3468
3469 if (dt->eor)
3470 {
3471 if (!gfc_reference_st_label (dt->eor, ST_LABEL_TARGET))
3472 return false;
3473 if (dt->eor->defined == ST_LABEL_UNKNOWN)
3474 {
3475 gfc_error ("EOR tag label %d at %L not defined",
3476 dt->eor->value, &dt->eor_where);
3477 return false;
3478 }
3479 }
3480
3481 /* Check the format label actually exists. */
3482 if (dt->format_label && dt->format_label != &format_asterisk
3483 && dt->format_label->defined == ST_LABEL_UNKNOWN)
3484 {
3485 gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
3486 loc);
3487 return false;
3488 }
3489
3490 return true;
3491 }
3492
3493
3494 /* Given an io_kind, return its name. */
3495
3496 static const char *
3497 io_kind_name (io_kind k)
3498 {
3499 const char *name;
3500
3501 switch (k)
3502 {
3503 case M_READ:
3504 name = "READ";
3505 break;
3506 case M_WRITE:
3507 name = "WRITE";
3508 break;
3509 case M_PRINT:
3510 name = "PRINT";
3511 break;
3512 case M_INQUIRE:
3513 name = "INQUIRE";
3514 break;
3515 default:
3516 gfc_internal_error ("io_kind_name(): bad I/O-kind");
3517 }
3518
3519 return name;
3520 }
3521
3522
3523 /* Match an IO iteration statement of the form:
3524
3525 ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
3526
3527 which is equivalent to a single IO element. This function is
3528 mutually recursive with match_io_element(). */
3529
3530 static match match_io_element (io_kind, gfc_code **);
3531
3532 static match
3533 match_io_iterator (io_kind k, gfc_code **result)
3534 {
3535 gfc_code *head, *tail, *new_code;
3536 gfc_iterator *iter;
3537 locus old_loc;
3538 match m;
3539 int n;
3540
3541 iter = NULL;
3542 head = NULL;
3543 old_loc = gfc_current_locus;
3544
3545 if (gfc_match_char ('(') != MATCH_YES)
3546 return MATCH_NO;
3547
3548 m = match_io_element (k, &head);
3549 tail = head;
3550
3551 if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
3552 {
3553 m = MATCH_NO;
3554 goto cleanup;
3555 }
3556
3557 /* Can't be anything but an IO iterator. Build a list. */
3558 iter = gfc_get_iterator ();
3559
3560 for (n = 1;; n++)
3561 {
3562 m = gfc_match_iterator (iter, 0);
3563 if (m == MATCH_ERROR)
3564 goto cleanup;
3565 if (m == MATCH_YES)
3566 {
3567 gfc_check_do_variable (iter->var->symtree);
3568 break;
3569 }
3570
3571 m = match_io_element (k, &new_code);
3572 if (m == MATCH_ERROR)
3573 goto cleanup;
3574 if (m == MATCH_NO)
3575 {
3576 if (n > 2)
3577 goto syntax;
3578 goto cleanup;
3579 }
3580
3581 tail = gfc_append_code (tail, new_code);
3582
3583 if (gfc_match_char (',') != MATCH_YES)
3584 {
3585 if (n > 2)
3586 goto syntax;
3587 m = MATCH_NO;
3588 goto cleanup;
3589 }
3590 }
3591
3592 if (gfc_match_char (')') != MATCH_YES)
3593 goto syntax;
3594
3595 new_code = gfc_get_code (EXEC_DO);
3596 new_code->ext.iterator = iter;
3597
3598 new_code->block = gfc_get_code (EXEC_DO);
3599 new_code->block->next = head;
3600
3601 *result = new_code;
3602 return MATCH_YES;
3603
3604 syntax:
3605 gfc_error ("Syntax error in I/O iterator at %C");
3606 m = MATCH_ERROR;
3607
3608 cleanup:
3609 gfc_free_iterator (iter, 1);
3610 gfc_free_statements (head);
3611 gfc_current_locus = old_loc;
3612 return m;
3613 }
3614
3615
3616 /* Match a single element of an IO list, which is either a single
3617 expression or an IO Iterator. */
3618
3619 static match
3620 match_io_element (io_kind k, gfc_code **cpp)
3621 {
3622 gfc_expr *expr;
3623 gfc_code *cp;
3624 match m;
3625
3626 expr = NULL;
3627
3628 m = match_io_iterator (k, cpp);
3629 if (m == MATCH_YES)
3630 return MATCH_YES;
3631
3632 if (k == M_READ)
3633 {
3634 m = gfc_match_variable (&expr, 0);
3635 if (m == MATCH_NO)
3636 {
3637 gfc_error ("Expecting variable in READ statement at %C");
3638 m = MATCH_ERROR;
3639 }
3640
3641 if (m == MATCH_YES && expr->expr_type == EXPR_CONSTANT)
3642 {
3643 gfc_error ("Expecting variable or io-implied-do in READ statement "
3644 "at %L", &expr->where);
3645 m = MATCH_ERROR;
3646 }
3647
3648 if (m == MATCH_YES
3649 && expr->expr_type == EXPR_VARIABLE
3650 && expr->symtree->n.sym->attr.external)
3651 {
3652 gfc_error ("Expecting variable or io-implied-do at %L",
3653 &expr->where);
3654 m = MATCH_ERROR;
3655 }
3656 }
3657 else
3658 {
3659 m = gfc_match_expr (&expr);
3660 if (m == MATCH_NO)
3661 gfc_error ("Expected expression in %s statement at %C",
3662 io_kind_name (k));
3663
3664 if (m == MATCH_YES && expr->ts.type == BT_BOZ)
3665 {
3666 if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in"
3667 " an output IO list"), &gfc_current_locus))
3668 return MATCH_ERROR;
3669 if (!gfc_boz2int (expr, gfc_max_integer_kind))
3670 return MATCH_ERROR;
3671 };
3672 }
3673
3674 if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree))
3675 m = MATCH_ERROR;
3676
3677 if (m != MATCH_YES)
3678 {
3679 gfc_free_expr (expr);
3680 return MATCH_ERROR;
3681 }
3682
3683 cp = gfc_get_code (EXEC_TRANSFER);
3684 cp->expr1 = expr;
3685 if (k != M_INQUIRE)
3686 cp->ext.dt = current_dt;
3687
3688 *cpp = cp;
3689 return MATCH_YES;
3690 }
3691
3692
3693 /* Match an I/O list, building gfc_code structures as we go. */
3694
3695 static match
3696 match_io_list (io_kind k, gfc_code **head_p)
3697 {
3698 gfc_code *head, *tail, *new_code;
3699 match m;
3700
3701 *head_p = head = tail = NULL;
3702 if (gfc_match_eos () == MATCH_YES)
3703 return MATCH_YES;
3704
3705 for (;;)
3706 {
3707 m = match_io_element (k, &new_code);
3708 if (m == MATCH_ERROR)
3709 goto cleanup;
3710 if (m == MATCH_NO)
3711 goto syntax;
3712
3713 tail = gfc_append_code (tail, new_code);
3714 if (head == NULL)
3715 head = new_code;
3716
3717 if (gfc_match_eos () == MATCH_YES)
3718 break;
3719 if (gfc_match_char (',') != MATCH_YES)
3720 goto syntax;
3721 }
3722
3723 *head_p = head;
3724 return MATCH_YES;
3725
3726 syntax:
3727 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3728
3729 cleanup:
3730 gfc_free_statements (head);
3731 return MATCH_ERROR;
3732 }
3733
3734
3735 /* Attach the data transfer end node. */
3736
3737 static void
3738 terminate_io (gfc_code *io_code)
3739 {
3740 gfc_code *c;
3741
3742 if (io_code == NULL)
3743 io_code = new_st.block;
3744
3745 c = gfc_get_code (EXEC_DT_END);
3746
3747 /* Point to structure that is already there */
3748 c->ext.dt = new_st.ext.dt;
3749 gfc_append_code (io_code, c);
3750 }
3751
3752
3753 /* Check the constraints for a data transfer statement. The majority of the
3754 constraints appearing in 9.4 of the standard appear here.
3755
3756 Tag expressions are already resolved by resolve_tag, which includes
3757 verifying the type, that they are scalar, and verifying that BT_CHARACTER
3758 tags are of default kind. */
3759
3760 static bool
3761 check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
3762 locus *spec_end)
3763 {
3764 #define io_constraint(condition, msg, arg)\
3765 if (condition) \
3766 {\
3767 if ((arg)->lb != NULL)\
3768 gfc_error ((msg), (arg));\
3769 else\
3770 gfc_error ((msg), spec_end);\
3771 return false;\
3772 }
3773
3774 gfc_expr *expr;
3775 gfc_symbol *sym = NULL;
3776 bool warn, unformatted;
3777
3778 warn = (dt->err || dt->iostat) ? true : false;
3779 unformatted = dt->format_expr == NULL && dt->format_label == NULL
3780 && dt->namelist == NULL;
3781
3782 expr = dt->io_unit;
3783 if (expr && expr->expr_type == EXPR_VARIABLE
3784 && expr->ts.type == BT_CHARACTER)
3785 {
3786 sym = expr->symtree->n.sym;
3787
3788 io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
3789 "Internal file at %L must not be INTENT(IN)",
3790 &expr->where);
3791
3792 io_constraint (gfc_has_vector_index (dt->io_unit),
3793 "Internal file incompatible with vector subscript at %L",
3794 &expr->where);
3795
3796 io_constraint (dt->rec != NULL,
3797 "REC tag at %L is incompatible with internal file",
3798 &dt->rec->where);
3799
3800 io_constraint (dt->pos != NULL,
3801 "POS tag at %L is incompatible with internal file",
3802 &dt->pos->where);
3803
3804 io_constraint (unformatted,
3805 "Unformatted I/O not allowed with internal unit at %L",
3806 &dt->io_unit->where);
3807
3808 io_constraint (dt->asynchronous != NULL,
3809 "ASYNCHRONOUS tag at %L not allowed with internal file",
3810 &dt->asynchronous->where);
3811
3812 if (dt->namelist != NULL)
3813 {
3814 if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with "
3815 "namelist", &expr->where))
3816 return false;
3817 }
3818
3819 io_constraint (dt->advance != NULL,
3820 "ADVANCE tag at %L is incompatible with internal file",
3821 &dt->advance->where);
3822 }
3823
3824 if (expr && expr->ts.type != BT_CHARACTER)
3825 {
3826
3827 if (gfc_pure (NULL) && (k == M_READ || k == M_WRITE))
3828 {
3829 gfc_error ("IO UNIT in %s statement at %L must be "
3830 "an internal file in a PURE procedure",
3831 io_kind_name (k), &expr->where);
3832 return false;
3833 }
3834
3835 if (k == M_READ || k == M_WRITE)
3836 gfc_unset_implicit_pure (NULL);
3837 }
3838
3839 if (dt->asynchronous)
3840 {
3841 int num = -1;
3842 static const char * asynchronous[] = { "YES", "NO", NULL };
3843
3844 /* Note: gfc_reduce_init_expr reports an error if not init-expr. */
3845 if (!gfc_reduce_init_expr (dt->asynchronous))
3846 return false;
3847
3848 if (!compare_to_allowed_values
3849 ("ASYNCHRONOUS", asynchronous, NULL, NULL,
3850 dt->asynchronous->value.character.string,
3851 io_kind_name (k), warn, &dt->asynchronous->where, &num))
3852 return false;
3853
3854 gcc_checking_assert (num != -1);
3855
3856 /* For "YES", mark related symbols as asynchronous. */
3857 if (num == 0)
3858 {
3859 /* SIZE variable. */
3860 if (dt->size)
3861 dt->size->symtree->n.sym->attr.asynchronous = 1;
3862
3863 /* Variables in a NAMELIST. */
3864 if (dt->namelist)
3865 for (gfc_namelist *nl = dt->namelist->namelist; nl; nl = nl->next)
3866 nl->sym->attr.asynchronous = 1;
3867
3868 /* Variables in an I/O list. */
3869 for (gfc_code *xfer = io_code; xfer && xfer->op == EXEC_TRANSFER;
3870 xfer = xfer->next)
3871 {
3872 gfc_expr *expr = xfer->expr1;
3873 while (expr != NULL && expr->expr_type == EXPR_OP
3874 && expr->value.op.op == INTRINSIC_PARENTHESES)
3875 expr = expr->value.op.op1;
3876
3877 if (expr && expr->expr_type == EXPR_VARIABLE)
3878 expr->symtree->n.sym->attr.asynchronous = 1;
3879 }
3880 }
3881 }
3882
3883 if (dt->id)
3884 {
3885 bool not_yes
3886 = !dt->asynchronous
3887 || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
3888 || gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
3889 "yes", 3) != 0;
3890 io_constraint (not_yes,
3891 "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3892 "specifier", &dt->id->where);
3893 }
3894
3895 if (dt->decimal)
3896 {
3897 if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L "
3898 "not allowed in Fortran 95", &dt->decimal->where))
3899 return false;
3900
3901 if (dt->decimal->expr_type == EXPR_CONSTANT)
3902 {
3903 static const char * decimal[] = { "COMMA", "POINT", NULL };
3904
3905 if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
3906 dt->decimal->value.character.string,
3907 io_kind_name (k), warn,
3908 &dt->decimal->where))
3909 return false;
3910
3911 io_constraint (unformatted,
3912 "the DECIMAL= specifier at %L must be with an "
3913 "explicit format expression", &dt->decimal->where);
3914 }
3915 }
3916
3917 if (dt->blank)
3918 {
3919 if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L "
3920 "not allowed in Fortran 95", &dt->blank->where))
3921 return false;
3922
3923 if (dt->blank->expr_type == EXPR_CONSTANT)
3924 {
3925 static const char * blank[] = { "NULL", "ZERO", NULL };
3926
3927
3928 if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
3929 dt->blank->value.character.string,
3930 io_kind_name (k), warn,
3931 &dt->blank->where))
3932 return false;
3933
3934 io_constraint (unformatted,
3935 "the BLANK= specifier at %L must be with an "
3936 "explicit format expression", &dt->blank->where);
3937 }
3938 }
3939
3940 if (dt->pad)
3941 {
3942 if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %L "
3943 "not allowed in Fortran 95", &dt->pad->where))
3944 return false;
3945
3946 if (dt->pad->expr_type == EXPR_CONSTANT)
3947 {
3948 static const char * pad[] = { "YES", "NO", NULL };
3949
3950 if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
3951 dt->pad->value.character.string,
3952 io_kind_name (k), warn,
3953 &dt->pad->where))
3954 return false;
3955
3956 io_constraint (unformatted,
3957 "the PAD= specifier at %L must be with an "
3958 "explicit format expression", &dt->pad->where);
3959 }
3960 }
3961
3962 if (dt->round)
3963 {
3964 if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L "
3965 "not allowed in Fortran 95", &dt->round->where))
3966 return false;
3967
3968 if (dt->round->expr_type == EXPR_CONSTANT)
3969 {
3970 static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
3971 "COMPATIBLE", "PROCESSOR_DEFINED",
3972 NULL };
3973
3974 if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
3975 dt->round->value.character.string,
3976 io_kind_name (k), warn,
3977 &dt->round->where))
3978 return false;
3979 }
3980 }
3981
3982 if (dt->sign)
3983 {
3984 /* When implemented, change the following to use gfc_notify_std F2003.
3985 if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %L "
3986 "not allowed in Fortran 95", &dt->sign->where) == false)
3987 return false; */
3988
3989 if (dt->sign->expr_type == EXPR_CONSTANT)
3990 {
3991 static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3992 NULL };
3993
3994 if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
3995 dt->sign->value.character.string,
3996 io_kind_name (k), warn, &dt->sign->where))
3997 return false;
3998
3999 io_constraint (unformatted,
4000 "SIGN= specifier at %L must be with an "
4001 "explicit format expression", &dt->sign->where);
4002
4003 io_constraint (k == M_READ,
4004 "SIGN= specifier at %L not allowed in a "
4005 "READ statement", &dt->sign->where);
4006 }
4007 }
4008
4009 if (dt->delim)
4010 {
4011 if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %L "
4012 "not allowed in Fortran 95", &dt->delim->where))
4013 return false;
4014
4015 if (dt->delim->expr_type == EXPR_CONSTANT)
4016 {
4017 static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
4018
4019 if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
4020 dt->delim->value.character.string,
4021 io_kind_name (k), warn,
4022 &dt->delim->where))
4023 return false;
4024
4025 io_constraint (k == M_READ,
4026 "DELIM= specifier at %L not allowed in a "
4027 "READ statement", &dt->delim->where);
4028
4029 io_constraint (dt->format_label != &format_asterisk
4030 && dt->namelist == NULL,
4031 "DELIM= specifier at %L must have FMT=*",
4032 &dt->delim->where);
4033
4034 io_constraint (unformatted && dt->namelist == NULL,
4035 "DELIM= specifier at %L must be with FMT=* or "
4036 "NML= specifier", &dt->delim->where);
4037 }
4038 }
4039
4040 if (dt->namelist)
4041 {
4042 io_constraint (io_code && dt->namelist,
4043 "NAMELIST cannot be followed by IO-list at %L",
4044 &io_code->loc);
4045
4046 io_constraint (dt->format_expr,
4047 "IO spec-list cannot contain both NAMELIST group name "
4048 "and format specification at %L",
4049 &dt->format_expr->where);
4050
4051 io_constraint (dt->format_label,
4052 "IO spec-list cannot contain both NAMELIST group name "
4053 "and format label at %L", spec_end);
4054
4055 io_constraint (dt->rec,
4056 "NAMELIST IO is not allowed with a REC= specifier "
4057 "at %L", &dt->rec->where);
4058
4059 io_constraint (dt->advance,
4060 "NAMELIST IO is not allowed with a ADVANCE= specifier "
4061 "at %L", &dt->advance->where);
4062 }
4063
4064 if (dt->rec)
4065 {
4066 io_constraint (dt->end,
4067 "An END tag is not allowed with a "
4068 "REC= specifier at %L", &dt->end_where);
4069
4070 io_constraint (dt->format_label == &format_asterisk,
4071 "FMT=* is not allowed with a REC= specifier "
4072 "at %L", spec_end);
4073
4074 io_constraint (dt->pos,
4075 "POS= is not allowed with REC= specifier "
4076 "at %L", &dt->pos->where);
4077 }
4078
4079 if (dt->advance)
4080 {
4081 int not_yes, not_no;
4082 expr = dt->advance;
4083
4084 io_constraint (dt->format_label == &format_asterisk,
4085 "List directed format(*) is not allowed with a "
4086 "ADVANCE= specifier at %L.", &expr->where);
4087
4088 io_constraint (unformatted,
4089 "the ADVANCE= specifier at %L must appear with an "
4090 "explicit format expression", &expr->where);
4091
4092 if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
4093 {
4094 const gfc_char_t *advance = expr->value.character.string;
4095 not_no = gfc_wide_strlen (advance) != 2
4096 || gfc_wide_strncasecmp (advance, "no", 2) != 0;
4097 not_yes = gfc_wide_strlen (advance) != 3
4098 || gfc_wide_strncasecmp (advance, "yes", 3) != 0;
4099 }
4100 else
4101 {
4102 not_no = 0;
4103 not_yes = 0;
4104 }
4105
4106 io_constraint (not_no && not_yes,
4107 "ADVANCE= specifier at %L must have value = "
4108 "YES or NO.", &expr->where);
4109
4110 io_constraint (dt->size && not_no && k == M_READ,
4111 "SIZE tag at %L requires an ADVANCE = %<NO%>",
4112 &dt->size->where);
4113
4114 io_constraint (dt->eor && not_no && k == M_READ,
4115 "EOR tag at %L requires an ADVANCE = %<NO%>",
4116 &dt->eor_where);
4117 }
4118
4119 if (k != M_READ)
4120 {
4121 io_constraint (dt->end, "END tag not allowed with output at %L",
4122 &dt->end_where);
4123
4124 io_constraint (dt->eor, "EOR tag not allowed with output at %L",
4125 &dt->eor_where);
4126
4127 io_constraint (dt->blank,
4128 "BLANK= specifier not allowed with output at %L",
4129 &dt->blank->where);
4130
4131 io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
4132 &dt->pad->where);
4133
4134 io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
4135 &dt->size->where);
4136 }
4137 else
4138 {
4139 io_constraint (dt->size && dt->advance == NULL,
4140 "SIZE tag at %L requires an ADVANCE tag",
4141 &dt->size->where);
4142
4143 io_constraint (dt->eor && dt->advance == NULL,
4144 "EOR tag at %L requires an ADVANCE tag",
4145 &dt->eor_where);
4146 }
4147
4148 return true;
4149 #undef io_constraint
4150 }
4151
4152
4153 /* Match a READ, WRITE or PRINT statement. */
4154
4155 static match
4156 match_io (io_kind k)
4157 {
4158 char name[GFC_MAX_SYMBOL_LEN + 1];
4159 gfc_code *io_code;
4160 gfc_symbol *sym;
4161 int comma_flag;
4162 locus where;
4163 locus control;
4164 gfc_dt *dt;
4165 match m;
4166
4167 where = gfc_current_locus;
4168 comma_flag = 0;
4169 current_dt = dt = XCNEW (gfc_dt);
4170 m = gfc_match_char ('(');
4171 if (m == MATCH_NO)
4172 {
4173 where = gfc_current_locus;
4174 if (k == M_WRITE)
4175 goto syntax;
4176 else if (k == M_PRINT)
4177 {
4178 /* Treat the non-standard case of PRINT namelist. */
4179 if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
4180 && gfc_match_name (name) == MATCH_YES)
4181 {
4182 gfc_find_symbol (name, NULL, 1, &sym);
4183 if (sym && sym->attr.flavor == FL_NAMELIST)
4184 {
4185 if (!gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
4186 "%C is an extension"))
4187 {
4188 m = MATCH_ERROR;
4189 goto cleanup;
4190 }
4191
4192 dt->io_unit = default_unit (k);
4193 dt->namelist = sym;
4194 goto get_io_list;
4195 }
4196 else
4197 gfc_current_locus = where;
4198 }
4199
4200 if (gfc_match_char ('*') == MATCH_YES
4201 && gfc_match_char(',') == MATCH_YES)
4202 {
4203 locus where2 = gfc_current_locus;
4204 if (gfc_match_eos () == MATCH_YES)
4205 {
4206 gfc_current_locus = where2;
4207 gfc_error ("Comma after * at %C not allowed without I/O list");
4208 m = MATCH_ERROR;
4209 goto cleanup;
4210 }
4211 else
4212 gfc_current_locus = where;
4213 }
4214 else
4215 gfc_current_locus = where;
4216 }
4217
4218 if (gfc_current_form == FORM_FREE)
4219 {
4220 char c = gfc_peek_ascii_char ();
4221 if (c != ' ' && c != '*' && c != '\'' && c != '"')
4222 {
4223 m = MATCH_NO;
4224 goto cleanup;
4225 }
4226 }
4227
4228 m = match_dt_format (dt);
4229 if (m == MATCH_ERROR)
4230 goto cleanup;
4231 if (m == MATCH_NO)
4232 goto syntax;
4233
4234 comma_flag = 1;
4235 dt->io_unit = default_unit (k);
4236 goto get_io_list;
4237 }
4238 else
4239 {
4240 /* Before issuing an error for a malformed 'print (1,*)' type of
4241 error, check for a default-char-expr of the form ('(I0)'). */
4242 if (m == MATCH_YES)
4243 {
4244 control = gfc_current_locus;
4245 if (k == M_PRINT)
4246 {
4247 /* Reset current locus to get the initial '(' in an expression. */
4248 gfc_current_locus = where;
4249 dt->format_expr = NULL;
4250 m = match_dt_format (dt);
4251
4252 if (m == MATCH_ERROR)
4253 goto cleanup;
4254 if (m == MATCH_NO || dt->format_expr == NULL)
4255 goto syntax;
4256
4257 comma_flag = 1;
4258 dt->io_unit = default_unit (k);
4259 goto get_io_list;
4260 }
4261 if (k == M_READ)
4262 {
4263 /* Commit any pending symbols now so that when we undo
4264 symbols later we wont lose them. */
4265 gfc_commit_symbols ();
4266 /* Reset current locus to get the initial '(' in an expression. */
4267 gfc_current_locus = where;
4268 dt->format_expr = NULL;
4269 m = gfc_match_expr (&dt->format_expr);
4270 if (m == MATCH_YES)
4271 {
4272 if (dt->format_expr
4273 && dt->format_expr->ts.type == BT_CHARACTER)
4274 {
4275 comma_flag = 1;
4276 dt->io_unit = default_unit (k);
4277 goto get_io_list;
4278 }
4279 else
4280 {
4281 gfc_free_expr (dt->format_expr);
4282 dt->format_expr = NULL;
4283 gfc_current_locus = control;
4284 }
4285 }
4286 else
4287 {
4288 gfc_clear_error ();
4289 gfc_undo_symbols ();
4290 gfc_free_expr (dt->format_expr);
4291 dt->format_expr = NULL;
4292 gfc_current_locus = control;
4293 }
4294 }
4295 }
4296 }
4297
4298 /* Match a control list */
4299 if (match_dt_element (k, dt) == MATCH_YES)
4300 goto next;
4301 if (match_dt_unit (k, dt) != MATCH_YES)
4302 goto loop;
4303
4304 if (gfc_match_char (')') == MATCH_YES)
4305 goto get_io_list;
4306 if (gfc_match_char (',') != MATCH_YES)
4307 goto syntax;
4308
4309 m = match_dt_element (k, dt);
4310 if (m == MATCH_YES)
4311 goto next;
4312 if (m == MATCH_ERROR)
4313 goto cleanup;
4314
4315 m = match_dt_format (dt);
4316 if (m == MATCH_YES)
4317 goto next;
4318 if (m == MATCH_ERROR)
4319 goto cleanup;
4320
4321 where = gfc_current_locus;
4322
4323 m = gfc_match_name (name);
4324 if (m == MATCH_YES)
4325 {
4326 gfc_find_symbol (name, NULL, 1, &sym);
4327 if (sym && sym->attr.flavor == FL_NAMELIST)
4328 {
4329 dt->namelist = sym;
4330 if (k == M_READ && check_namelist (sym))
4331 {
4332 m = MATCH_ERROR;
4333 goto cleanup;
4334 }
4335 goto next;
4336 }
4337 }
4338
4339 gfc_current_locus = where;
4340
4341 goto loop; /* No matches, try regular elements */
4342
4343 next:
4344 if (gfc_match_char (')') == MATCH_YES)
4345 goto get_io_list;
4346 if (gfc_match_char (',') != MATCH_YES)
4347 goto syntax;
4348
4349 loop:
4350 for (;;)
4351 {
4352 m = match_dt_element (k, dt);
4353 if (m == MATCH_NO)
4354 goto syntax;
4355 if (m == MATCH_ERROR)
4356 goto cleanup;
4357
4358 if (gfc_match_char (')') == MATCH_YES)
4359 break;
4360 if (gfc_match_char (',') != MATCH_YES)
4361 goto syntax;
4362 }
4363
4364 get_io_list:
4365
4366 /* Save the IO kind for later use. */
4367 dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k);
4368
4369 /* Optional leading comma (non-standard). We use a gfc_expr structure here
4370 to save the locus. This is used later when resolving transfer statements
4371 that might have a format expression without unit number. */
4372 if (!comma_flag && gfc_match_char (',') == MATCH_YES)
4373 dt->extra_comma = dt->dt_io_kind;
4374
4375 io_code = NULL;
4376 if (gfc_match_eos () != MATCH_YES)
4377 {
4378 if (comma_flag && gfc_match_char (',') != MATCH_YES)
4379 {
4380 gfc_error ("Expected comma in I/O list at %C");
4381 m = MATCH_ERROR;
4382 goto cleanup;
4383 }
4384
4385 m = match_io_list (k, &io_code);
4386 if (m == MATCH_ERROR)
4387 goto cleanup;
4388 if (m == MATCH_NO)
4389 goto syntax;
4390 }
4391
4392 /* See if we want to use defaults for missing exponents in real transfers
4393 and other DEC runtime extensions. */
4394 if (flag_dec_format_defaults)
4395 dt->dec_ext = 1;
4396
4397 /* Check the format string now. */
4398 if (dt->format_expr
4399 && (!gfc_simplify_expr (dt->format_expr, 0)
4400 || !check_format_string (dt->format_expr, k == M_READ)))
4401 return MATCH_ERROR;
4402
4403 new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
4404 new_st.ext.dt = dt;
4405 new_st.block = gfc_get_code (new_st.op);
4406 new_st.block->next = io_code;
4407
4408 terminate_io (io_code);
4409
4410 return MATCH_YES;
4411
4412 syntax:
4413 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
4414 m = MATCH_ERROR;
4415
4416 cleanup:
4417 gfc_free_dt (dt);
4418 return m;
4419 }
4420
4421
4422 match
4423 gfc_match_read (void)
4424 {
4425 return match_io (M_READ);
4426 }
4427
4428
4429 match
4430 gfc_match_write (void)
4431 {
4432 return match_io (M_WRITE);
4433 }
4434
4435
4436 match
4437 gfc_match_print (void)
4438 {
4439 match m;
4440
4441 m = match_io (M_PRINT);
4442 if (m != MATCH_YES)
4443 return m;
4444
4445 if (gfc_pure (NULL))
4446 {
4447 gfc_error ("PRINT statement at %C not allowed within PURE procedure");
4448 return MATCH_ERROR;
4449 }
4450
4451 gfc_unset_implicit_pure (NULL);
4452
4453 return MATCH_YES;
4454 }
4455
4456
4457 /* Free a gfc_inquire structure. */
4458
4459 void
4460 gfc_free_inquire (gfc_inquire *inquire)
4461 {
4462
4463 if (inquire == NULL)
4464 return;
4465
4466 gfc_free_expr (inquire->unit);
4467 gfc_free_expr (inquire->file);
4468 gfc_free_expr (inquire->iomsg);
4469 gfc_free_expr (inquire->iostat);
4470 gfc_free_expr (inquire->exist);
4471 gfc_free_expr (inquire->opened);
4472 gfc_free_expr (inquire->number);
4473 gfc_free_expr (inquire->named);
4474 gfc_free_expr (inquire->name);
4475 gfc_free_expr (inquire->access);
4476 gfc_free_expr (inquire->sequential);
4477 gfc_free_expr (inquire->direct);
4478 gfc_free_expr (inquire->form);
4479 gfc_free_expr (inquire->formatted);
4480 gfc_free_expr (inquire->unformatted);
4481 gfc_free_expr (inquire->recl);
4482 gfc_free_expr (inquire->nextrec);
4483 gfc_free_expr (inquire->blank);
4484 gfc_free_expr (inquire->position);
4485 gfc_free_expr (inquire->action);
4486 gfc_free_expr (inquire->read);
4487 gfc_free_expr (inquire->write);
4488 gfc_free_expr (inquire->readwrite);
4489 gfc_free_expr (inquire->delim);
4490 gfc_free_expr (inquire->encoding);
4491 gfc_free_expr (inquire->pad);
4492 gfc_free_expr (inquire->iolength);
4493 gfc_free_expr (inquire->convert);
4494 gfc_free_expr (inquire->strm_pos);
4495 gfc_free_expr (inquire->asynchronous);
4496 gfc_free_expr (inquire->decimal);
4497 gfc_free_expr (inquire->pending);
4498 gfc_free_expr (inquire->id);
4499 gfc_free_expr (inquire->sign);
4500 gfc_free_expr (inquire->size);
4501 gfc_free_expr (inquire->round);
4502 gfc_free_expr (inquire->share);
4503 gfc_free_expr (inquire->cc);
4504 free (inquire);
4505 }
4506
4507
4508 /* Match an element of an INQUIRE statement. */
4509
4510 #define RETM if (m != MATCH_NO) return m;
4511
4512 static match
4513 match_inquire_element (gfc_inquire *inquire)
4514 {
4515 match m;
4516
4517 m = match_etag (&tag_unit, &inquire->unit);
4518 RETM m = match_etag (&tag_file, &inquire->file);
4519 RETM m = match_ltag (&tag_err, &inquire->err);
4520 RETM m = match_etag (&tag_iomsg, &inquire->iomsg);
4521 RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
4522 RETM m = match_vtag (&tag_exist, &inquire->exist);
4523 RETM m = match_vtag (&tag_opened, &inquire->opened);
4524 RETM m = match_vtag (&tag_named, &inquire->named);
4525 RETM m = match_vtag (&tag_name, &inquire->name);
4526 RETM m = match_out_tag (&tag_number, &inquire->number);
4527 RETM m = match_vtag (&tag_s_access, &inquire->access);
4528 RETM m = match_vtag (&tag_sequential, &inquire->sequential);
4529 RETM m = match_vtag (&tag_direct, &inquire->direct);
4530 RETM m = match_vtag (&tag_s_form, &inquire->form);
4531 RETM m = match_vtag (&tag_formatted, &inquire->formatted);
4532 RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
4533 RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
4534 RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
4535 RETM m = match_vtag (&tag_s_blank, &inquire->blank);
4536 RETM m = match_vtag (&tag_s_position, &inquire->position);
4537 RETM m = match_vtag (&tag_s_action, &inquire->action);
4538 RETM m = match_vtag (&tag_read, &inquire->read);
4539 RETM m = match_vtag (&tag_write, &inquire->write);
4540 RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
4541 RETM m = match_vtag (&tag_s_async, &inquire->asynchronous);
4542 RETM m = match_vtag (&tag_s_delim, &inquire->delim);
4543 RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
4544 RETM m = match_out_tag (&tag_size, &inquire->size);
4545 RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
4546 RETM m = match_vtag (&tag_s_round, &inquire->round);
4547 RETM m = match_vtag (&tag_s_sign, &inquire->sign);
4548 RETM m = match_vtag (&tag_s_pad, &inquire->pad);
4549 RETM m = match_out_tag (&tag_iolength, &inquire->iolength);
4550 RETM m = match_vtag (&tag_convert, &inquire->convert);
4551 RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
4552 RETM m = match_vtag (&tag_pending, &inquire->pending);
4553 RETM m = match_vtag (&tag_id, &inquire->id);
4554 RETM m = match_vtag (&tag_s_iqstream, &inquire->iqstream);
4555 RETM m = match_dec_vtag (&tag_v_share, &inquire->share);
4556 RETM m = match_dec_vtag (&tag_v_cc, &inquire->cc);
4557 RETM return MATCH_NO;
4558 }
4559
4560 #undef RETM
4561
4562
4563 match
4564 gfc_match_inquire (void)
4565 {
4566 gfc_inquire *inquire;
4567 gfc_code *code;
4568 match m;
4569 locus loc;
4570
4571 m = gfc_match_char ('(');
4572 if (m == MATCH_NO)
4573 return m;
4574
4575 inquire = XCNEW (gfc_inquire);
4576
4577 loc = gfc_current_locus;
4578
4579 m = match_inquire_element (inquire);
4580 if (m == MATCH_ERROR)
4581 goto cleanup;
4582 if (m == MATCH_NO)
4583 {
4584 m = gfc_match_expr (&inquire->unit);
4585 if (m == MATCH_ERROR)
4586 goto cleanup;
4587 if (m == MATCH_NO)
4588 goto syntax;
4589 }
4590
4591 /* See if we have the IOLENGTH form of the inquire statement. */
4592 if (inquire->iolength != NULL)
4593 {
4594 if (gfc_match_char (')') != MATCH_YES)
4595 goto syntax;
4596
4597 m = match_io_list (M_INQUIRE, &code);
4598 if (m == MATCH_ERROR)
4599 goto cleanup;
4600 if (m == MATCH_NO)
4601 goto syntax;
4602
4603 for (gfc_code *c = code; c; c = c->next)
4604 if (c->expr1 && c->expr1->expr_type == EXPR_FUNCTION
4605 && c->expr1->symtree && c->expr1->symtree->n.sym->attr.function
4606 && !c->expr1->symtree->n.sym->attr.external
4607 && strcmp (c->expr1->symtree->name, "null") == 0)
4608 {
4609 gfc_error ("NULL() near %L cannot appear in INQUIRE statement",
4610 &c->expr1->where);
4611 goto cleanup;
4612 }
4613
4614 new_st.op = EXEC_IOLENGTH;
4615 new_st.expr1 = inquire->iolength;
4616 new_st.ext.inquire = inquire;
4617
4618 if (gfc_pure (NULL))
4619 {
4620 gfc_free_statements (code);
4621 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4622 return MATCH_ERROR;
4623 }
4624
4625 gfc_unset_implicit_pure (NULL);
4626
4627 new_st.block = gfc_get_code (EXEC_IOLENGTH);
4628 terminate_io (code);
4629 new_st.block->next = code;
4630 return MATCH_YES;
4631 }
4632
4633 /* At this point, we have the non-IOLENGTH inquire statement. */
4634 for (;;)
4635 {
4636 if (gfc_match_char (')') == MATCH_YES)
4637 break;
4638 if (gfc_match_char (',') != MATCH_YES)
4639 goto syntax;
4640
4641 m = match_inquire_element (inquire);
4642 if (m == MATCH_ERROR)
4643 goto cleanup;
4644 if (m == MATCH_NO)
4645 goto syntax;
4646
4647 if (inquire->iolength != NULL)
4648 {
4649 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
4650 goto cleanup;
4651 }
4652 }
4653
4654 if (gfc_match_eos () != MATCH_YES)
4655 goto syntax;
4656
4657 if (inquire->unit != NULL && inquire->file != NULL)
4658 {
4659 gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
4660 "UNIT specifiers", &loc);
4661 goto cleanup;
4662 }
4663
4664 if (inquire->unit == NULL && inquire->file == NULL)
4665 {
4666 gfc_error ("INQUIRE statement at %L requires either FILE or "
4667 "UNIT specifier", &loc);
4668 goto cleanup;
4669 }
4670
4671 if (inquire->unit != NULL && inquire->unit->expr_type == EXPR_CONSTANT
4672 && inquire->unit->ts.type == BT_INTEGER
4673 && ((mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT4)
4674 || (mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT)))
4675 {
4676 gfc_error ("UNIT number in INQUIRE statement at %L cannot "
4677 "be %d", &loc, (int) mpz_get_si (inquire->unit->value.integer));
4678 goto cleanup;
4679 }
4680
4681 if (gfc_pure (NULL))
4682 {
4683 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4684 goto cleanup;
4685 }
4686
4687 gfc_unset_implicit_pure (NULL);
4688
4689 if (inquire->id != NULL && inquire->pending == NULL)
4690 {
4691 gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
4692 "the ID= specifier", &loc);
4693 goto cleanup;
4694 }
4695
4696 new_st.op = EXEC_INQUIRE;
4697 new_st.ext.inquire = inquire;
4698 return MATCH_YES;
4699
4700 syntax:
4701 gfc_syntax_error (ST_INQUIRE);
4702
4703 cleanup:
4704 gfc_free_inquire (inquire);
4705 return MATCH_ERROR;
4706 }
4707
4708
4709 /* Resolve everything in a gfc_inquire structure. */
4710
4711 bool
4712 gfc_resolve_inquire (gfc_inquire *inquire)
4713 {
4714 RESOLVE_TAG (&tag_unit, inquire->unit);
4715 RESOLVE_TAG (&tag_file, inquire->file);
4716 RESOLVE_TAG (&tag_id, inquire->id);
4717
4718 /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4719 contexts. Thus, use an extended RESOLVE_TAG macro for that. */
4720 #define INQUIRE_RESOLVE_TAG(tag, expr) \
4721 RESOLVE_TAG (tag, expr); \
4722 if (expr) \
4723 { \
4724 char context[64]; \
4725 sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
4726 if (gfc_check_vardef_context ((expr), false, false, false, \
4727 context) == false) \
4728 return false; \
4729 }
4730 INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
4731 INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat);
4732 INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist);
4733 INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened);
4734 INQUIRE_RESOLVE_TAG (&tag_number, inquire->number);
4735 INQUIRE_RESOLVE_TAG (&tag_named, inquire->named);
4736 INQUIRE_RESOLVE_TAG (&tag_name, inquire->name);
4737 INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access);
4738 INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential);
4739 INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct);
4740 INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form);
4741 INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted);
4742 INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
4743 INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl);
4744 INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
4745 INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank);
4746 INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position);
4747 INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action);
4748 INQUIRE_RESOLVE_TAG (&tag_read, inquire->read);
4749 INQUIRE_RESOLVE_TAG (&tag_write, inquire->write);
4750 INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
4751 INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim);
4752 INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad);
4753 INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
4754 INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4755 INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength);
4756 INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert);
4757 INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
4758 INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
4759 INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign);
4760 INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4761 INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending);
4762 INQUIRE_RESOLVE_TAG (&tag_size, inquire->size);
4763 INQUIRE_RESOLVE_TAG (&tag_s_decimal, inquire->decimal);
4764 INQUIRE_RESOLVE_TAG (&tag_s_iqstream, inquire->iqstream);
4765 INQUIRE_RESOLVE_TAG (&tag_v_share, inquire->share);
4766 INQUIRE_RESOLVE_TAG (&tag_v_cc, inquire->cc);
4767 #undef INQUIRE_RESOLVE_TAG
4768
4769 if (!gfc_reference_st_label (inquire->err, ST_LABEL_TARGET))
4770 return false;
4771
4772 return true;
4773 }
4774
4775
4776 void
4777 gfc_free_wait (gfc_wait *wait)
4778 {
4779 if (wait == NULL)
4780 return;
4781
4782 gfc_free_expr (wait->unit);
4783 gfc_free_expr (wait->iostat);
4784 gfc_free_expr (wait->iomsg);
4785 gfc_free_expr (wait->id);
4786 free (wait);
4787 }
4788
4789
4790 bool
4791 gfc_resolve_wait (gfc_wait *wait)
4792 {
4793 RESOLVE_TAG (&tag_unit, wait->unit);
4794 RESOLVE_TAG (&tag_iomsg, wait->iomsg);
4795 RESOLVE_TAG (&tag_iostat, wait->iostat);
4796 RESOLVE_TAG (&tag_id, wait->id);
4797
4798 if (!gfc_reference_st_label (wait->err, ST_LABEL_TARGET))
4799 return false;
4800
4801 if (!gfc_reference_st_label (wait->end, ST_LABEL_TARGET))
4802 return false;
4803
4804 return true;
4805 }
4806
4807 /* Match an element of a WAIT statement. */
4808
4809 #define RETM if (m != MATCH_NO) return m;
4810
4811 static match
4812 match_wait_element (gfc_wait *wait)
4813 {
4814 match m;
4815
4816 m = match_etag (&tag_unit, &wait->unit);
4817 RETM m = match_ltag (&tag_err, &wait->err);
4818 RETM m = match_ltag (&tag_end, &wait->end);
4819 RETM m = match_ltag (&tag_eor, &wait->eor);
4820 RETM m = match_etag (&tag_iomsg, &wait->iomsg);
4821 RETM m = match_out_tag (&tag_iostat, &wait->iostat);
4822 RETM m = match_etag (&tag_id, &wait->id);
4823 RETM return MATCH_NO;
4824 }
4825
4826 #undef RETM
4827
4828
4829 match
4830 gfc_match_wait (void)
4831 {
4832 gfc_wait *wait;
4833 match m;
4834
4835 m = gfc_match_char ('(');
4836 if (m == MATCH_NO)
4837 return m;
4838
4839 wait = XCNEW (gfc_wait);
4840
4841 m = match_wait_element (wait);
4842 if (m == MATCH_ERROR)
4843 goto cleanup;
4844 if (m == MATCH_NO)
4845 {
4846 m = gfc_match_expr (&wait->unit);
4847 if (m == MATCH_ERROR)
4848 goto cleanup;
4849 if (m == MATCH_NO)
4850 goto syntax;
4851 }
4852
4853 for (;;)
4854 {
4855 if (gfc_match_char (')') == MATCH_YES)
4856 break;
4857 if (gfc_match_char (',') != MATCH_YES)
4858 goto syntax;
4859
4860 m = match_wait_element (wait);
4861 if (m == MATCH_ERROR)
4862 goto cleanup;
4863 if (m == MATCH_NO)
4864 goto syntax;
4865 }
4866
4867 if (!gfc_notify_std (GFC_STD_F2003, "WAIT at %C "
4868 "not allowed in Fortran 95"))
4869 goto cleanup;
4870
4871 if (gfc_pure (NULL))
4872 {
4873 gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4874 goto cleanup;
4875 }
4876
4877 gfc_unset_implicit_pure (NULL);
4878
4879 new_st.op = EXEC_WAIT;
4880 new_st.ext.wait = wait;
4881
4882 return MATCH_YES;
4883
4884 syntax:
4885 gfc_syntax_error (ST_WAIT);
4886
4887 cleanup:
4888 gfc_free_wait (wait);
4889 return MATCH_ERROR;
4890 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org