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