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