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