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