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