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