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