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