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