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