?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2011-04-04 Tobias Burnus <burnus@net-b.de>
[official-gcc.git] / gcc / fortran / io.c
blob3ce7e816b9a04007f0374393bf29c718133193c7
1 /* Deal with I/O statements & related stuff.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
3 2009, 2010, 2011
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 (gfc_instring 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 (NONSTRING);
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 (INSTRING_WARN);
378 if (c == '\0')
379 {
380 token = FMT_END;
381 break;
382 }
383
384 if (c == delim)
385 {
386 c = next_char (INSTRING_NOWARN);
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 (INSTRING_WARN);
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 if (gfc_implicit_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
1319 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1320
1321 *v = result;
1322 return MATCH_YES;
1323 }
1324
1325
1326 /* Match I/O tags that cause variables to become redefined. */
1327
1328 static match
1329 match_out_tag (const io_tag *tag, gfc_expr **result)
1330 {
1331 match m;
1332
1333 m = match_vtag (tag, result);
1334 if (m == MATCH_YES)
1335 gfc_check_do_variable ((*result)->symtree);
1336
1337 return m;
1338 }
1339
1340
1341 /* Match a label I/O tag. */
1342
1343 static match
1344 match_ltag (const io_tag *tag, gfc_st_label ** label)
1345 {
1346 match m;
1347 gfc_st_label *old;
1348
1349 old = *label;
1350 m = gfc_match (tag->spec);
1351 if (m != MATCH_YES)
1352 return m;
1353
1354 m = gfc_match (tag->value, label);
1355 if (m != MATCH_YES)
1356 {
1357 gfc_error ("Invalid value for %s specification at %C", tag->name);
1358 return MATCH_ERROR;
1359 }
1360
1361 if (old)
1362 {
1363 gfc_error ("Duplicate %s label specification at %C", tag->name);
1364 return MATCH_ERROR;
1365 }
1366
1367 if (gfc_reference_st_label (*label, ST_LABEL_TARGET) == FAILURE)
1368 return MATCH_ERROR;
1369
1370 return m;
1371 }
1372
1373
1374 /* Resolution of the FORMAT tag, to be called from resolve_tag. */
1375
1376 static gfc_try
1377 resolve_tag_format (const gfc_expr *e)
1378 {
1379 if (e->expr_type == EXPR_CONSTANT
1380 && (e->ts.type != BT_CHARACTER
1381 || e->ts.kind != gfc_default_character_kind))
1382 {
1383 gfc_error ("Constant expression in FORMAT tag at %L must be "
1384 "of type default CHARACTER", &e->where);
1385 return FAILURE;
1386 }
1387
1388 /* If e's rank is zero and e is not an element of an array, it should be
1389 of integer or character type. The integer variable should be
1390 ASSIGNED. */
1391 if (e->rank == 0
1392 && (e->expr_type != EXPR_VARIABLE
1393 || e->symtree == NULL
1394 || e->symtree->n.sym->as == NULL
1395 || e->symtree->n.sym->as->rank == 0))
1396 {
1397 if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
1398 {
1399 gfc_error ("FORMAT tag at %L must be of type CHARACTER or INTEGER",
1400 &e->where);
1401 return FAILURE;
1402 }
1403 else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
1404 {
1405 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGNED "
1406 "variable in FORMAT tag at %L", &e->where)
1407 == FAILURE)
1408 return FAILURE;
1409 if (e->symtree->n.sym->attr.assign != 1)
1410 {
1411 gfc_error ("Variable '%s' at %L has not been assigned a "
1412 "format label", e->symtree->n.sym->name, &e->where);
1413 return FAILURE;
1414 }
1415 }
1416 else if (e->ts.type == BT_INTEGER)
1417 {
1418 gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
1419 "variable", gfc_basic_typename (e->ts.type), &e->where);
1420 return FAILURE;
1421 }
1422
1423 return SUCCESS;
1424 }
1425
1426 /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
1427 It may be assigned an Hollerith constant. */
1428 if (e->ts.type != BT_CHARACTER)
1429 {
1430 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character "
1431 "in FORMAT tag at %L", &e->where) == FAILURE)
1432 return FAILURE;
1433
1434 if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)
1435 {
1436 gfc_error ("Non-character assumed shape array element in FORMAT"
1437 " tag at %L", &e->where);
1438 return FAILURE;
1439 }
1440
1441 if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
1442 {
1443 gfc_error ("Non-character assumed size array element in FORMAT"
1444 " tag at %L", &e->where);
1445 return FAILURE;
1446 }
1447
1448 if (e->rank == 0 && e->symtree->n.sym->attr.pointer)
1449 {
1450 gfc_error ("Non-character pointer array element in FORMAT tag at %L",
1451 &e->where);
1452 return FAILURE;
1453 }
1454 }
1455
1456 return SUCCESS;
1457 }
1458
1459
1460 /* Do expression resolution and type-checking on an expression tag. */
1461
1462 static gfc_try
1463 resolve_tag (const io_tag *tag, gfc_expr *e)
1464 {
1465 if (e == NULL)
1466 return SUCCESS;
1467
1468 if (gfc_resolve_expr (e) == FAILURE)
1469 return FAILURE;
1470
1471 if (tag == &tag_format)
1472 return resolve_tag_format (e);
1473
1474 if (e->ts.type != tag->type)
1475 {
1476 gfc_error ("%s tag at %L must be of type %s", tag->name,
1477 &e->where, gfc_basic_typename (tag->type));
1478 return FAILURE;
1479 }
1480
1481 if (e->rank != 0)
1482 {
1483 gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
1484 return FAILURE;
1485 }
1486
1487 if (tag == &tag_iomsg)
1488 {
1489 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L",
1490 &e->where) == FAILURE)
1491 return FAILURE;
1492 }
1493
1494 if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength)
1495 && e->ts.kind != gfc_default_integer_kind)
1496 {
1497 if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
1498 "INTEGER in %s tag at %L", tag->name, &e->where)
1499 == FAILURE)
1500 return FAILURE;
1501 }
1502
1503 if (tag == &tag_exist && e->ts.kind != gfc_default_logical_kind)
1504 {
1505 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Nondefault LOGICAL "
1506 "in %s tag at %L", tag->name, &e->where)
1507 == FAILURE)
1508 return FAILURE;
1509 }
1510
1511 if (tag == &tag_newunit)
1512 {
1513 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: NEWUNIT specifier"
1514 " at %L", &e->where) == FAILURE)
1515 return FAILURE;
1516 }
1517
1518 /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */
1519 if (tag == &tag_newunit || tag == &tag_iostat
1520 || tag == &tag_size || tag == &tag_iomsg)
1521 {
1522 char context[64];
1523
1524 sprintf (context, _("%s tag"), tag->name);
1525 if (gfc_check_vardef_context (e, false, context) == FAILURE)
1526 return FAILURE;
1527 }
1528
1529 if (tag == &tag_convert)
1530 {
1531 if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L",
1532 &e->where) == FAILURE)
1533 return FAILURE;
1534 }
1535
1536 return SUCCESS;
1537 }
1538
1539
1540 /* Match a single tag of an OPEN statement. */
1541
1542 static match
1543 match_open_element (gfc_open *open)
1544 {
1545 match m;
1546
1547 m = match_etag (&tag_e_async, &open->asynchronous);
1548 if (m != MATCH_NO)
1549 return m;
1550 m = match_etag (&tag_unit, &open->unit);
1551 if (m != MATCH_NO)
1552 return m;
1553 m = match_out_tag (&tag_iomsg, &open->iomsg);
1554 if (m != MATCH_NO)
1555 return m;
1556 m = match_out_tag (&tag_iostat, &open->iostat);
1557 if (m != MATCH_NO)
1558 return m;
1559 m = match_etag (&tag_file, &open->file);
1560 if (m != MATCH_NO)
1561 return m;
1562 m = match_etag (&tag_status, &open->status);
1563 if (m != MATCH_NO)
1564 return m;
1565 m = match_etag (&tag_e_access, &open->access);
1566 if (m != MATCH_NO)
1567 return m;
1568 m = match_etag (&tag_e_form, &open->form);
1569 if (m != MATCH_NO)
1570 return m;
1571 m = match_etag (&tag_e_recl, &open->recl);
1572 if (m != MATCH_NO)
1573 return m;
1574 m = match_etag (&tag_e_blank, &open->blank);
1575 if (m != MATCH_NO)
1576 return m;
1577 m = match_etag (&tag_e_position, &open->position);
1578 if (m != MATCH_NO)
1579 return m;
1580 m = match_etag (&tag_e_action, &open->action);
1581 if (m != MATCH_NO)
1582 return m;
1583 m = match_etag (&tag_e_delim, &open->delim);
1584 if (m != MATCH_NO)
1585 return m;
1586 m = match_etag (&tag_e_pad, &open->pad);
1587 if (m != MATCH_NO)
1588 return m;
1589 m = match_etag (&tag_e_decimal, &open->decimal);
1590 if (m != MATCH_NO)
1591 return m;
1592 m = match_etag (&tag_e_encoding, &open->encoding);
1593 if (m != MATCH_NO)
1594 return m;
1595 m = match_etag (&tag_e_round, &open->round);
1596 if (m != MATCH_NO)
1597 return m;
1598 m = match_etag (&tag_e_sign, &open->sign);
1599 if (m != MATCH_NO)
1600 return m;
1601 m = match_ltag (&tag_err, &open->err);
1602 if (m != MATCH_NO)
1603 return m;
1604 m = match_etag (&tag_convert, &open->convert);
1605 if (m != MATCH_NO)
1606 return m;
1607 m = match_out_tag (&tag_newunit, &open->newunit);
1608 if (m != MATCH_NO)
1609 return m;
1610
1611 return MATCH_NO;
1612 }
1613
1614
1615 /* Free the gfc_open structure and all the expressions it contains. */
1616
1617 void
1618 gfc_free_open (gfc_open *open)
1619 {
1620 if (open == NULL)
1621 return;
1622
1623 gfc_free_expr (open->unit);
1624 gfc_free_expr (open->iomsg);
1625 gfc_free_expr (open->iostat);
1626 gfc_free_expr (open->file);
1627 gfc_free_expr (open->status);
1628 gfc_free_expr (open->access);
1629 gfc_free_expr (open->form);
1630 gfc_free_expr (open->recl);
1631 gfc_free_expr (open->blank);
1632 gfc_free_expr (open->position);
1633 gfc_free_expr (open->action);
1634 gfc_free_expr (open->delim);
1635 gfc_free_expr (open->pad);
1636 gfc_free_expr (open->decimal);
1637 gfc_free_expr (open->encoding);
1638 gfc_free_expr (open->round);
1639 gfc_free_expr (open->sign);
1640 gfc_free_expr (open->convert);
1641 gfc_free_expr (open->asynchronous);
1642 gfc_free_expr (open->newunit);
1643 gfc_free (open);
1644 }
1645
1646
1647 /* Resolve everything in a gfc_open structure. */
1648
1649 gfc_try
1650 gfc_resolve_open (gfc_open *open)
1651 {
1652
1653 RESOLVE_TAG (&tag_unit, open->unit);
1654 RESOLVE_TAG (&tag_iomsg, open->iomsg);
1655 RESOLVE_TAG (&tag_iostat, open->iostat);
1656 RESOLVE_TAG (&tag_file, open->file);
1657 RESOLVE_TAG (&tag_status, open->status);
1658 RESOLVE_TAG (&tag_e_access, open->access);
1659 RESOLVE_TAG (&tag_e_form, open->form);
1660 RESOLVE_TAG (&tag_e_recl, open->recl);
1661 RESOLVE_TAG (&tag_e_blank, open->blank);
1662 RESOLVE_TAG (&tag_e_position, open->position);
1663 RESOLVE_TAG (&tag_e_action, open->action);
1664 RESOLVE_TAG (&tag_e_delim, open->delim);
1665 RESOLVE_TAG (&tag_e_pad, open->pad);
1666 RESOLVE_TAG (&tag_e_decimal, open->decimal);
1667 RESOLVE_TAG (&tag_e_encoding, open->encoding);
1668 RESOLVE_TAG (&tag_e_async, open->asynchronous);
1669 RESOLVE_TAG (&tag_e_round, open->round);
1670 RESOLVE_TAG (&tag_e_sign, open->sign);
1671 RESOLVE_TAG (&tag_convert, open->convert);
1672 RESOLVE_TAG (&tag_newunit, open->newunit);
1673
1674 if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
1675 return FAILURE;
1676
1677 return SUCCESS;
1678 }
1679
1680
1681 /* Check if a given value for a SPECIFIER is either in the list of values
1682 allowed in F95 or F2003, issuing an error message and returning a zero
1683 value if it is not allowed. */
1684
1685 static int
1686 compare_to_allowed_values (const char *specifier, const char *allowed[],
1687 const char *allowed_f2003[],
1688 const char *allowed_gnu[], gfc_char_t *value,
1689 const char *statement, bool warn)
1690 {
1691 int i;
1692 unsigned int len;
1693
1694 len = gfc_wide_strlen (value);
1695 if (len > 0)
1696 {
1697 for (len--; len > 0; len--)
1698 if (value[len] != ' ')
1699 break;
1700 len++;
1701 }
1702
1703 for (i = 0; allowed[i]; i++)
1704 if (len == strlen (allowed[i])
1705 && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
1706 return 1;
1707
1708 for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
1709 if (len == strlen (allowed_f2003[i])
1710 && gfc_wide_strncasecmp (value, allowed_f2003[i],
1711 strlen (allowed_f2003[i])) == 0)
1712 {
1713 notification n = gfc_notification_std (GFC_STD_F2003);
1714
1715 if (n == WARNING || (warn && n == ERROR))
1716 {
1717 gfc_warning ("Fortran 2003: %s specifier in %s statement at %C "
1718 "has value '%s'", specifier, statement,
1719 allowed_f2003[i]);
1720 return 1;
1721 }
1722 else
1723 if (n == ERROR)
1724 {
1725 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: %s specifier in "
1726 "%s statement at %C has value '%s'", specifier,
1727 statement, allowed_f2003[i]);
1728 return 0;
1729 }
1730
1731 /* n == SILENT */
1732 return 1;
1733 }
1734
1735 for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
1736 if (len == strlen (allowed_gnu[i])
1737 && gfc_wide_strncasecmp (value, allowed_gnu[i],
1738 strlen (allowed_gnu[i])) == 0)
1739 {
1740 notification n = gfc_notification_std (GFC_STD_GNU);
1741
1742 if (n == WARNING || (warn && n == ERROR))
1743 {
1744 gfc_warning ("Extension: %s specifier in %s statement at %C "
1745 "has value '%s'", specifier, statement,
1746 allowed_gnu[i]);
1747 return 1;
1748 }
1749 else
1750 if (n == ERROR)
1751 {
1752 gfc_notify_std (GFC_STD_GNU, "Extension: %s specifier in "
1753 "%s statement at %C has value '%s'", specifier,
1754 statement, allowed_gnu[i]);
1755 return 0;
1756 }
1757
1758 /* n == SILENT */
1759 return 1;
1760 }
1761
1762 if (warn)
1763 {
1764 char *s = gfc_widechar_to_char (value, -1);
1765 gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
1766 specifier, statement, s);
1767 gfc_free (s);
1768 return 1;
1769 }
1770 else
1771 {
1772 char *s = gfc_widechar_to_char (value, -1);
1773 gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
1774 specifier, statement, s);
1775 gfc_free (s);
1776 return 0;
1777 }
1778 }
1779
1780
1781 /* Match an OPEN statement. */
1782
1783 match
1784 gfc_match_open (void)
1785 {
1786 gfc_open *open;
1787 match m;
1788 bool warn;
1789
1790 m = gfc_match_char ('(');
1791 if (m == MATCH_NO)
1792 return m;
1793
1794 open = XCNEW (gfc_open);
1795
1796 m = match_open_element (open);
1797
1798 if (m == MATCH_ERROR)
1799 goto cleanup;
1800 if (m == MATCH_NO)
1801 {
1802 m = gfc_match_expr (&open->unit);
1803 if (m == MATCH_ERROR)
1804 goto cleanup;
1805 }
1806
1807 for (;;)
1808 {
1809 if (gfc_match_char (')') == MATCH_YES)
1810 break;
1811 if (gfc_match_char (',') != MATCH_YES)
1812 goto syntax;
1813
1814 m = match_open_element (open);
1815 if (m == MATCH_ERROR)
1816 goto cleanup;
1817 if (m == MATCH_NO)
1818 goto syntax;
1819 }
1820
1821 if (gfc_match_eos () == MATCH_NO)
1822 goto syntax;
1823
1824 if (gfc_pure (NULL))
1825 {
1826 gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1827 goto cleanup;
1828 }
1829
1830 if (gfc_implicit_pure (NULL))
1831 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1832
1833 warn = (open->err || open->iostat) ? true : false;
1834
1835 /* Checks on NEWUNIT specifier. */
1836 if (open->newunit)
1837 {
1838 if (open->unit)
1839 {
1840 gfc_error ("UNIT specifier not allowed with NEWUNIT at %C");
1841 goto cleanup;
1842 }
1843
1844 if (!(open->file || (open->status
1845 && gfc_wide_strncasecmp (open->status->value.character.string,
1846 "scratch", 7) == 0)))
1847 {
1848 gfc_error ("NEWUNIT specifier must have FILE= "
1849 "or STATUS='scratch' at %C");
1850 goto cleanup;
1851 }
1852 }
1853 else if (!open->unit)
1854 {
1855 gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified");
1856 goto cleanup;
1857 }
1858
1859 /* Checks on the ACCESS specifier. */
1860 if (open->access && open->access->expr_type == EXPR_CONSTANT)
1861 {
1862 static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
1863 static const char *access_f2003[] = { "STREAM", NULL };
1864 static const char *access_gnu[] = { "APPEND", NULL };
1865
1866 if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
1867 access_gnu,
1868 open->access->value.character.string,
1869 "OPEN", warn))
1870 goto cleanup;
1871 }
1872
1873 /* Checks on the ACTION specifier. */
1874 if (open->action && open->action->expr_type == EXPR_CONSTANT)
1875 {
1876 static const char *action[] = { "READ", "WRITE", "READWRITE", NULL };
1877
1878 if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
1879 open->action->value.character.string,
1880 "OPEN", warn))
1881 goto cleanup;
1882 }
1883
1884 /* Checks on the ASYNCHRONOUS specifier. */
1885 if (open->asynchronous)
1886 {
1887 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASYNCHRONOUS= at %C "
1888 "not allowed in Fortran 95") == FAILURE)
1889 goto cleanup;
1890
1891 if (open->asynchronous->expr_type == EXPR_CONSTANT)
1892 {
1893 static const char * asynchronous[] = { "YES", "NO", NULL };
1894
1895 if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous,
1896 NULL, NULL, open->asynchronous->value.character.string,
1897 "OPEN", warn))
1898 goto cleanup;
1899 }
1900 }
1901
1902 /* Checks on the BLANK specifier. */
1903 if (open->blank)
1904 {
1905 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
1906 "not allowed in Fortran 95") == FAILURE)
1907 goto cleanup;
1908
1909 if (open->blank->expr_type == EXPR_CONSTANT)
1910 {
1911 static const char *blank[] = { "ZERO", "NULL", NULL };
1912
1913 if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
1914 open->blank->value.character.string,
1915 "OPEN", warn))
1916 goto cleanup;
1917 }
1918 }
1919
1920 /* Checks on the DECIMAL specifier. */
1921 if (open->decimal)
1922 {
1923 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
1924 "not allowed in Fortran 95") == FAILURE)
1925 goto cleanup;
1926
1927 if (open->decimal->expr_type == EXPR_CONSTANT)
1928 {
1929 static const char * decimal[] = { "COMMA", "POINT", NULL };
1930
1931 if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
1932 open->decimal->value.character.string,
1933 "OPEN", warn))
1934 goto cleanup;
1935 }
1936 }
1937
1938 /* Checks on the DELIM specifier. */
1939 if (open->delim)
1940 {
1941 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
1942 "not allowed in Fortran 95") == FAILURE)
1943 goto cleanup;
1944
1945 if (open->delim->expr_type == EXPR_CONSTANT)
1946 {
1947 static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
1948
1949 if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
1950 open->delim->value.character.string,
1951 "OPEN", warn))
1952 goto cleanup;
1953 }
1954 }
1955
1956 /* Checks on the ENCODING specifier. */
1957 if (open->encoding)
1958 {
1959 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENCODING= at %C "
1960 "not allowed in Fortran 95") == FAILURE)
1961 goto cleanup;
1962
1963 if (open->encoding->expr_type == EXPR_CONSTANT)
1964 {
1965 static const char * encoding[] = { "DEFAULT", "UTF-8", NULL };
1966
1967 if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
1968 open->encoding->value.character.string,
1969 "OPEN", warn))
1970 goto cleanup;
1971 }
1972 }
1973
1974 /* Checks on the FORM specifier. */
1975 if (open->form && open->form->expr_type == EXPR_CONSTANT)
1976 {
1977 static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
1978
1979 if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
1980 open->form->value.character.string,
1981 "OPEN", warn))
1982 goto cleanup;
1983 }
1984
1985 /* Checks on the PAD specifier. */
1986 if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
1987 {
1988 static const char *pad[] = { "YES", "NO", NULL };
1989
1990 if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
1991 open->pad->value.character.string,
1992 "OPEN", warn))
1993 goto cleanup;
1994 }
1995
1996 /* Checks on the POSITION specifier. */
1997 if (open->position && open->position->expr_type == EXPR_CONSTANT)
1998 {
1999 static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
2000
2001 if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
2002 open->position->value.character.string,
2003 "OPEN", warn))
2004 goto cleanup;
2005 }
2006
2007 /* Checks on the ROUND specifier. */
2008 if (open->round)
2009 {
2010 if (gfc_notify_std (GFC_STD_F2003, "Fortran F2003: ROUND= at %C "
2011 "not allowed in Fortran 95") == FAILURE)
2012 goto cleanup;
2013
2014 if (open->round->expr_type == EXPR_CONSTANT)
2015 {
2016 static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
2017 "COMPATIBLE", "PROCESSOR_DEFINED",
2018 NULL };
2019
2020 if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
2021 open->round->value.character.string,
2022 "OPEN", warn))
2023 goto cleanup;
2024 }
2025 }
2026
2027 /* Checks on the SIGN specifier. */
2028 if (open->sign)
2029 {
2030 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
2031 "not allowed in Fortran 95") == FAILURE)
2032 goto cleanup;
2033
2034 if (open->sign->expr_type == EXPR_CONSTANT)
2035 {
2036 static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
2037 NULL };
2038
2039 if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
2040 open->sign->value.character.string,
2041 "OPEN", warn))
2042 goto cleanup;
2043 }
2044 }
2045
2046 #define warn_or_error(...) \
2047 { \
2048 if (warn) \
2049 gfc_warning (__VA_ARGS__); \
2050 else \
2051 { \
2052 gfc_error (__VA_ARGS__); \
2053 goto cleanup; \
2054 } \
2055 }
2056
2057 /* Checks on the RECL specifier. */
2058 if (open->recl && open->recl->expr_type == EXPR_CONSTANT
2059 && open->recl->ts.type == BT_INTEGER
2060 && mpz_sgn (open->recl->value.integer) != 1)
2061 {
2062 warn_or_error ("RECL in OPEN statement at %C must be positive");
2063 }
2064
2065 /* Checks on the STATUS specifier. */
2066 if (open->status && open->status->expr_type == EXPR_CONSTANT)
2067 {
2068 static const char *status[] = { "OLD", "NEW", "SCRATCH",
2069 "REPLACE", "UNKNOWN", NULL };
2070
2071 if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2072 open->status->value.character.string,
2073 "OPEN", warn))
2074 goto cleanup;
2075
2076 /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2077 the FILE= specifier shall appear. */
2078 if (open->file == NULL
2079 && (gfc_wide_strncasecmp (open->status->value.character.string,
2080 "replace", 7) == 0
2081 || gfc_wide_strncasecmp (open->status->value.character.string,
2082 "new", 3) == 0))
2083 {
2084 char *s = gfc_widechar_to_char (open->status->value.character.string,
2085 -1);
2086 warn_or_error ("The STATUS specified in OPEN statement at %C is "
2087 "'%s' and no FILE specifier is present", s);
2088 gfc_free (s);
2089 }
2090
2091 /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2092 the FILE= specifier shall not appear. */
2093 if (gfc_wide_strncasecmp (open->status->value.character.string,
2094 "scratch", 7) == 0 && open->file)
2095 {
2096 warn_or_error ("The STATUS specified in OPEN statement at %C "
2097 "cannot have the value SCRATCH if a FILE specifier "
2098 "is present");
2099 }
2100 }
2101
2102 /* Things that are not allowed for unformatted I/O. */
2103 if (open->form && open->form->expr_type == EXPR_CONSTANT
2104 && (open->delim || open->decimal || open->encoding || open->round
2105 || open->sign || open->pad || open->blank)
2106 && gfc_wide_strncasecmp (open->form->value.character.string,
2107 "unformatted", 11) == 0)
2108 {
2109 const char *spec = (open->delim ? "DELIM "
2110 : (open->pad ? "PAD " : open->blank
2111 ? "BLANK " : ""));
2112
2113 warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
2114 "unformatted I/O", spec);
2115 }
2116
2117 if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
2118 && gfc_wide_strncasecmp (open->access->value.character.string,
2119 "stream", 6) == 0)
2120 {
2121 warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
2122 "stream I/O");
2123 }
2124
2125 if (open->position
2126 && open->access && open->access->expr_type == EXPR_CONSTANT
2127 && !(gfc_wide_strncasecmp (open->access->value.character.string,
2128 "sequential", 10) == 0
2129 || gfc_wide_strncasecmp (open->access->value.character.string,
2130 "stream", 6) == 0
2131 || gfc_wide_strncasecmp (open->access->value.character.string,
2132 "append", 6) == 0))
2133 {
2134 warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
2135 "for stream or sequential ACCESS");
2136 }
2137
2138 #undef warn_or_error
2139
2140 new_st.op = EXEC_OPEN;
2141 new_st.ext.open = open;
2142 return MATCH_YES;
2143
2144 syntax:
2145 gfc_syntax_error (ST_OPEN);
2146
2147 cleanup:
2148 gfc_free_open (open);
2149 return MATCH_ERROR;
2150 }
2151
2152
2153 /* Free a gfc_close structure an all its expressions. */
2154
2155 void
2156 gfc_free_close (gfc_close *close)
2157 {
2158 if (close == NULL)
2159 return;
2160
2161 gfc_free_expr (close->unit);
2162 gfc_free_expr (close->iomsg);
2163 gfc_free_expr (close->iostat);
2164 gfc_free_expr (close->status);
2165 gfc_free (close);
2166 }
2167
2168
2169 /* Match elements of a CLOSE statement. */
2170
2171 static match
2172 match_close_element (gfc_close *close)
2173 {
2174 match m;
2175
2176 m = match_etag (&tag_unit, &close->unit);
2177 if (m != MATCH_NO)
2178 return m;
2179 m = match_etag (&tag_status, &close->status);
2180 if (m != MATCH_NO)
2181 return m;
2182 m = match_out_tag (&tag_iomsg, &close->iomsg);
2183 if (m != MATCH_NO)
2184 return m;
2185 m = match_out_tag (&tag_iostat, &close->iostat);
2186 if (m != MATCH_NO)
2187 return m;
2188 m = match_ltag (&tag_err, &close->err);
2189 if (m != MATCH_NO)
2190 return m;
2191
2192 return MATCH_NO;
2193 }
2194
2195
2196 /* Match a CLOSE statement. */
2197
2198 match
2199 gfc_match_close (void)
2200 {
2201 gfc_close *close;
2202 match m;
2203 bool warn;
2204
2205 m = gfc_match_char ('(');
2206 if (m == MATCH_NO)
2207 return m;
2208
2209 close = XCNEW (gfc_close);
2210
2211 m = match_close_element (close);
2212
2213 if (m == MATCH_ERROR)
2214 goto cleanup;
2215 if (m == MATCH_NO)
2216 {
2217 m = gfc_match_expr (&close->unit);
2218 if (m == MATCH_NO)
2219 goto syntax;
2220 if (m == MATCH_ERROR)
2221 goto cleanup;
2222 }
2223
2224 for (;;)
2225 {
2226 if (gfc_match_char (')') == MATCH_YES)
2227 break;
2228 if (gfc_match_char (',') != MATCH_YES)
2229 goto syntax;
2230
2231 m = match_close_element (close);
2232 if (m == MATCH_ERROR)
2233 goto cleanup;
2234 if (m == MATCH_NO)
2235 goto syntax;
2236 }
2237
2238 if (gfc_match_eos () == MATCH_NO)
2239 goto syntax;
2240
2241 if (gfc_pure (NULL))
2242 {
2243 gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2244 goto cleanup;
2245 }
2246
2247 if (gfc_implicit_pure (NULL))
2248 gfc_current_ns->proc_name->attr.implicit_pure = 0;
2249
2250 warn = (close->iostat || close->err) ? true : false;
2251
2252 /* Checks on the STATUS specifier. */
2253 if (close->status && close->status->expr_type == EXPR_CONSTANT)
2254 {
2255 static const char *status[] = { "KEEP", "DELETE", NULL };
2256
2257 if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2258 close->status->value.character.string,
2259 "CLOSE", warn))
2260 goto cleanup;
2261 }
2262
2263 new_st.op = EXEC_CLOSE;
2264 new_st.ext.close = close;
2265 return MATCH_YES;
2266
2267 syntax:
2268 gfc_syntax_error (ST_CLOSE);
2269
2270 cleanup:
2271 gfc_free_close (close);
2272 return MATCH_ERROR;
2273 }
2274
2275
2276 /* Resolve everything in a gfc_close structure. */
2277
2278 gfc_try
2279 gfc_resolve_close (gfc_close *close)
2280 {
2281 RESOLVE_TAG (&tag_unit, close->unit);
2282 RESOLVE_TAG (&tag_iomsg, close->iomsg);
2283 RESOLVE_TAG (&tag_iostat, close->iostat);
2284 RESOLVE_TAG (&tag_status, close->status);
2285
2286 if (gfc_reference_st_label (close->err, ST_LABEL_TARGET) == FAILURE)
2287 return FAILURE;
2288
2289 if (close->unit->expr_type == EXPR_CONSTANT
2290 && close->unit->ts.type == BT_INTEGER
2291 && mpz_sgn (close->unit->value.integer) < 0)
2292 {
2293 gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2294 &close->unit->where);
2295 }
2296
2297 return SUCCESS;
2298 }
2299
2300
2301 /* Free a gfc_filepos structure. */
2302
2303 void
2304 gfc_free_filepos (gfc_filepos *fp)
2305 {
2306 gfc_free_expr (fp->unit);
2307 gfc_free_expr (fp->iomsg);
2308 gfc_free_expr (fp->iostat);
2309 gfc_free (fp);
2310 }
2311
2312
2313 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
2314
2315 static match
2316 match_file_element (gfc_filepos *fp)
2317 {
2318 match m;
2319
2320 m = match_etag (&tag_unit, &fp->unit);
2321 if (m != MATCH_NO)
2322 return m;
2323 m = match_out_tag (&tag_iomsg, &fp->iomsg);
2324 if (m != MATCH_NO)
2325 return m;
2326 m = match_out_tag (&tag_iostat, &fp->iostat);
2327 if (m != MATCH_NO)
2328 return m;
2329 m = match_ltag (&tag_err, &fp->err);
2330 if (m != MATCH_NO)
2331 return m;
2332
2333 return MATCH_NO;
2334 }
2335
2336
2337 /* Match the second half of the file-positioning statements, REWIND,
2338 BACKSPACE, ENDFILE, or the FLUSH statement. */
2339
2340 static match
2341 match_filepos (gfc_statement st, gfc_exec_op op)
2342 {
2343 gfc_filepos *fp;
2344 match m;
2345
2346 fp = XCNEW (gfc_filepos);
2347
2348 if (gfc_match_char ('(') == MATCH_NO)
2349 {
2350 m = gfc_match_expr (&fp->unit);
2351 if (m == MATCH_ERROR)
2352 goto cleanup;
2353 if (m == MATCH_NO)
2354 goto syntax;
2355
2356 goto done;
2357 }
2358
2359 m = match_file_element (fp);
2360 if (m == MATCH_ERROR)
2361 goto done;
2362 if (m == MATCH_NO)
2363 {
2364 m = gfc_match_expr (&fp->unit);
2365 if (m == MATCH_ERROR)
2366 goto done;
2367 if (m == MATCH_NO)
2368 goto syntax;
2369 }
2370
2371 for (;;)
2372 {
2373 if (gfc_match_char (')') == MATCH_YES)
2374 break;
2375 if (gfc_match_char (',') != MATCH_YES)
2376 goto syntax;
2377
2378 m = match_file_element (fp);
2379 if (m == MATCH_ERROR)
2380 goto cleanup;
2381 if (m == MATCH_NO)
2382 goto syntax;
2383 }
2384
2385 done:
2386 if (gfc_match_eos () != MATCH_YES)
2387 goto syntax;
2388
2389 if (gfc_pure (NULL))
2390 {
2391 gfc_error ("%s statement not allowed in PURE procedure at %C",
2392 gfc_ascii_statement (st));
2393
2394 goto cleanup;
2395 }
2396
2397 if (gfc_implicit_pure (NULL))
2398 gfc_current_ns->proc_name->attr.implicit_pure = 0;
2399
2400 new_st.op = op;
2401 new_st.ext.filepos = fp;
2402 return MATCH_YES;
2403
2404 syntax:
2405 gfc_syntax_error (st);
2406
2407 cleanup:
2408 gfc_free_filepos (fp);
2409 return MATCH_ERROR;
2410 }
2411
2412
2413 gfc_try
2414 gfc_resolve_filepos (gfc_filepos *fp)
2415 {
2416 RESOLVE_TAG (&tag_unit, fp->unit);
2417 RESOLVE_TAG (&tag_iostat, fp->iostat);
2418 RESOLVE_TAG (&tag_iomsg, fp->iomsg);
2419 if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE)
2420 return FAILURE;
2421
2422 if (fp->unit->expr_type == EXPR_CONSTANT
2423 && fp->unit->ts.type == BT_INTEGER
2424 && mpz_sgn (fp->unit->value.integer) < 0)
2425 {
2426 gfc_error ("UNIT number in statement at %L must be non-negative",
2427 &fp->unit->where);
2428 }
2429
2430 return SUCCESS;
2431 }
2432
2433
2434 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2435 and the FLUSH statement. */
2436
2437 match
2438 gfc_match_endfile (void)
2439 {
2440 return match_filepos (ST_END_FILE, EXEC_ENDFILE);
2441 }
2442
2443 match
2444 gfc_match_backspace (void)
2445 {
2446 return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
2447 }
2448
2449 match
2450 gfc_match_rewind (void)
2451 {
2452 return match_filepos (ST_REWIND, EXEC_REWIND);
2453 }
2454
2455 match
2456 gfc_match_flush (void)
2457 {
2458 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C")
2459 == FAILURE)
2460 return MATCH_ERROR;
2461
2462 return match_filepos (ST_FLUSH, EXEC_FLUSH);
2463 }
2464
2465 /******************** Data Transfer Statements *********************/
2466
2467 /* Return a default unit number. */
2468
2469 static gfc_expr *
2470 default_unit (io_kind k)
2471 {
2472 int unit;
2473
2474 if (k == M_READ)
2475 unit = 5;
2476 else
2477 unit = 6;
2478
2479 return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit);
2480 }
2481
2482
2483 /* Match a unit specification for a data transfer statement. */
2484
2485 static match
2486 match_dt_unit (io_kind k, gfc_dt *dt)
2487 {
2488 gfc_expr *e;
2489
2490 if (gfc_match_char ('*') == MATCH_YES)
2491 {
2492 if (dt->io_unit != NULL)
2493 goto conflict;
2494
2495 dt->io_unit = default_unit (k);
2496 return MATCH_YES;
2497 }
2498
2499 if (gfc_match_expr (&e) == MATCH_YES)
2500 {
2501 if (dt->io_unit != NULL)
2502 {
2503 gfc_free_expr (e);
2504 goto conflict;
2505 }
2506
2507 dt->io_unit = e;
2508 return MATCH_YES;
2509 }
2510
2511 return MATCH_NO;
2512
2513 conflict:
2514 gfc_error ("Duplicate UNIT specification at %C");
2515 return MATCH_ERROR;
2516 }
2517
2518
2519 /* Match a format specification. */
2520
2521 static match
2522 match_dt_format (gfc_dt *dt)
2523 {
2524 locus where;
2525 gfc_expr *e;
2526 gfc_st_label *label;
2527 match m;
2528
2529 where = gfc_current_locus;
2530
2531 if (gfc_match_char ('*') == MATCH_YES)
2532 {
2533 if (dt->format_expr != NULL || dt->format_label != NULL)
2534 goto conflict;
2535
2536 dt->format_label = &format_asterisk;
2537 return MATCH_YES;
2538 }
2539
2540 if ((m = gfc_match_st_label (&label)) == MATCH_YES)
2541 {
2542 if (dt->format_expr != NULL || dt->format_label != NULL)
2543 {
2544 gfc_free_st_label (label);
2545 goto conflict;
2546 }
2547
2548 if (gfc_reference_st_label (label, ST_LABEL_FORMAT) == FAILURE)
2549 return MATCH_ERROR;
2550
2551 dt->format_label = label;
2552 return MATCH_YES;
2553 }
2554 else if (m == MATCH_ERROR)
2555 /* The label was zero or too large. Emit the correct diagnosis. */
2556 return MATCH_ERROR;
2557
2558 if (gfc_match_expr (&e) == MATCH_YES)
2559 {
2560 if (dt->format_expr != NULL || dt->format_label != NULL)
2561 {
2562 gfc_free_expr (e);
2563 goto conflict;
2564 }
2565 dt->format_expr = e;
2566 return MATCH_YES;
2567 }
2568
2569 gfc_current_locus = where; /* The only case where we have to restore */
2570
2571 return MATCH_NO;
2572
2573 conflict:
2574 gfc_error ("Duplicate format specification at %C");
2575 return MATCH_ERROR;
2576 }
2577
2578
2579 /* Traverse a namelist that is part of a READ statement to make sure
2580 that none of the variables in the namelist are INTENT(IN). Returns
2581 nonzero if we find such a variable. */
2582
2583 static int
2584 check_namelist (gfc_symbol *sym)
2585 {
2586 gfc_namelist *p;
2587
2588 for (p = sym->namelist; p; p = p->next)
2589 if (p->sym->attr.intent == INTENT_IN)
2590 {
2591 gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
2592 p->sym->name, sym->name);
2593 return 1;
2594 }
2595
2596 return 0;
2597 }
2598
2599
2600 /* Match a single data transfer element. */
2601
2602 static match
2603 match_dt_element (io_kind k, gfc_dt *dt)
2604 {
2605 char name[GFC_MAX_SYMBOL_LEN + 1];
2606 gfc_symbol *sym;
2607 match m;
2608
2609 if (gfc_match (" unit =") == MATCH_YES)
2610 {
2611 m = match_dt_unit (k, dt);
2612 if (m != MATCH_NO)
2613 return m;
2614 }
2615
2616 if (gfc_match (" fmt =") == MATCH_YES)
2617 {
2618 m = match_dt_format (dt);
2619 if (m != MATCH_NO)
2620 return m;
2621 }
2622
2623 if (gfc_match (" nml = %n", name) == MATCH_YES)
2624 {
2625 if (dt->namelist != NULL)
2626 {
2627 gfc_error ("Duplicate NML specification at %C");
2628 return MATCH_ERROR;
2629 }
2630
2631 if (gfc_find_symbol (name, NULL, 1, &sym))
2632 return MATCH_ERROR;
2633
2634 if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
2635 {
2636 gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
2637 sym != NULL ? sym->name : name);
2638 return MATCH_ERROR;
2639 }
2640
2641 dt->namelist = sym;
2642 if (k == M_READ && check_namelist (sym))
2643 return MATCH_ERROR;
2644
2645 return MATCH_YES;
2646 }
2647
2648 m = match_etag (&tag_e_async, &dt->asynchronous);
2649 if (m != MATCH_NO)
2650 return m;
2651 m = match_etag (&tag_e_blank, &dt->blank);
2652 if (m != MATCH_NO)
2653 return m;
2654 m = match_etag (&tag_e_delim, &dt->delim);
2655 if (m != MATCH_NO)
2656 return m;
2657 m = match_etag (&tag_e_pad, &dt->pad);
2658 if (m != MATCH_NO)
2659 return m;
2660 m = match_etag (&tag_e_sign, &dt->sign);
2661 if (m != MATCH_NO)
2662 return m;
2663 m = match_etag (&tag_e_round, &dt->round);
2664 if (m != MATCH_NO)
2665 return m;
2666 m = match_out_tag (&tag_id, &dt->id);
2667 if (m != MATCH_NO)
2668 return m;
2669 m = match_etag (&tag_e_decimal, &dt->decimal);
2670 if (m != MATCH_NO)
2671 return m;
2672 m = match_etag (&tag_rec, &dt->rec);
2673 if (m != MATCH_NO)
2674 return m;
2675 m = match_etag (&tag_spos, &dt->pos);
2676 if (m != MATCH_NO)
2677 return m;
2678 m = match_out_tag (&tag_iomsg, &dt->iomsg);
2679 if (m != MATCH_NO)
2680 return m;
2681 m = match_out_tag (&tag_iostat, &dt->iostat);
2682 if (m != MATCH_NO)
2683 return m;
2684 m = match_ltag (&tag_err, &dt->err);
2685 if (m == MATCH_YES)
2686 dt->err_where = gfc_current_locus;
2687 if (m != MATCH_NO)
2688 return m;
2689 m = match_etag (&tag_advance, &dt->advance);
2690 if (m != MATCH_NO)
2691 return m;
2692 m = match_out_tag (&tag_size, &dt->size);
2693 if (m != MATCH_NO)
2694 return m;
2695
2696 m = match_ltag (&tag_end, &dt->end);
2697 if (m == MATCH_YES)
2698 {
2699 if (k == M_WRITE)
2700 {
2701 gfc_error ("END tag at %C not allowed in output statement");
2702 return MATCH_ERROR;
2703 }
2704 dt->end_where = gfc_current_locus;
2705 }
2706 if (m != MATCH_NO)
2707 return m;
2708
2709 m = match_ltag (&tag_eor, &dt->eor);
2710 if (m == MATCH_YES)
2711 dt->eor_where = gfc_current_locus;
2712 if (m != MATCH_NO)
2713 return m;
2714
2715 return MATCH_NO;
2716 }
2717
2718
2719 /* Free a data transfer structure and everything below it. */
2720
2721 void
2722 gfc_free_dt (gfc_dt *dt)
2723 {
2724 if (dt == NULL)
2725 return;
2726
2727 gfc_free_expr (dt->io_unit);
2728 gfc_free_expr (dt->format_expr);
2729 gfc_free_expr (dt->rec);
2730 gfc_free_expr (dt->advance);
2731 gfc_free_expr (dt->iomsg);
2732 gfc_free_expr (dt->iostat);
2733 gfc_free_expr (dt->size);
2734 gfc_free_expr (dt->pad);
2735 gfc_free_expr (dt->delim);
2736 gfc_free_expr (dt->sign);
2737 gfc_free_expr (dt->round);
2738 gfc_free_expr (dt->blank);
2739 gfc_free_expr (dt->decimal);
2740 gfc_free_expr (dt->pos);
2741 gfc_free_expr (dt->dt_io_kind);
2742 /* dt->extra_comma is a link to dt_io_kind if it is set. */
2743 gfc_free (dt);
2744 }
2745
2746
2747 /* Resolve everything in a gfc_dt structure. */
2748
2749 gfc_try
2750 gfc_resolve_dt (gfc_dt *dt, locus *loc)
2751 {
2752 gfc_expr *e;
2753 io_kind k;
2754
2755 /* This is set in any case. */
2756 gcc_assert (dt->dt_io_kind);
2757 k = dt->dt_io_kind->value.iokind;
2758
2759 RESOLVE_TAG (&tag_format, dt->format_expr);
2760 RESOLVE_TAG (&tag_rec, dt->rec);
2761 RESOLVE_TAG (&tag_spos, dt->pos);
2762 RESOLVE_TAG (&tag_advance, dt->advance);
2763 RESOLVE_TAG (&tag_id, dt->id);
2764 RESOLVE_TAG (&tag_iomsg, dt->iomsg);
2765 RESOLVE_TAG (&tag_iostat, dt->iostat);
2766 RESOLVE_TAG (&tag_size, dt->size);
2767 RESOLVE_TAG (&tag_e_pad, dt->pad);
2768 RESOLVE_TAG (&tag_e_delim, dt->delim);
2769 RESOLVE_TAG (&tag_e_sign, dt->sign);
2770 RESOLVE_TAG (&tag_e_round, dt->round);
2771 RESOLVE_TAG (&tag_e_blank, dt->blank);
2772 RESOLVE_TAG (&tag_e_decimal, dt->decimal);
2773 RESOLVE_TAG (&tag_e_async, dt->asynchronous);
2774
2775 e = dt->io_unit;
2776 if (e == NULL)
2777 {
2778 gfc_error ("UNIT not specified at %L", loc);
2779 return FAILURE;
2780 }
2781
2782 if (gfc_resolve_expr (e) == SUCCESS
2783 && (e->ts.type != BT_INTEGER
2784 && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
2785 {
2786 /* If there is no extra comma signifying the "format" form of the IO
2787 statement, then this must be an error. */
2788 if (!dt->extra_comma)
2789 {
2790 gfc_error ("UNIT specification at %L must be an INTEGER expression "
2791 "or a CHARACTER variable", &e->where);
2792 return FAILURE;
2793 }
2794 else
2795 {
2796 /* At this point, we have an extra comma. If io_unit has arrived as
2797 type character, we assume its really the "format" form of the I/O
2798 statement. We set the io_unit to the default unit and format to
2799 the character expression. See F95 Standard section 9.4. */
2800 if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
2801 {
2802 dt->format_expr = dt->io_unit;
2803 dt->io_unit = default_unit (k);
2804
2805 /* Nullify this pointer now so that a warning/error is not
2806 triggered below for the "Extension". */
2807 dt->extra_comma = NULL;
2808 }
2809
2810 if (k == M_WRITE)
2811 {
2812 gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
2813 &dt->extra_comma->where);
2814 return FAILURE;
2815 }
2816 }
2817 }
2818
2819 if (e->ts.type == BT_CHARACTER)
2820 {
2821 if (gfc_has_vector_index (e))
2822 {
2823 gfc_error ("Internal unit with vector subscript at %L", &e->where);
2824 return FAILURE;
2825 }
2826
2827 /* If we are writing, make sure the internal unit can be changed. */
2828 gcc_assert (k != M_PRINT);
2829 if (k == M_WRITE
2830 && gfc_check_vardef_context (e, false, _("internal unit in WRITE"))
2831 == FAILURE)
2832 return FAILURE;
2833 }
2834
2835 if (e->rank && e->ts.type != BT_CHARACTER)
2836 {
2837 gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
2838 return FAILURE;
2839 }
2840
2841 if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER
2842 && mpz_sgn (e->value.integer) < 0)
2843 {
2844 gfc_error ("UNIT number in statement at %L must be non-negative",
2845 &e->where);
2846 return FAILURE;
2847 }
2848
2849 /* If we are reading and have a namelist, check that all namelist symbols
2850 can appear in a variable definition context. */
2851 if (k == M_READ && dt->namelist)
2852 {
2853 gfc_namelist* n;
2854 for (n = dt->namelist->namelist; n; n = n->next)
2855 {
2856 gfc_expr* e;
2857 gfc_try t;
2858
2859 e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
2860 t = gfc_check_vardef_context (e, false, NULL);
2861 gfc_free_expr (e);
2862
2863 if (t == FAILURE)
2864 {
2865 gfc_error ("NAMELIST '%s' in READ statement at %L contains"
2866 " the symbol '%s' which may not appear in a"
2867 " variable definition context",
2868 dt->namelist->name, loc, n->sym->name);
2869 return FAILURE;
2870 }
2871 }
2872 }
2873
2874 if (dt->extra_comma
2875 && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before i/o "
2876 "item list at %L", &dt->extra_comma->where) == FAILURE)
2877 return FAILURE;
2878
2879 if (dt->err)
2880 {
2881 if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
2882 return FAILURE;
2883 if (dt->err->defined == ST_LABEL_UNKNOWN)
2884 {
2885 gfc_error ("ERR tag label %d at %L not defined",
2886 dt->err->value, &dt->err_where);
2887 return FAILURE;
2888 }
2889 }
2890
2891 if (dt->end)
2892 {
2893 if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
2894 return FAILURE;
2895 if (dt->end->defined == ST_LABEL_UNKNOWN)
2896 {
2897 gfc_error ("END tag label %d at %L not defined",
2898 dt->end->value, &dt->end_where);
2899 return FAILURE;
2900 }
2901 }
2902
2903 if (dt->eor)
2904 {
2905 if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
2906 return FAILURE;
2907 if (dt->eor->defined == ST_LABEL_UNKNOWN)
2908 {
2909 gfc_error ("EOR tag label %d at %L not defined",
2910 dt->eor->value, &dt->eor_where);
2911 return FAILURE;
2912 }
2913 }
2914
2915 /* Check the format label actually exists. */
2916 if (dt->format_label && dt->format_label != &format_asterisk
2917 && dt->format_label->defined == ST_LABEL_UNKNOWN)
2918 {
2919 gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
2920 &dt->format_label->where);
2921 return FAILURE;
2922 }
2923
2924 return SUCCESS;
2925 }
2926
2927
2928 /* Given an io_kind, return its name. */
2929
2930 static const char *
2931 io_kind_name (io_kind k)
2932 {
2933 const char *name;
2934
2935 switch (k)
2936 {
2937 case M_READ:
2938 name = "READ";
2939 break;
2940 case M_WRITE:
2941 name = "WRITE";
2942 break;
2943 case M_PRINT:
2944 name = "PRINT";
2945 break;
2946 case M_INQUIRE:
2947 name = "INQUIRE";
2948 break;
2949 default:
2950 gfc_internal_error ("io_kind_name(): bad I/O-kind");
2951 }
2952
2953 return name;
2954 }
2955
2956
2957 /* Match an IO iteration statement of the form:
2958
2959 ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
2960
2961 which is equivalent to a single IO element. This function is
2962 mutually recursive with match_io_element(). */
2963
2964 static match match_io_element (io_kind, gfc_code **);
2965
2966 static match
2967 match_io_iterator (io_kind k, gfc_code **result)
2968 {
2969 gfc_code *head, *tail, *new_code;
2970 gfc_iterator *iter;
2971 locus old_loc;
2972 match m;
2973 int n;
2974
2975 iter = NULL;
2976 head = NULL;
2977 old_loc = gfc_current_locus;
2978
2979 if (gfc_match_char ('(') != MATCH_YES)
2980 return MATCH_NO;
2981
2982 m = match_io_element (k, &head);
2983 tail = head;
2984
2985 if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
2986 {
2987 m = MATCH_NO;
2988 goto cleanup;
2989 }
2990
2991 /* Can't be anything but an IO iterator. Build a list. */
2992 iter = gfc_get_iterator ();
2993
2994 for (n = 1;; n++)
2995 {
2996 m = gfc_match_iterator (iter, 0);
2997 if (m == MATCH_ERROR)
2998 goto cleanup;
2999 if (m == MATCH_YES)
3000 {
3001 gfc_check_do_variable (iter->var->symtree);
3002 break;
3003 }
3004
3005 m = match_io_element (k, &new_code);
3006 if (m == MATCH_ERROR)
3007 goto cleanup;
3008 if (m == MATCH_NO)
3009 {
3010 if (n > 2)
3011 goto syntax;
3012 goto cleanup;
3013 }
3014
3015 tail = gfc_append_code (tail, new_code);
3016
3017 if (gfc_match_char (',') != MATCH_YES)
3018 {
3019 if (n > 2)
3020 goto syntax;
3021 m = MATCH_NO;
3022 goto cleanup;
3023 }
3024 }
3025
3026 if (gfc_match_char (')') != MATCH_YES)
3027 goto syntax;
3028
3029 new_code = gfc_get_code ();
3030 new_code->op = EXEC_DO;
3031 new_code->ext.iterator = iter;
3032
3033 new_code->block = gfc_get_code ();
3034 new_code->block->op = EXEC_DO;
3035 new_code->block->next = head;
3036
3037 *result = new_code;
3038 return MATCH_YES;
3039
3040 syntax:
3041 gfc_error ("Syntax error in I/O iterator at %C");
3042 m = MATCH_ERROR;
3043
3044 cleanup:
3045 gfc_free_iterator (iter, 1);
3046 gfc_free_statements (head);
3047 gfc_current_locus = old_loc;
3048 return m;
3049 }
3050
3051
3052 /* Match a single element of an IO list, which is either a single
3053 expression or an IO Iterator. */
3054
3055 static match
3056 match_io_element (io_kind k, gfc_code **cpp)
3057 {
3058 gfc_expr *expr;
3059 gfc_code *cp;
3060 match m;
3061
3062 expr = NULL;
3063
3064 m = match_io_iterator (k, cpp);
3065 if (m == MATCH_YES)
3066 return MATCH_YES;
3067
3068 if (k == M_READ)
3069 {
3070 m = gfc_match_variable (&expr, 0);
3071 if (m == MATCH_NO)
3072 gfc_error ("Expected variable in READ statement at %C");
3073 }
3074 else
3075 {
3076 m = gfc_match_expr (&expr);
3077 if (m == MATCH_NO)
3078 gfc_error ("Expected expression in %s statement at %C",
3079 io_kind_name (k));
3080 }
3081
3082 if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree))
3083 m = MATCH_ERROR;
3084
3085 if (m != MATCH_YES)
3086 {
3087 gfc_free_expr (expr);
3088 return MATCH_ERROR;
3089 }
3090
3091 cp = gfc_get_code ();
3092 cp->op = EXEC_TRANSFER;
3093 cp->expr1 = expr;
3094 if (k != M_INQUIRE)
3095 cp->ext.dt = current_dt;
3096
3097 *cpp = cp;
3098 return MATCH_YES;
3099 }
3100
3101
3102 /* Match an I/O list, building gfc_code structures as we go. */
3103
3104 static match
3105 match_io_list (io_kind k, gfc_code **head_p)
3106 {
3107 gfc_code *head, *tail, *new_code;
3108 match m;
3109
3110 *head_p = head = tail = NULL;
3111 if (gfc_match_eos () == MATCH_YES)
3112 return MATCH_YES;
3113
3114 for (;;)
3115 {
3116 m = match_io_element (k, &new_code);
3117 if (m == MATCH_ERROR)
3118 goto cleanup;
3119 if (m == MATCH_NO)
3120 goto syntax;
3121
3122 tail = gfc_append_code (tail, new_code);
3123 if (head == NULL)
3124 head = new_code;
3125
3126 if (gfc_match_eos () == MATCH_YES)
3127 break;
3128 if (gfc_match_char (',') != MATCH_YES)
3129 goto syntax;
3130 }
3131
3132 *head_p = head;
3133 return MATCH_YES;
3134
3135 syntax:
3136 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3137
3138 cleanup:
3139 gfc_free_statements (head);
3140 return MATCH_ERROR;
3141 }
3142
3143
3144 /* Attach the data transfer end node. */
3145
3146 static void
3147 terminate_io (gfc_code *io_code)
3148 {
3149 gfc_code *c;
3150
3151 if (io_code == NULL)
3152 io_code = new_st.block;
3153
3154 c = gfc_get_code ();
3155 c->op = EXEC_DT_END;
3156
3157 /* Point to structure that is already there */
3158 c->ext.dt = new_st.ext.dt;
3159 gfc_append_code (io_code, c);
3160 }
3161
3162
3163 /* Check the constraints for a data transfer statement. The majority of the
3164 constraints appearing in 9.4 of the standard appear here. Some are handled
3165 in resolve_tag and others in gfc_resolve_dt. */
3166
3167 static match
3168 check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
3169 locus *spec_end)
3170 {
3171 #define io_constraint(condition,msg,arg)\
3172 if (condition) \
3173 {\
3174 gfc_error(msg,arg);\
3175 m = MATCH_ERROR;\
3176 }
3177
3178 match m;
3179 gfc_expr *expr;
3180 gfc_symbol *sym = NULL;
3181 bool warn, unformatted;
3182
3183 warn = (dt->err || dt->iostat) ? true : false;
3184 unformatted = dt->format_expr == NULL && dt->format_label == NULL
3185 && dt->namelist == NULL;
3186
3187 m = MATCH_YES;
3188
3189 expr = dt->io_unit;
3190 if (expr && expr->expr_type == EXPR_VARIABLE
3191 && expr->ts.type == BT_CHARACTER)
3192 {
3193 sym = expr->symtree->n.sym;
3194
3195 io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
3196 "Internal file at %L must not be INTENT(IN)",
3197 &expr->where);
3198
3199 io_constraint (gfc_has_vector_index (dt->io_unit),
3200 "Internal file incompatible with vector subscript at %L",
3201 &expr->where);
3202
3203 io_constraint (dt->rec != NULL,
3204 "REC tag at %L is incompatible with internal file",
3205 &dt->rec->where);
3206
3207 io_constraint (dt->pos != NULL,
3208 "POS tag at %L is incompatible with internal file",
3209 &dt->pos->where);
3210
3211 io_constraint (unformatted,
3212 "Unformatted I/O not allowed with internal unit at %L",
3213 &dt->io_unit->where);
3214
3215 io_constraint (dt->asynchronous != NULL,
3216 "ASYNCHRONOUS tag at %L not allowed with internal file",
3217 &dt->asynchronous->where);
3218
3219 if (dt->namelist != NULL)
3220 {
3221 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Internal file "
3222 "at %L with namelist", &expr->where)
3223 == FAILURE)
3224 m = MATCH_ERROR;
3225 }
3226
3227 io_constraint (dt->advance != NULL,
3228 "ADVANCE tag at %L is incompatible with internal file",
3229 &dt->advance->where);
3230 }
3231
3232 if (expr && expr->ts.type != BT_CHARACTER)
3233 {
3234
3235 io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE),
3236 "IO UNIT in %s statement at %C must be "
3237 "an internal file in a PURE procedure",
3238 io_kind_name (k));
3239
3240 if (gfc_implicit_pure (NULL) && (k == M_READ || k == M_WRITE))
3241 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3242
3243 }
3244
3245 if (k != M_READ)
3246 {
3247 io_constraint (dt->end, "END tag not allowed with output at %L",
3248 &dt->end_where);
3249
3250 io_constraint (dt->eor, "EOR tag not allowed with output at %L",
3251 &dt->eor_where);
3252
3253 io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L",
3254 &dt->blank->where);
3255
3256 io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
3257 &dt->pad->where);
3258
3259 io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
3260 &dt->size->where);
3261 }
3262 else
3263 {
3264 io_constraint (dt->size && dt->advance == NULL,
3265 "SIZE tag at %L requires an ADVANCE tag",
3266 &dt->size->where);
3267
3268 io_constraint (dt->eor && dt->advance == NULL,
3269 "EOR tag at %L requires an ADVANCE tag",
3270 &dt->eor_where);
3271 }
3272
3273 if (dt->asynchronous)
3274 {
3275 static const char * asynchronous[] = { "YES", "NO", NULL };
3276
3277 if (gfc_reduce_init_expr (dt->asynchronous) != SUCCESS)
3278 {
3279 gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3280 "expression", &dt->asynchronous->where);
3281 return MATCH_ERROR;
3282 }
3283
3284 if (!compare_to_allowed_values
3285 ("ASYNCHRONOUS", asynchronous, NULL, NULL,
3286 dt->asynchronous->value.character.string,
3287 io_kind_name (k), warn))
3288 return MATCH_ERROR;
3289 }
3290
3291 if (dt->id)
3292 {
3293 bool not_yes
3294 = !dt->asynchronous
3295 || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
3296 || gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
3297 "yes", 3) != 0;
3298 io_constraint (not_yes,
3299 "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3300 "specifier", &dt->id->where);
3301 }
3302
3303 if (dt->decimal)
3304 {
3305 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
3306 "not allowed in Fortran 95") == FAILURE)
3307 return MATCH_ERROR;
3308
3309 if (dt->decimal->expr_type == EXPR_CONSTANT)
3310 {
3311 static const char * decimal[] = { "COMMA", "POINT", NULL };
3312
3313 if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
3314 dt->decimal->value.character.string,
3315 io_kind_name (k), warn))
3316 return MATCH_ERROR;
3317
3318 io_constraint (unformatted,
3319 "the DECIMAL= specifier at %L must be with an "
3320 "explicit format expression", &dt->decimal->where);
3321 }
3322 }
3323
3324 if (dt->blank)
3325 {
3326 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
3327 "not allowed in Fortran 95") == FAILURE)
3328 return MATCH_ERROR;
3329
3330 if (dt->blank->expr_type == EXPR_CONSTANT)
3331 {
3332 static const char * blank[] = { "NULL", "ZERO", NULL };
3333
3334 if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
3335 dt->blank->value.character.string,
3336 io_kind_name (k), warn))
3337 return MATCH_ERROR;
3338
3339 io_constraint (unformatted,
3340 "the BLANK= specifier at %L must be with an "
3341 "explicit format expression", &dt->blank->where);
3342 }
3343 }
3344
3345 if (dt->pad)
3346 {
3347 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PAD= at %C "
3348 "not allowed in Fortran 95") == FAILURE)
3349 return MATCH_ERROR;
3350
3351 if (dt->pad->expr_type == EXPR_CONSTANT)
3352 {
3353 static const char * pad[] = { "YES", "NO", NULL };
3354
3355 if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
3356 dt->pad->value.character.string,
3357 io_kind_name (k), warn))
3358 return MATCH_ERROR;
3359
3360 io_constraint (unformatted,
3361 "the PAD= specifier at %L must be with an "
3362 "explicit format expression", &dt->pad->where);
3363 }
3364 }
3365
3366 if (dt->round)
3367 {
3368 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ROUND= at %C "
3369 "not allowed in Fortran 95") == FAILURE)
3370 return MATCH_ERROR;
3371
3372 if (dt->round->expr_type == EXPR_CONSTANT)
3373 {
3374 static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
3375 "COMPATIBLE", "PROCESSOR_DEFINED",
3376 NULL };
3377
3378 if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
3379 dt->round->value.character.string,
3380 io_kind_name (k), warn))
3381 return MATCH_ERROR;
3382 }
3383 }
3384
3385 if (dt->sign)
3386 {
3387 /* When implemented, change the following to use gfc_notify_std F2003.
3388 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
3389 "not allowed in Fortran 95") == FAILURE)
3390 return MATCH_ERROR; */
3391 if (dt->sign->expr_type == EXPR_CONSTANT)
3392 {
3393 static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3394 NULL };
3395
3396 if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
3397 dt->sign->value.character.string,
3398 io_kind_name (k), warn))
3399 return MATCH_ERROR;
3400
3401 io_constraint (unformatted,
3402 "SIGN= specifier at %L must be with an "
3403 "explicit format expression", &dt->sign->where);
3404
3405 io_constraint (k == M_READ,
3406 "SIGN= specifier at %L not allowed in a "
3407 "READ statement", &dt->sign->where);
3408 }
3409 }
3410
3411 if (dt->delim)
3412 {
3413 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
3414 "not allowed in Fortran 95") == FAILURE)
3415 return MATCH_ERROR;
3416
3417 if (dt->delim->expr_type == EXPR_CONSTANT)
3418 {
3419 static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
3420
3421 if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
3422 dt->delim->value.character.string,
3423 io_kind_name (k), warn))
3424 return MATCH_ERROR;
3425
3426 io_constraint (k == M_READ,
3427 "DELIM= specifier at %L not allowed in a "
3428 "READ statement", &dt->delim->where);
3429
3430 io_constraint (dt->format_label != &format_asterisk
3431 && dt->namelist == NULL,
3432 "DELIM= specifier at %L must have FMT=*",
3433 &dt->delim->where);
3434
3435 io_constraint (unformatted && dt->namelist == NULL,
3436 "DELIM= specifier at %L must be with FMT=* or "
3437 "NML= specifier ", &dt->delim->where);
3438 }
3439 }
3440
3441 if (dt->namelist)
3442 {
3443 io_constraint (io_code && dt->namelist,
3444 "NAMELIST cannot be followed by IO-list at %L",
3445 &io_code->loc);
3446
3447 io_constraint (dt->format_expr,
3448 "IO spec-list cannot contain both NAMELIST group name "
3449 "and format specification at %L",
3450 &dt->format_expr->where);
3451
3452 io_constraint (dt->format_label,
3453 "IO spec-list cannot contain both NAMELIST group name "
3454 "and format label at %L", spec_end);
3455
3456 io_constraint (dt->rec,
3457 "NAMELIST IO is not allowed with a REC= specifier "
3458 "at %L", &dt->rec->where);
3459
3460 io_constraint (dt->advance,
3461 "NAMELIST IO is not allowed with a ADVANCE= specifier "
3462 "at %L", &dt->advance->where);
3463 }
3464
3465 if (dt->rec)
3466 {
3467 io_constraint (dt->end,
3468 "An END tag is not allowed with a "
3469 "REC= specifier at %L", &dt->end_where);
3470
3471 io_constraint (dt->format_label == &format_asterisk,
3472 "FMT=* is not allowed with a REC= specifier "
3473 "at %L", spec_end);
3474
3475 io_constraint (dt->pos,
3476 "POS= is not allowed with REC= specifier "
3477 "at %L", &dt->pos->where);
3478 }
3479
3480 if (dt->advance)
3481 {
3482 int not_yes, not_no;
3483 expr = dt->advance;
3484
3485 io_constraint (dt->format_label == &format_asterisk,
3486 "List directed format(*) is not allowed with a "
3487 "ADVANCE= specifier at %L.", &expr->where);
3488
3489 io_constraint (unformatted,
3490 "the ADVANCE= specifier at %L must appear with an "
3491 "explicit format expression", &expr->where);
3492
3493 if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
3494 {
3495 const gfc_char_t *advance = expr->value.character.string;
3496 not_no = gfc_wide_strlen (advance) != 2
3497 || gfc_wide_strncasecmp (advance, "no", 2) != 0;
3498 not_yes = gfc_wide_strlen (advance) != 3
3499 || gfc_wide_strncasecmp (advance, "yes", 3) != 0;
3500 }
3501 else
3502 {
3503 not_no = 0;
3504 not_yes = 0;
3505 }
3506
3507 io_constraint (not_no && not_yes,
3508 "ADVANCE= specifier at %L must have value = "
3509 "YES or NO.", &expr->where);
3510
3511 io_constraint (dt->size && not_no && k == M_READ,
3512 "SIZE tag at %L requires an ADVANCE = 'NO'",
3513 &dt->size->where);
3514
3515 io_constraint (dt->eor && not_no && k == M_READ,
3516 "EOR tag at %L requires an ADVANCE = 'NO'",
3517 &dt->eor_where);
3518 }
3519
3520 expr = dt->format_expr;
3521 if (gfc_simplify_expr (expr, 0) == FAILURE
3522 || check_format_string (expr, k == M_READ) == FAILURE)
3523 return MATCH_ERROR;
3524
3525 return m;
3526 }
3527 #undef io_constraint
3528
3529
3530 /* Match a READ, WRITE or PRINT statement. */
3531
3532 static match
3533 match_io (io_kind k)
3534 {
3535 char name[GFC_MAX_SYMBOL_LEN + 1];
3536 gfc_code *io_code;
3537 gfc_symbol *sym;
3538 int comma_flag;
3539 locus where;
3540 locus spec_end;
3541 gfc_dt *dt;
3542 match m;
3543
3544 where = gfc_current_locus;
3545 comma_flag = 0;
3546 current_dt = dt = XCNEW (gfc_dt);
3547 m = gfc_match_char ('(');
3548 if (m == MATCH_NO)
3549 {
3550 where = gfc_current_locus;
3551 if (k == M_WRITE)
3552 goto syntax;
3553 else if (k == M_PRINT)
3554 {
3555 /* Treat the non-standard case of PRINT namelist. */
3556 if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
3557 && gfc_match_name (name) == MATCH_YES)
3558 {
3559 gfc_find_symbol (name, NULL, 1, &sym);
3560 if (sym && sym->attr.flavor == FL_NAMELIST)
3561 {
3562 if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
3563 "%C is an extension") == FAILURE)
3564 {
3565 m = MATCH_ERROR;
3566 goto cleanup;
3567 }
3568
3569 dt->io_unit = default_unit (k);
3570 dt->namelist = sym;
3571 goto get_io_list;
3572 }
3573 else
3574 gfc_current_locus = where;
3575 }
3576 }
3577
3578 if (gfc_current_form == FORM_FREE)
3579 {
3580 char c = gfc_peek_ascii_char ();
3581 if (c != ' ' && c != '*' && c != '\'' && c != '"')
3582 {
3583 m = MATCH_NO;
3584 goto cleanup;
3585 }
3586 }
3587
3588 m = match_dt_format (dt);
3589 if (m == MATCH_ERROR)
3590 goto cleanup;
3591 if (m == MATCH_NO)
3592 goto syntax;
3593
3594 comma_flag = 1;
3595 dt->io_unit = default_unit (k);
3596 goto get_io_list;
3597 }
3598 else
3599 {
3600 /* Before issuing an error for a malformed 'print (1,*)' type of
3601 error, check for a default-char-expr of the form ('(I0)'). */
3602 if (k == M_PRINT && m == MATCH_YES)
3603 {
3604 /* Reset current locus to get the initial '(' in an expression. */
3605 gfc_current_locus = where;
3606 dt->format_expr = NULL;
3607 m = match_dt_format (dt);
3608
3609 if (m == MATCH_ERROR)
3610 goto cleanup;
3611 if (m == MATCH_NO || dt->format_expr == NULL)
3612 goto syntax;
3613
3614 comma_flag = 1;
3615 dt->io_unit = default_unit (k);
3616 goto get_io_list;
3617 }
3618 }
3619
3620 /* Match a control list */
3621 if (match_dt_element (k, dt) == MATCH_YES)
3622 goto next;
3623 if (match_dt_unit (k, dt) != MATCH_YES)
3624 goto loop;
3625
3626 if (gfc_match_char (')') == MATCH_YES)
3627 goto get_io_list;
3628 if (gfc_match_char (',') != MATCH_YES)
3629 goto syntax;
3630
3631 m = match_dt_element (k, dt);
3632 if (m == MATCH_YES)
3633 goto next;
3634 if (m == MATCH_ERROR)
3635 goto cleanup;
3636
3637 m = match_dt_format (dt);
3638 if (m == MATCH_YES)
3639 goto next;
3640 if (m == MATCH_ERROR)
3641 goto cleanup;
3642
3643 where = gfc_current_locus;
3644
3645 m = gfc_match_name (name);
3646 if (m == MATCH_YES)
3647 {
3648 gfc_find_symbol (name, NULL, 1, &sym);
3649 if (sym && sym->attr.flavor == FL_NAMELIST)
3650 {
3651 dt->namelist = sym;
3652 if (k == M_READ && check_namelist (sym))
3653 {
3654 m = MATCH_ERROR;
3655 goto cleanup;
3656 }
3657 goto next;
3658 }
3659 }
3660
3661 gfc_current_locus = where;
3662
3663 goto loop; /* No matches, try regular elements */
3664
3665 next:
3666 if (gfc_match_char (')') == MATCH_YES)
3667 goto get_io_list;
3668 if (gfc_match_char (',') != MATCH_YES)
3669 goto syntax;
3670
3671 loop:
3672 for (;;)
3673 {
3674 m = match_dt_element (k, dt);
3675 if (m == MATCH_NO)
3676 goto syntax;
3677 if (m == MATCH_ERROR)
3678 goto cleanup;
3679
3680 if (gfc_match_char (')') == MATCH_YES)
3681 break;
3682 if (gfc_match_char (',') != MATCH_YES)
3683 goto syntax;
3684 }
3685
3686 get_io_list:
3687
3688 /* Used in check_io_constraints, where no locus is available. */
3689 spec_end = gfc_current_locus;
3690
3691 /* Save the IO kind for later use. */
3692 dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k);
3693
3694 /* Optional leading comma (non-standard). We use a gfc_expr structure here
3695 to save the locus. This is used later when resolving transfer statements
3696 that might have a format expression without unit number. */
3697 if (!comma_flag && gfc_match_char (',') == MATCH_YES)
3698 dt->extra_comma = dt->dt_io_kind;
3699
3700 io_code = NULL;
3701 if (gfc_match_eos () != MATCH_YES)
3702 {
3703 if (comma_flag && gfc_match_char (',') != MATCH_YES)
3704 {
3705 gfc_error ("Expected comma in I/O list at %C");
3706 m = MATCH_ERROR;
3707 goto cleanup;
3708 }
3709
3710 m = match_io_list (k, &io_code);
3711 if (m == MATCH_ERROR)
3712 goto cleanup;
3713 if (m == MATCH_NO)
3714 goto syntax;
3715 }
3716
3717 /* A full IO statement has been matched. Check the constraints. spec_end is
3718 supplied for cases where no locus is supplied. */
3719 m = check_io_constraints (k, dt, io_code, &spec_end);
3720
3721 if (m == MATCH_ERROR)
3722 goto cleanup;
3723
3724 new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
3725 new_st.ext.dt = dt;
3726 new_st.block = gfc_get_code ();
3727 new_st.block->op = new_st.op;
3728 new_st.block->next = io_code;
3729
3730 terminate_io (io_code);
3731
3732 return MATCH_YES;
3733
3734 syntax:
3735 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3736 m = MATCH_ERROR;
3737
3738 cleanup:
3739 gfc_free_dt (dt);
3740 return m;
3741 }
3742
3743
3744 match
3745 gfc_match_read (void)
3746 {
3747 return match_io (M_READ);
3748 }
3749
3750
3751 match
3752 gfc_match_write (void)
3753 {
3754 return match_io (M_WRITE);
3755 }
3756
3757
3758 match
3759 gfc_match_print (void)
3760 {
3761 match m;
3762
3763 m = match_io (M_PRINT);
3764 if (m != MATCH_YES)
3765 return m;
3766
3767 if (gfc_pure (NULL))
3768 {
3769 gfc_error ("PRINT statement at %C not allowed within PURE procedure");
3770 return MATCH_ERROR;
3771 }
3772
3773 if (gfc_implicit_pure (NULL))
3774 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3775
3776 return MATCH_YES;
3777 }
3778
3779
3780 /* Free a gfc_inquire structure. */
3781
3782 void
3783 gfc_free_inquire (gfc_inquire *inquire)
3784 {
3785
3786 if (inquire == NULL)
3787 return;
3788
3789 gfc_free_expr (inquire->unit);
3790 gfc_free_expr (inquire->file);
3791 gfc_free_expr (inquire->iomsg);
3792 gfc_free_expr (inquire->iostat);
3793 gfc_free_expr (inquire->exist);
3794 gfc_free_expr (inquire->opened);
3795 gfc_free_expr (inquire->number);
3796 gfc_free_expr (inquire->named);
3797 gfc_free_expr (inquire->name);
3798 gfc_free_expr (inquire->access);
3799 gfc_free_expr (inquire->sequential);
3800 gfc_free_expr (inquire->direct);
3801 gfc_free_expr (inquire->form);
3802 gfc_free_expr (inquire->formatted);
3803 gfc_free_expr (inquire->unformatted);
3804 gfc_free_expr (inquire->recl);
3805 gfc_free_expr (inquire->nextrec);
3806 gfc_free_expr (inquire->blank);
3807 gfc_free_expr (inquire->position);
3808 gfc_free_expr (inquire->action);
3809 gfc_free_expr (inquire->read);
3810 gfc_free_expr (inquire->write);
3811 gfc_free_expr (inquire->readwrite);
3812 gfc_free_expr (inquire->delim);
3813 gfc_free_expr (inquire->encoding);
3814 gfc_free_expr (inquire->pad);
3815 gfc_free_expr (inquire->iolength);
3816 gfc_free_expr (inquire->convert);
3817 gfc_free_expr (inquire->strm_pos);
3818 gfc_free_expr (inquire->asynchronous);
3819 gfc_free_expr (inquire->decimal);
3820 gfc_free_expr (inquire->pending);
3821 gfc_free_expr (inquire->id);
3822 gfc_free_expr (inquire->sign);
3823 gfc_free_expr (inquire->size);
3824 gfc_free_expr (inquire->round);
3825 gfc_free (inquire);
3826 }
3827
3828
3829 /* Match an element of an INQUIRE statement. */
3830
3831 #define RETM if (m != MATCH_NO) return m;
3832
3833 static match
3834 match_inquire_element (gfc_inquire *inquire)
3835 {
3836 match m;
3837
3838 m = match_etag (&tag_unit, &inquire->unit);
3839 RETM m = match_etag (&tag_file, &inquire->file);
3840 RETM m = match_ltag (&tag_err, &inquire->err);
3841 RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg);
3842 RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
3843 RETM m = match_vtag (&tag_exist, &inquire->exist);
3844 RETM m = match_vtag (&tag_opened, &inquire->opened);
3845 RETM m = match_vtag (&tag_named, &inquire->named);
3846 RETM m = match_vtag (&tag_name, &inquire->name);
3847 RETM m = match_out_tag (&tag_number, &inquire->number);
3848 RETM m = match_vtag (&tag_s_access, &inquire->access);
3849 RETM m = match_vtag (&tag_sequential, &inquire->sequential);
3850 RETM m = match_vtag (&tag_direct, &inquire->direct);
3851 RETM m = match_vtag (&tag_s_form, &inquire->form);
3852 RETM m = match_vtag (&tag_formatted, &inquire->formatted);
3853 RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
3854 RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
3855 RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
3856 RETM m = match_vtag (&tag_s_blank, &inquire->blank);
3857 RETM m = match_vtag (&tag_s_position, &inquire->position);
3858 RETM m = match_vtag (&tag_s_action, &inquire->action);
3859 RETM m = match_vtag (&tag_read, &inquire->read);
3860 RETM m = match_vtag (&tag_write, &inquire->write);
3861 RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
3862 RETM m = match_vtag (&tag_s_async, &inquire->asynchronous);
3863 RETM m = match_vtag (&tag_s_delim, &inquire->delim);
3864 RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
3865 RETM m = match_vtag (&tag_size, &inquire->size);
3866 RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
3867 RETM m = match_vtag (&tag_s_round, &inquire->round);
3868 RETM m = match_vtag (&tag_s_sign, &inquire->sign);
3869 RETM m = match_vtag (&tag_s_pad, &inquire->pad);
3870 RETM m = match_vtag (&tag_iolength, &inquire->iolength);
3871 RETM m = match_vtag (&tag_convert, &inquire->convert);
3872 RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
3873 RETM m = match_vtag (&tag_pending, &inquire->pending);
3874 RETM m = match_vtag (&tag_id, &inquire->id);
3875 RETM return MATCH_NO;
3876 }
3877
3878 #undef RETM
3879
3880
3881 match
3882 gfc_match_inquire (void)
3883 {
3884 gfc_inquire *inquire;
3885 gfc_code *code;
3886 match m;
3887 locus loc;
3888
3889 m = gfc_match_char ('(');
3890 if (m == MATCH_NO)
3891 return m;
3892
3893 inquire = XCNEW (gfc_inquire);
3894
3895 loc = gfc_current_locus;
3896
3897 m = match_inquire_element (inquire);
3898 if (m == MATCH_ERROR)
3899 goto cleanup;
3900 if (m == MATCH_NO)
3901 {
3902 m = gfc_match_expr (&inquire->unit);
3903 if (m == MATCH_ERROR)
3904 goto cleanup;
3905 if (m == MATCH_NO)
3906 goto syntax;
3907 }
3908
3909 /* See if we have the IOLENGTH form of the inquire statement. */
3910 if (inquire->iolength != NULL)
3911 {
3912 if (gfc_match_char (')') != MATCH_YES)
3913 goto syntax;
3914
3915 m = match_io_list (M_INQUIRE, &code);
3916 if (m == MATCH_ERROR)
3917 goto cleanup;
3918 if (m == MATCH_NO)
3919 goto syntax;
3920
3921 new_st.op = EXEC_IOLENGTH;
3922 new_st.expr1 = inquire->iolength;
3923 new_st.ext.inquire = inquire;
3924
3925 if (gfc_pure (NULL))
3926 {
3927 gfc_free_statements (code);
3928 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3929 return MATCH_ERROR;
3930 }
3931
3932 if (gfc_implicit_pure (NULL))
3933 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3934
3935 new_st.block = gfc_get_code ();
3936 new_st.block->op = EXEC_IOLENGTH;
3937 terminate_io (code);
3938 new_st.block->next = code;
3939 return MATCH_YES;
3940 }
3941
3942 /* At this point, we have the non-IOLENGTH inquire statement. */
3943 for (;;)
3944 {
3945 if (gfc_match_char (')') == MATCH_YES)
3946 break;
3947 if (gfc_match_char (',') != MATCH_YES)
3948 goto syntax;
3949
3950 m = match_inquire_element (inquire);
3951 if (m == MATCH_ERROR)
3952 goto cleanup;
3953 if (m == MATCH_NO)
3954 goto syntax;
3955
3956 if (inquire->iolength != NULL)
3957 {
3958 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
3959 goto cleanup;
3960 }
3961 }
3962
3963 if (gfc_match_eos () != MATCH_YES)
3964 goto syntax;
3965
3966 if (inquire->unit != NULL && inquire->file != NULL)
3967 {
3968 gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
3969 "UNIT specifiers", &loc);
3970 goto cleanup;
3971 }
3972
3973 if (inquire->unit == NULL && inquire->file == NULL)
3974 {
3975 gfc_error ("INQUIRE statement at %L requires either FILE or "
3976 "UNIT specifier", &loc);
3977 goto cleanup;
3978 }
3979
3980 if (gfc_pure (NULL))
3981 {
3982 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3983 goto cleanup;
3984 }
3985
3986 if (gfc_implicit_pure (NULL))
3987 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3988
3989 if (inquire->id != NULL && inquire->pending == NULL)
3990 {
3991 gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
3992 "the ID= specifier", &loc);
3993 goto cleanup;
3994 }
3995
3996 new_st.op = EXEC_INQUIRE;
3997 new_st.ext.inquire = inquire;
3998 return MATCH_YES;
3999
4000 syntax:
4001 gfc_syntax_error (ST_INQUIRE);
4002
4003 cleanup:
4004 gfc_free_inquire (inquire);
4005 return MATCH_ERROR;
4006 }
4007
4008
4009 /* Resolve everything in a gfc_inquire structure. */
4010
4011 gfc_try
4012 gfc_resolve_inquire (gfc_inquire *inquire)
4013 {
4014 RESOLVE_TAG (&tag_unit, inquire->unit);
4015 RESOLVE_TAG (&tag_file, inquire->file);
4016 RESOLVE_TAG (&tag_id, inquire->id);
4017
4018 /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4019 contexts. Thus, use an extended RESOLVE_TAG macro for that. */
4020 #define INQUIRE_RESOLVE_TAG(tag, expr) \
4021 RESOLVE_TAG (tag, expr); \
4022 if (expr) \
4023 { \
4024 char context[64]; \
4025 sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
4026 if (gfc_check_vardef_context ((expr), false, context) == FAILURE) \
4027 return FAILURE; \
4028 }
4029 INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
4030 INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat);
4031 INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist);
4032 INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened);
4033 INQUIRE_RESOLVE_TAG (&tag_number, inquire->number);
4034 INQUIRE_RESOLVE_TAG (&tag_named, inquire->named);
4035 INQUIRE_RESOLVE_TAG (&tag_name, inquire->name);
4036 INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access);
4037 INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential);
4038 INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct);
4039 INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form);
4040 INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted);
4041 INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
4042 INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl);
4043 INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
4044 INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank);
4045 INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position);
4046 INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action);
4047 INQUIRE_RESOLVE_TAG (&tag_read, inquire->read);
4048 INQUIRE_RESOLVE_TAG (&tag_write, inquire->write);
4049 INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
4050 INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim);
4051 INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad);
4052 INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
4053 INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4054 INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength);
4055 INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert);
4056 INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
4057 INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
4058 INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign);
4059 INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4060 INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending);
4061 INQUIRE_RESOLVE_TAG (&tag_size, inquire->size);
4062 #undef INQUIRE_RESOLVE_TAG
4063
4064 if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
4065 return FAILURE;
4066
4067 return SUCCESS;
4068 }
4069
4070
4071 void
4072 gfc_free_wait (gfc_wait *wait)
4073 {
4074 if (wait == NULL)
4075 return;
4076
4077 gfc_free_expr (wait->unit);
4078 gfc_free_expr (wait->iostat);
4079 gfc_free_expr (wait->iomsg);
4080 gfc_free_expr (wait->id);
4081 }
4082
4083
4084 gfc_try
4085 gfc_resolve_wait (gfc_wait *wait)
4086 {
4087 RESOLVE_TAG (&tag_unit, wait->unit);
4088 RESOLVE_TAG (&tag_iomsg, wait->iomsg);
4089 RESOLVE_TAG (&tag_iostat, wait->iostat);
4090 RESOLVE_TAG (&tag_id, wait->id);
4091
4092 if (gfc_reference_st_label (wait->err, ST_LABEL_TARGET) == FAILURE)
4093 return FAILURE;
4094
4095 if (gfc_reference_st_label (wait->end, ST_LABEL_TARGET) == FAILURE)
4096 return FAILURE;
4097
4098 return SUCCESS;
4099 }
4100
4101 /* Match an element of a WAIT statement. */
4102
4103 #define RETM if (m != MATCH_NO) return m;
4104
4105 static match
4106 match_wait_element (gfc_wait *wait)
4107 {
4108 match m;
4109
4110 m = match_etag (&tag_unit, &wait->unit);
4111 RETM m = match_ltag (&tag_err, &wait->err);
4112 RETM m = match_ltag (&tag_end, &wait->eor);
4113 RETM m = match_ltag (&tag_eor, &wait->end);
4114 RETM m = match_out_tag (&tag_iomsg, &wait->iomsg);
4115 RETM m = match_out_tag (&tag_iostat, &wait->iostat);
4116 RETM m = match_etag (&tag_id, &wait->id);
4117 RETM return MATCH_NO;
4118 }
4119
4120 #undef RETM
4121
4122
4123 match
4124 gfc_match_wait (void)
4125 {
4126 gfc_wait *wait;
4127 match m;
4128
4129 m = gfc_match_char ('(');
4130 if (m == MATCH_NO)
4131 return m;
4132
4133 wait = XCNEW (gfc_wait);
4134
4135 m = match_wait_element (wait);
4136 if (m == MATCH_ERROR)
4137 goto cleanup;
4138 if (m == MATCH_NO)
4139 {
4140 m = gfc_match_expr (&wait->unit);
4141 if (m == MATCH_ERROR)
4142 goto cleanup;
4143 if (m == MATCH_NO)
4144 goto syntax;
4145 }
4146
4147 for (;;)
4148 {
4149 if (gfc_match_char (')') == MATCH_YES)
4150 break;
4151 if (gfc_match_char (',') != MATCH_YES)
4152 goto syntax;
4153
4154 m = match_wait_element (wait);
4155 if (m == MATCH_ERROR)
4156 goto cleanup;
4157 if (m == MATCH_NO)
4158 goto syntax;
4159 }
4160
4161 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: WAIT at %C "
4162 "not allowed in Fortran 95") == FAILURE)
4163 goto cleanup;
4164
4165 if (gfc_pure (NULL))
4166 {
4167 gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4168 goto cleanup;
4169 }
4170
4171 if (gfc_implicit_pure (NULL))
4172 gfc_current_ns->proc_name->attr.implicit_pure = 0;
4173
4174 new_st.op = EXEC_WAIT;
4175 new_st.ext.wait = wait;
4176
4177 return MATCH_YES;
4178
4179 syntax:
4180 gfc_syntax_error (ST_WAIT);
4181
4182 cleanup:
4183 gfc_free_wait (wait);
4184 return MATCH_ERROR;
4185 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org