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