1 /* Deal with I/O statements & related stuff.
2 Copyright (C) 2000-2015 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
30 format_asterisk
= {0, NULL
, NULL
, -1, ST_LABEL_FORMAT
, ST_LABEL_FORMAT
, NULL
,
31 0, {NULL
, NULL
}, NULL
};
35 const char *name
, *spec
, *value
;
41 tag_file
= {"FILE", " file =", " %e", BT_CHARACTER
},
42 tag_status
= {"STATUS", " status =", " %e", BT_CHARACTER
},
43 tag_e_access
= {"ACCESS", " access =", " %e", BT_CHARACTER
},
44 tag_e_form
= {"FORM", " form =", " %e", BT_CHARACTER
},
45 tag_e_recl
= {"RECL", " recl =", " %e", BT_INTEGER
},
46 tag_e_blank
= {"BLANK", " blank =", " %e", BT_CHARACTER
},
47 tag_e_position
= {"POSITION", " position =", " %e", BT_CHARACTER
},
48 tag_e_action
= {"ACTION", " action =", " %e", BT_CHARACTER
},
49 tag_e_delim
= {"DELIM", " delim =", " %e", BT_CHARACTER
},
50 tag_e_pad
= {"PAD", " pad =", " %e", BT_CHARACTER
},
51 tag_e_decimal
= {"DECIMAL", " decimal =", " %e", BT_CHARACTER
},
52 tag_e_encoding
= {"ENCODING", " encoding =", " %e", BT_CHARACTER
},
53 tag_e_async
= {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER
},
54 tag_e_round
= {"ROUND", " round =", " %e", BT_CHARACTER
},
55 tag_e_sign
= {"SIGN", " sign =", " %e", BT_CHARACTER
},
56 tag_unit
= {"UNIT", " unit =", " %e", BT_INTEGER
},
57 tag_advance
= {"ADVANCE", " advance =", " %e", BT_CHARACTER
},
58 tag_rec
= {"REC", " rec =", " %e", BT_INTEGER
},
59 tag_spos
= {"POSITION", " pos =", " %e", BT_INTEGER
},
60 tag_format
= {"FORMAT", NULL
, NULL
, BT_CHARACTER
},
61 tag_iomsg
= {"IOMSG", " iomsg =", " %e", BT_CHARACTER
},
62 tag_iostat
= {"IOSTAT", " iostat =", " %v", BT_INTEGER
},
63 tag_size
= {"SIZE", " size =", " %v", BT_INTEGER
},
64 tag_exist
= {"EXIST", " exist =", " %v", BT_LOGICAL
},
65 tag_opened
= {"OPENED", " opened =", " %v", BT_LOGICAL
},
66 tag_named
= {"NAMED", " named =", " %v", BT_LOGICAL
},
67 tag_name
= {"NAME", " name =", " %v", BT_CHARACTER
},
68 tag_number
= {"NUMBER", " number =", " %v", BT_INTEGER
},
69 tag_s_access
= {"ACCESS", " access =", " %v", BT_CHARACTER
},
70 tag_sequential
= {"SEQUENTIAL", " sequential =", " %v", BT_CHARACTER
},
71 tag_direct
= {"DIRECT", " direct =", " %v", BT_CHARACTER
},
72 tag_s_form
= {"FORM", " form =", " %v", BT_CHARACTER
},
73 tag_formatted
= {"FORMATTED", " formatted =", " %v", BT_CHARACTER
},
74 tag_unformatted
= {"UNFORMATTED", " unformatted =", " %v", BT_CHARACTER
},
75 tag_s_recl
= {"RECL", " recl =", " %v", BT_INTEGER
},
76 tag_nextrec
= {"NEXTREC", " nextrec =", " %v", BT_INTEGER
},
77 tag_s_blank
= {"BLANK", " blank =", " %v", BT_CHARACTER
},
78 tag_s_position
= {"POSITION", " position =", " %v", BT_CHARACTER
},
79 tag_s_action
= {"ACTION", " action =", " %v", BT_CHARACTER
},
80 tag_read
= {"READ", " read =", " %v", BT_CHARACTER
},
81 tag_write
= {"WRITE", " write =", " %v", BT_CHARACTER
},
82 tag_readwrite
= {"READWRITE", " readwrite =", " %v", BT_CHARACTER
},
83 tag_s_delim
= {"DELIM", " delim =", " %v", BT_CHARACTER
},
84 tag_s_pad
= {"PAD", " pad =", " %v", BT_CHARACTER
},
85 tag_s_decimal
= {"DECIMAL", " decimal =", " %v", BT_CHARACTER
},
86 tag_s_encoding
= {"ENCODING", " encoding =", " %v", BT_CHARACTER
},
87 tag_s_async
= {"ASYNCHRONOUS", " asynchronous =", " %v", BT_CHARACTER
},
88 tag_s_round
= {"ROUND", " round =", " %v", BT_CHARACTER
},
89 tag_s_sign
= {"SIGN", " sign =", " %v", BT_CHARACTER
},
90 tag_iolength
= {"IOLENGTH", " iolength =", " %v", BT_INTEGER
},
91 tag_convert
= {"CONVERT", " convert =", " %e", BT_CHARACTER
},
92 tag_strm_out
= {"POS", " pos =", " %v", BT_INTEGER
},
93 tag_err
= {"ERR", " err =", " %l", BT_UNKNOWN
},
94 tag_end
= {"END", " end =", " %l", BT_UNKNOWN
},
95 tag_eor
= {"EOR", " eor =", " %l", BT_UNKNOWN
},
96 tag_id
= {"ID", " id =", " %v", BT_INTEGER
},
97 tag_pending
= {"PENDING", " pending =", " %v", BT_LOGICAL
},
98 tag_newunit
= {"NEWUNIT", " newunit =", " %v", BT_INTEGER
},
99 tag_s_iqstream
= {"STREAM", " stream =", " %v", BT_CHARACTER
};
101 static gfc_dt
*current_dt
;
103 #define RESOLVE_TAG(x, y) if (!resolve_tag (x, y)) return false;
106 /**************** Fortran 95 FORMAT parser *****************/
108 /* FORMAT tokens returned by format_lex(). */
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
119 /* Local variables for checking format strings. The saved_token is
120 used to back up by a single format token during the parsing
122 static gfc_char_t
*format_string
;
123 static int format_string_pos
;
124 static int format_length
, use_last_char
;
125 static char error_element
;
126 static locus format_locus
;
128 static format_token saved_token
;
131 { MODE_STRING
, MODE_FORMAT
, MODE_COPY
}
135 /* Return the next character in the format string. */
138 next_char (gfc_instring in_string
)
150 if (mode
== MODE_STRING
)
151 c
= *format_string
++;
154 c
= gfc_next_char_literal (in_string
);
159 if (flag_backslash
&& c
== '\\')
161 locus old_locus
= gfc_current_locus
;
163 if (gfc_match_special_char (&c
) == MATCH_NO
)
164 gfc_current_locus
= old_locus
;
166 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
167 gfc_warning (0, "Extension: backslash character at %C");
170 if (mode
== MODE_COPY
)
171 *format_string
++ = c
;
173 if (mode
!= MODE_STRING
)
174 format_locus
= gfc_current_locus
;
178 c
= gfc_wide_toupper (c
);
183 /* Back up one character position. Only works once. */
191 /* Eat up the spaces and return a character. */
194 next_char_not_space (bool *error
)
199 error_element
= c
= next_char (NONSTRING
);
202 if (gfc_option
.allow_std
& GFC_STD_GNU
)
203 gfc_warning (0, "Extension: Tab character in format at %C");
206 gfc_error ("Extension: Tab character in format at %C");
212 while (gfc_is_whitespace (c
));
216 static int value
= 0;
218 /* Simple lexical analyzer for getting the next token in a FORMAT
230 if (saved_token
!= FMT_NONE
)
233 saved_token
= FMT_NONE
;
237 c
= next_char_not_space (&error
);
247 c
= next_char_not_space (&error
);
258 c
= next_char_not_space (&error
);
260 value
= 10 * value
+ c
- '0';
269 token
= FMT_SIGNED_INT
;
288 c
= next_char_not_space (&error
);
291 value
= 10 * value
+ c
- '0';
299 token
= zflag
? FMT_ZERO
: FMT_POSINT
;
323 c
= next_char_not_space (&error
);
351 c
= next_char_not_space (&error
);
352 if (c
!= 'P' && c
!= 'S')
359 c
= next_char_not_space (&error
);
360 if (c
== 'N' || c
== 'Z')
378 c
= next_char (INSTRING_WARN
);
387 c
= next_char (NONSTRING
);
421 c
= next_char_not_space (&error
);
451 c
= next_char_not_space (&error
);
454 if (!gfc_notify_std (GFC_STD_F2003
, "DP format "
455 "specifier not allowed at %C"))
461 if (!gfc_notify_std (GFC_STD_F2003
, "DC format "
462 "specifier not allowed at %C"))
474 c
= next_char_not_space (&error
);
523 token_to_string (format_token t
)
542 /* Check a format statement. The format string, either from a FORMAT
543 statement or a constant in an I/O statement has already been parsed
544 by itself, and we are checking it for validity. The dual origin
545 means that the warning message is a little less than great. */
548 check_format (bool is_input
)
550 const char *posint_required
= _("Positive width required");
551 const char *nonneg_required
= _("Nonnegative width required");
552 const char *unexpected_element
= _("Unexpected element %<%c%> in format "
554 const char *unexpected_end
= _("Unexpected end of format string");
555 const char *zero_width
= _("Zero width in format descriptor");
564 saved_token
= FMT_NONE
;
568 format_string_pos
= 0;
575 error
= _("Missing leading left parenthesis");
583 goto finished
; /* Empty format is legal */
587 /* In this state, the next thing has to be a format item. */
604 error
= _("Left parenthesis required after %<*%>");
629 /* Signed integer can only precede a P format. */
635 error
= _("Expected P edit descriptor");
642 /* P requires a prior number. */
643 error
= _("P descriptor requires leading scale factor");
647 /* X requires a prior number if we're being pedantic. */
648 if (mode
!= MODE_FORMAT
)
649 format_locus
.nextc
+= format_string_pos
;
650 if (!gfc_notify_std (GFC_STD_GNU
, "X descriptor requires leading "
651 "space count at %L", &format_locus
))
668 goto extension_optional_comma
;
679 if (!gfc_notify_std (GFC_STD_GNU
, "$ descriptor at %L", &format_locus
))
681 if (t
!= FMT_RPAREN
|| level
> 0)
683 gfc_warning (0, "$ should be the last specifier in format at %L",
685 goto optional_comma_1
;
706 error
= unexpected_end
;
710 error
= unexpected_element
;
715 /* In this state, t must currently be a data descriptor.
716 Deal with things that can/must follow the descriptor. */
727 /* No comma after P allowed only for F, E, EN, ES, D, or G.
732 if (!(gfc_option
.allow_std
& GFC_STD_F2003
) && t
!= FMT_COMMA
733 && t
!= FMT_F
&& t
!= FMT_E
&& t
!= FMT_EN
&& t
!= FMT_ES
734 && t
!= FMT_D
&& t
!= FMT_G
&& t
!= FMT_RPAREN
&& t
!= FMT_SLASH
)
736 error
= _("Comma required after P descriptor");
747 if (t
!= FMT_F
&& t
!= FMT_E
&& t
!= FMT_EN
&& t
!= FMT_ES
&& t
!= FMT_D
748 && t
!= FMT_G
&& t
!= FMT_RPAREN
&& t
!= FMT_SLASH
)
750 error
= _("Comma required after P descriptor");
764 error
= _("Positive width required with T descriptor");
776 switch (gfc_notification_std (GFC_STD_GNU
))
779 if (mode
!= MODE_FORMAT
)
780 format_locus
.nextc
+= format_string_pos
;
781 gfc_warning (0, "Extension: Missing positive width after L "
782 "descriptor at %L", &format_locus
);
787 error
= posint_required
;
818 if (t
== FMT_G
&& u
== FMT_ZERO
)
825 if (!gfc_notify_std (GFC_STD_F2008
, "%<G0%> in format at %L",
837 error
= posint_required
;
843 error
= _("E specifier not allowed with g0 descriptor");
852 format_locus
.nextc
+= format_string_pos
;
853 gfc_error ("Positive width required in format "
854 "specifier %s at %L", token_to_string (t
),
865 /* Warn if -std=legacy, otherwise error. */
866 format_locus
.nextc
+= format_string_pos
;
867 if (gfc_option
.warn_std
!= 0)
869 gfc_error ("Period required in format "
870 "specifier %s at %L", token_to_string (t
),
876 gfc_warning (0, "Period required in format "
877 "specifier %s at %L", token_to_string (t
),
879 /* If we go to finished, we need to unwind this
880 before the next round. */
881 format_locus
.nextc
-= format_string_pos
;
889 if (u
!= FMT_ZERO
&& u
!= FMT_POSINT
)
891 error
= nonneg_required
;
898 /* Look for optional exponent. */
913 error
= _("Positive exponent width required");
924 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
926 error
= nonneg_required
;
929 else if (is_input
&& t
== FMT_ZERO
)
931 error
= posint_required
;
940 /* Warn if -std=legacy, otherwise error. */
941 if (gfc_option
.warn_std
!= 0)
943 error
= _("Period required in format specifier");
946 if (mode
!= MODE_FORMAT
)
947 format_locus
.nextc
+= format_string_pos
;
948 gfc_warning (0, "Period required in format specifier at %L",
957 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
959 error
= nonneg_required
;
966 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
968 if (mode
!= MODE_FORMAT
)
969 format_locus
.nextc
+= format_string_pos
;
970 gfc_warning (0, "The H format specifier at %L is"
971 " a Fortran 95 deleted feature", &format_locus
);
973 if (mode
== MODE_STRING
)
975 format_string
+= value
;
976 format_length
-= value
;
977 format_string_pos
+= repeat
;
983 next_char (INSTRING_WARN
);
993 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
995 error
= nonneg_required
;
998 else if (is_input
&& t
== FMT_ZERO
)
1000 error
= posint_required
;
1007 if (t
!= FMT_PERIOD
)
1016 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
1018 error
= nonneg_required
;
1026 error
= unexpected_element
;
1031 /* Between a descriptor and what comes next. */
1049 goto optional_comma
;
1052 error
= unexpected_end
;
1056 if (mode
!= MODE_FORMAT
)
1057 format_locus
.nextc
+= format_string_pos
- 1;
1058 if (!gfc_notify_std (GFC_STD_GNU
, "Missing comma at %L", &format_locus
))
1060 /* If we do not actually return a failure, we need to unwind this
1061 before the next round. */
1062 if (mode
!= MODE_FORMAT
)
1063 format_locus
.nextc
-= format_string_pos
;
1068 /* Optional comma is a weird between state where we've just finished
1069 reading a colon, slash, dollar or P descriptor. */
1086 /* Assume that we have another format item. */
1093 extension_optional_comma
:
1094 /* As a GNU extension, permit a missing comma after a string literal. */
1111 goto optional_comma
;
1114 error
= unexpected_end
;
1118 if (mode
!= MODE_FORMAT
)
1119 format_locus
.nextc
+= format_string_pos
;
1120 if (!gfc_notify_std (GFC_STD_GNU
, "Missing comma at %L", &format_locus
))
1122 /* If we do not actually return a failure, we need to unwind this
1123 before the next round. */
1124 if (mode
!= MODE_FORMAT
)
1125 format_locus
.nextc
-= format_string_pos
;
1133 if (mode
!= MODE_FORMAT
)
1134 format_locus
.nextc
+= format_string_pos
;
1135 if (error
== unexpected_element
)
1136 gfc_error (error
, error_element
, &format_locus
);
1138 gfc_error ("%s in format string at %L", error
, &format_locus
);
1147 /* Given an expression node that is a constant string, see if it looks
1148 like a format string. */
1151 check_format_string (gfc_expr
*e
, bool is_input
)
1155 if (!e
|| e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1159 format_string
= e
->value
.character
.string
;
1161 /* More elaborate measures are needed to show where a problem is within a
1162 format string that has been calculated, but that's probably not worth the
1164 format_locus
= e
->where
;
1165 rv
= check_format (is_input
);
1166 /* check for extraneous characters at the end of an otherwise valid format
1167 string, like '(A10,I3)F5'
1168 start at the end and move back to the last character processed,
1170 if (rv
&& e
->value
.character
.length
> format_string_pos
)
1171 for (i
=e
->value
.character
.length
-1;i
>format_string_pos
-1;i
--)
1172 if (e
->value
.character
.string
[i
] != ' ')
1174 format_locus
.nextc
+= format_length
+ 1;
1176 "Extraneous characters in format at %L", &format_locus
);
1183 /************ Fortran I/O statement matchers *************/
1185 /* Match a FORMAT statement. This amounts to actually parsing the
1186 format descriptors in order to correctly locate the end of the
1190 gfc_match_format (void)
1195 if (gfc_current_ns
->proc_name
1196 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1198 gfc_error ("Format statement in module main block at %C");
1202 /* Before parsing the rest of a FORMAT statement, check F2008:c1206. */
1203 if ((gfc_current_state () == COMP_FUNCTION
1204 || gfc_current_state () == COMP_SUBROUTINE
)
1205 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
1207 gfc_error ("FORMAT statement at %C cannot appear within an INTERFACE");
1211 if (gfc_statement_label
== NULL
)
1213 gfc_error ("Missing format label at %C");
1216 gfc_gobble_whitespace ();
1221 start
= gfc_current_locus
;
1223 if (!check_format (false))
1226 if (gfc_match_eos () != MATCH_YES
)
1228 gfc_syntax_error (ST_FORMAT
);
1232 /* The label doesn't get created until after the statement is done
1233 being matched, so we have to leave the string for later. */
1235 gfc_current_locus
= start
; /* Back to the beginning */
1238 new_st
.op
= EXEC_NOP
;
1240 e
= gfc_get_character_expr (gfc_default_character_kind
, &start
,
1241 NULL
, format_length
);
1242 format_string
= e
->value
.character
.string
;
1243 gfc_statement_label
->format
= e
;
1246 check_format (false); /* Guaranteed to succeed */
1247 gfc_match_eos (); /* Guaranteed to succeed */
1253 /* Check for a CHARACTER variable. The check for scalar is done in
1257 check_char_variable (gfc_expr
*e
)
1259 if (e
->expr_type
!= EXPR_VARIABLE
|| e
->ts
.type
!= BT_CHARACTER
)
1261 gfc_error("IOMSG must be a scalar-default-char-variable at %L", &e
->where
);
1269 is_char_type (const char *name
, gfc_expr
*e
)
1271 gfc_resolve_expr (e
);
1273 if (e
->ts
.type
!= BT_CHARACTER
)
1275 gfc_error ("%s requires a scalar-default-char-expr at %L",
1283 /* Match an expression I/O tag of some sort. */
1286 match_etag (const io_tag
*tag
, gfc_expr
**v
)
1291 m
= gfc_match (tag
->spec
);
1295 m
= gfc_match (tag
->value
, &result
);
1298 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1304 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1305 gfc_free_expr (result
);
1314 /* Match a variable I/O tag of some sort. */
1317 match_vtag (const io_tag
*tag
, gfc_expr
**v
)
1322 m
= gfc_match (tag
->spec
);
1326 m
= gfc_match (tag
->value
, &result
);
1329 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1335 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1336 gfc_free_expr (result
);
1340 if (result
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1342 gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag
->name
);
1343 gfc_free_expr (result
);
1347 bool impure
= gfc_impure_variable (result
->symtree
->n
.sym
);
1348 if (impure
&& gfc_pure (NULL
))
1350 gfc_error ("Variable %s cannot be assigned in PURE procedure at %C",
1352 gfc_free_expr (result
);
1357 gfc_unset_implicit_pure (NULL
);
1364 /* Match I/O tags that cause variables to become redefined. */
1367 match_out_tag (const io_tag
*tag
, gfc_expr
**result
)
1371 m
= match_vtag (tag
, result
);
1373 gfc_check_do_variable ((*result
)->symtree
);
1379 /* Match a label I/O tag. */
1382 match_ltag (const io_tag
*tag
, gfc_st_label
** label
)
1388 m
= gfc_match (tag
->spec
);
1392 m
= gfc_match (tag
->value
, label
);
1395 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1401 gfc_error ("Duplicate %s label specification at %C", tag
->name
);
1405 if (!gfc_reference_st_label (*label
, ST_LABEL_TARGET
))
1412 /* Resolution of the FORMAT tag, to be called from resolve_tag. */
1415 resolve_tag_format (const gfc_expr
*e
)
1417 if (e
->expr_type
== EXPR_CONSTANT
1418 && (e
->ts
.type
!= BT_CHARACTER
1419 || e
->ts
.kind
!= gfc_default_character_kind
))
1421 gfc_error ("Constant expression in FORMAT tag at %L must be "
1422 "of type default CHARACTER", &e
->where
);
1426 /* If e's rank is zero and e is not an element of an array, it should be
1427 of integer or character type. The integer variable should be
1430 && (e
->expr_type
!= EXPR_VARIABLE
1431 || e
->symtree
== NULL
1432 || e
->symtree
->n
.sym
->as
== NULL
1433 || e
->symtree
->n
.sym
->as
->rank
== 0))
1435 if ((e
->ts
.type
!= BT_CHARACTER
1436 || e
->ts
.kind
!= gfc_default_character_kind
)
1437 && e
->ts
.type
!= BT_INTEGER
)
1439 gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER "
1440 "or of INTEGER", &e
->where
);
1443 else if (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_VARIABLE
)
1445 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGNED variable in "
1446 "FORMAT tag at %L", &e
->where
))
1448 if (e
->symtree
->n
.sym
->attr
.assign
!= 1)
1450 gfc_error ("Variable %qs at %L has not been assigned a "
1451 "format label", e
->symtree
->n
.sym
->name
, &e
->where
);
1455 else if (e
->ts
.type
== BT_INTEGER
)
1457 gfc_error ("Scalar %qs in FORMAT tag at %L is not an ASSIGNED "
1458 "variable", gfc_basic_typename (e
->ts
.type
), &e
->where
);
1465 /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
1466 It may be assigned an Hollerith constant. */
1467 if (e
->ts
.type
!= BT_CHARACTER
)
1469 if (!gfc_notify_std (GFC_STD_LEGACY
, "Non-character in FORMAT tag "
1470 "at %L", &e
->where
))
1473 if (e
->rank
== 0 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
)
1475 gfc_error ("Non-character assumed shape array element in FORMAT"
1476 " tag at %L", &e
->where
);
1480 if (e
->rank
== 0 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
)
1482 gfc_error ("Non-character assumed size array element in FORMAT"
1483 " tag at %L", &e
->where
);
1487 if (e
->rank
== 0 && e
->symtree
->n
.sym
->attr
.pointer
)
1489 gfc_error ("Non-character pointer array element in FORMAT tag at %L",
1499 /* Do expression resolution and type-checking on an expression tag. */
1502 resolve_tag (const io_tag
*tag
, gfc_expr
*e
)
1507 if (!gfc_resolve_expr (e
))
1510 if (tag
== &tag_format
)
1511 return resolve_tag_format (e
);
1513 if (e
->ts
.type
!= tag
->type
)
1515 gfc_error ("%s tag at %L must be of type %s", tag
->name
,
1516 &e
->where
, gfc_basic_typename (tag
->type
));
1520 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= gfc_default_character_kind
)
1522 gfc_error ("%s tag at %L must be a character string of default kind",
1523 tag
->name
, &e
->where
);
1529 gfc_error ("%s tag at %L must be scalar", tag
->name
, &e
->where
);
1533 if (tag
== &tag_iomsg
)
1535 if (!gfc_notify_std (GFC_STD_F2003
, "IOMSG tag at %L", &e
->where
))
1539 if ((tag
== &tag_iostat
|| tag
== &tag_size
|| tag
== &tag_iolength
1540 || tag
== &tag_number
|| tag
== &tag_nextrec
|| tag
== &tag_s_recl
)
1541 && e
->ts
.kind
!= gfc_default_integer_kind
)
1543 if (!gfc_notify_std (GFC_STD_F2003
, "Fortran 95 requires default "
1544 "INTEGER in %s tag at %L", tag
->name
, &e
->where
))
1548 if (e
->ts
.kind
!= gfc_default_logical_kind
&&
1549 (tag
== &tag_exist
|| tag
== &tag_named
|| tag
== &tag_opened
1550 || tag
== &tag_pending
))
1552 if (!gfc_notify_std (GFC_STD_F2008
, "Non-default LOGICAL kind "
1553 "in %s tag at %L", tag
->name
, &e
->where
))
1557 if (tag
== &tag_newunit
)
1559 if (!gfc_notify_std (GFC_STD_F2008
, "NEWUNIT specifier at %L",
1564 /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */
1565 if (tag
== &tag_newunit
|| tag
== &tag_iostat
1566 || tag
== &tag_size
|| tag
== &tag_iomsg
)
1570 sprintf (context
, _("%s tag"), tag
->name
);
1571 if (!gfc_check_vardef_context (e
, false, false, false, context
))
1575 if (tag
== &tag_convert
)
1577 if (!gfc_notify_std (GFC_STD_GNU
, "CONVERT tag at %L", &e
->where
))
1585 /* Match a single tag of an OPEN statement. */
1588 match_open_element (gfc_open
*open
)
1592 m
= match_etag (&tag_e_async
, &open
->asynchronous
);
1593 if (m
== MATCH_YES
&& !is_char_type ("ASYNCHRONOUS", open
->asynchronous
))
1597 m
= match_etag (&tag_unit
, &open
->unit
);
1600 m
= match_etag (&tag_iomsg
, &open
->iomsg
);
1601 if (m
== MATCH_YES
&& !check_char_variable (open
->iomsg
))
1605 m
= match_out_tag (&tag_iostat
, &open
->iostat
);
1608 m
= match_etag (&tag_file
, &open
->file
);
1611 m
= match_etag (&tag_status
, &open
->status
);
1614 m
= match_etag (&tag_e_access
, &open
->access
);
1617 m
= match_etag (&tag_e_form
, &open
->form
);
1620 m
= match_etag (&tag_e_recl
, &open
->recl
);
1623 m
= match_etag (&tag_e_blank
, &open
->blank
);
1626 m
= match_etag (&tag_e_position
, &open
->position
);
1629 m
= match_etag (&tag_e_action
, &open
->action
);
1632 m
= match_etag (&tag_e_delim
, &open
->delim
);
1635 m
= match_etag (&tag_e_pad
, &open
->pad
);
1638 m
= match_etag (&tag_e_decimal
, &open
->decimal
);
1641 m
= match_etag (&tag_e_encoding
, &open
->encoding
);
1644 m
= match_etag (&tag_e_round
, &open
->round
);
1647 m
= match_etag (&tag_e_sign
, &open
->sign
);
1650 m
= match_ltag (&tag_err
, &open
->err
);
1653 m
= match_etag (&tag_convert
, &open
->convert
);
1656 m
= match_out_tag (&tag_newunit
, &open
->newunit
);
1664 /* Free the gfc_open structure and all the expressions it contains. */
1667 gfc_free_open (gfc_open
*open
)
1672 gfc_free_expr (open
->unit
);
1673 gfc_free_expr (open
->iomsg
);
1674 gfc_free_expr (open
->iostat
);
1675 gfc_free_expr (open
->file
);
1676 gfc_free_expr (open
->status
);
1677 gfc_free_expr (open
->access
);
1678 gfc_free_expr (open
->form
);
1679 gfc_free_expr (open
->recl
);
1680 gfc_free_expr (open
->blank
);
1681 gfc_free_expr (open
->position
);
1682 gfc_free_expr (open
->action
);
1683 gfc_free_expr (open
->delim
);
1684 gfc_free_expr (open
->pad
);
1685 gfc_free_expr (open
->decimal
);
1686 gfc_free_expr (open
->encoding
);
1687 gfc_free_expr (open
->round
);
1688 gfc_free_expr (open
->sign
);
1689 gfc_free_expr (open
->convert
);
1690 gfc_free_expr (open
->asynchronous
);
1691 gfc_free_expr (open
->newunit
);
1696 /* Resolve everything in a gfc_open structure. */
1699 gfc_resolve_open (gfc_open
*open
)
1702 RESOLVE_TAG (&tag_unit
, open
->unit
);
1703 RESOLVE_TAG (&tag_iomsg
, open
->iomsg
);
1704 RESOLVE_TAG (&tag_iostat
, open
->iostat
);
1705 RESOLVE_TAG (&tag_file
, open
->file
);
1706 RESOLVE_TAG (&tag_status
, open
->status
);
1707 RESOLVE_TAG (&tag_e_access
, open
->access
);
1708 RESOLVE_TAG (&tag_e_form
, open
->form
);
1709 RESOLVE_TAG (&tag_e_recl
, open
->recl
);
1710 RESOLVE_TAG (&tag_e_blank
, open
->blank
);
1711 RESOLVE_TAG (&tag_e_position
, open
->position
);
1712 RESOLVE_TAG (&tag_e_action
, open
->action
);
1713 RESOLVE_TAG (&tag_e_delim
, open
->delim
);
1714 RESOLVE_TAG (&tag_e_pad
, open
->pad
);
1715 RESOLVE_TAG (&tag_e_decimal
, open
->decimal
);
1716 RESOLVE_TAG (&tag_e_encoding
, open
->encoding
);
1717 RESOLVE_TAG (&tag_e_async
, open
->asynchronous
);
1718 RESOLVE_TAG (&tag_e_round
, open
->round
);
1719 RESOLVE_TAG (&tag_e_sign
, open
->sign
);
1720 RESOLVE_TAG (&tag_convert
, open
->convert
);
1721 RESOLVE_TAG (&tag_newunit
, open
->newunit
);
1723 if (!gfc_reference_st_label (open
->err
, ST_LABEL_TARGET
))
1730 /* Check if a given value for a SPECIFIER is either in the list of values
1731 allowed in F95 or F2003, issuing an error message and returning a zero
1732 value if it is not allowed. */
1735 compare_to_allowed_values (const char *specifier
, const char *allowed
[],
1736 const char *allowed_f2003
[],
1737 const char *allowed_gnu
[], gfc_char_t
*value
,
1738 const char *statement
, bool warn
)
1743 len
= gfc_wide_strlen (value
);
1746 for (len
--; len
> 0; len
--)
1747 if (value
[len
] != ' ')
1752 for (i
= 0; allowed
[i
]; i
++)
1753 if (len
== strlen (allowed
[i
])
1754 && gfc_wide_strncasecmp (value
, allowed
[i
], strlen (allowed
[i
])) == 0)
1757 for (i
= 0; allowed_f2003
&& allowed_f2003
[i
]; i
++)
1758 if (len
== strlen (allowed_f2003
[i
])
1759 && gfc_wide_strncasecmp (value
, allowed_f2003
[i
],
1760 strlen (allowed_f2003
[i
])) == 0)
1762 notification n
= gfc_notification_std (GFC_STD_F2003
);
1764 if (n
== WARNING
|| (warn
&& n
== ERROR
))
1766 gfc_warning (0, "Fortran 2003: %s specifier in %s statement at %C "
1767 "has value %qs", specifier
, statement
,
1774 gfc_notify_std (GFC_STD_F2003
, "%s specifier in "
1775 "%s statement at %C has value %qs", specifier
,
1776 statement
, allowed_f2003
[i
]);
1784 for (i
= 0; allowed_gnu
&& allowed_gnu
[i
]; i
++)
1785 if (len
== strlen (allowed_gnu
[i
])
1786 && gfc_wide_strncasecmp (value
, allowed_gnu
[i
],
1787 strlen (allowed_gnu
[i
])) == 0)
1789 notification n
= gfc_notification_std (GFC_STD_GNU
);
1791 if (n
== WARNING
|| (warn
&& n
== ERROR
))
1793 gfc_warning (0, "Extension: %s specifier in %s statement at %C "
1794 "has value %qs", specifier
, statement
,
1801 gfc_notify_std (GFC_STD_GNU
, "%s specifier in "
1802 "%s statement at %C has value %qs", specifier
,
1803 statement
, allowed_gnu
[i
]);
1813 char *s
= gfc_widechar_to_char (value
, -1);
1815 "%s specifier in %s statement at %C has invalid value %qs",
1816 specifier
, statement
, s
);
1822 char *s
= gfc_widechar_to_char (value
, -1);
1823 gfc_error ("%s specifier in %s statement at %C has invalid value %qs",
1824 specifier
, statement
, s
);
1831 /* Match an OPEN statement. */
1834 gfc_match_open (void)
1840 m
= gfc_match_char ('(');
1844 open
= XCNEW (gfc_open
);
1846 m
= match_open_element (open
);
1848 if (m
== MATCH_ERROR
)
1852 m
= gfc_match_expr (&open
->unit
);
1853 if (m
== MATCH_ERROR
)
1859 if (gfc_match_char (')') == MATCH_YES
)
1861 if (gfc_match_char (',') != MATCH_YES
)
1864 m
= match_open_element (open
);
1865 if (m
== MATCH_ERROR
)
1871 if (gfc_match_eos () == MATCH_NO
)
1874 if (gfc_pure (NULL
))
1876 gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1880 gfc_unset_implicit_pure (NULL
);
1882 warn
= (open
->err
|| open
->iostat
) ? true : false;
1884 /* Checks on NEWUNIT specifier. */
1889 gfc_error ("UNIT specifier not allowed with NEWUNIT at %C");
1893 if (!(open
->file
|| (open
->status
1894 && gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
1895 "scratch", 7) == 0)))
1897 gfc_error ("NEWUNIT specifier must have FILE= "
1898 "or STATUS='scratch' at %C");
1902 else if (!open
->unit
)
1904 gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified");
1908 /* Checks on the ACCESS specifier. */
1909 if (open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
)
1911 static const char *access_f95
[] = { "SEQUENTIAL", "DIRECT", NULL
};
1912 static const char *access_f2003
[] = { "STREAM", NULL
};
1913 static const char *access_gnu
[] = { "APPEND", NULL
};
1915 if (!is_char_type ("ACCESS", open
->access
))
1918 if (!compare_to_allowed_values ("ACCESS", access_f95
, access_f2003
,
1920 open
->access
->value
.character
.string
,
1925 /* Checks on the ACTION specifier. */
1926 if (open
->action
&& open
->action
->expr_type
== EXPR_CONSTANT
)
1928 static const char *action
[] = { "READ", "WRITE", "READWRITE", NULL
};
1930 if (!is_char_type ("ACTION", open
->action
))
1933 if (!compare_to_allowed_values ("ACTION", action
, NULL
, NULL
,
1934 open
->action
->value
.character
.string
,
1939 /* Checks on the ASYNCHRONOUS specifier. */
1940 if (open
->asynchronous
)
1942 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS= at %C "
1943 "not allowed in Fortran 95"))
1946 if (!is_char_type ("ASYNCHRONOUS", open
->asynchronous
))
1949 if (open
->asynchronous
->expr_type
== EXPR_CONSTANT
)
1951 static const char * asynchronous
[] = { "YES", "NO", NULL
};
1953 if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous
,
1954 NULL
, NULL
, open
->asynchronous
->value
.character
.string
,
1960 /* Checks on the BLANK specifier. */
1963 if (!gfc_notify_std (GFC_STD_F2003
, "BLANK= at %C "
1964 "not allowed in Fortran 95"))
1967 if (!is_char_type ("BLANK", open
->blank
))
1970 if (open
->blank
->expr_type
== EXPR_CONSTANT
)
1972 static const char *blank
[] = { "ZERO", "NULL", NULL
};
1974 if (!compare_to_allowed_values ("BLANK", blank
, NULL
, NULL
,
1975 open
->blank
->value
.character
.string
,
1981 /* Checks on the DECIMAL specifier. */
1984 if (!gfc_notify_std (GFC_STD_F2003
, "DECIMAL= at %C "
1985 "not allowed in Fortran 95"))
1988 if (!is_char_type ("DECIMAL", open
->decimal
))
1991 if (open
->decimal
->expr_type
== EXPR_CONSTANT
)
1993 static const char * decimal
[] = { "COMMA", "POINT", NULL
};
1995 if (!compare_to_allowed_values ("DECIMAL", decimal
, NULL
, NULL
,
1996 open
->decimal
->value
.character
.string
,
2002 /* Checks on the DELIM specifier. */
2005 if (open
->delim
->expr_type
== EXPR_CONSTANT
)
2007 static const char *delim
[] = { "APOSTROPHE", "QUOTE", "NONE", NULL
};
2009 if (!is_char_type ("DELIM", open
->delim
))
2012 if (!compare_to_allowed_values ("DELIM", delim
, NULL
, NULL
,
2013 open
->delim
->value
.character
.string
,
2019 /* Checks on the ENCODING specifier. */
2022 if (!gfc_notify_std (GFC_STD_F2003
, "ENCODING= at %C "
2023 "not allowed in Fortran 95"))
2026 if (!is_char_type ("ENCODING", open
->encoding
))
2029 if (open
->encoding
->expr_type
== EXPR_CONSTANT
)
2031 static const char * encoding
[] = { "DEFAULT", "UTF-8", NULL
};
2033 if (!compare_to_allowed_values ("ENCODING", encoding
, NULL
, NULL
,
2034 open
->encoding
->value
.character
.string
,
2040 /* Checks on the FORM specifier. */
2041 if (open
->form
&& open
->form
->expr_type
== EXPR_CONSTANT
)
2043 static const char *form
[] = { "FORMATTED", "UNFORMATTED", NULL
};
2045 if (!is_char_type ("FORM", open
->form
))
2048 if (!compare_to_allowed_values ("FORM", form
, NULL
, NULL
,
2049 open
->form
->value
.character
.string
,
2054 /* Checks on the PAD specifier. */
2055 if (open
->pad
&& open
->pad
->expr_type
== EXPR_CONSTANT
)
2057 static const char *pad
[] = { "YES", "NO", NULL
};
2059 if (!is_char_type ("PAD", open
->pad
))
2062 if (!compare_to_allowed_values ("PAD", pad
, NULL
, NULL
,
2063 open
->pad
->value
.character
.string
,
2068 /* Checks on the POSITION specifier. */
2069 if (open
->position
&& open
->position
->expr_type
== EXPR_CONSTANT
)
2071 static const char *position
[] = { "ASIS", "REWIND", "APPEND", NULL
};
2073 if (!is_char_type ("POSITION", open
->position
))
2076 if (!compare_to_allowed_values ("POSITION", position
, NULL
, NULL
,
2077 open
->position
->value
.character
.string
,
2082 /* Checks on the ROUND specifier. */
2085 if (!gfc_notify_std (GFC_STD_F2003
, "ROUND= at %C "
2086 "not allowed in Fortran 95"))
2089 if (!is_char_type ("ROUND", open
->round
))
2092 if (open
->round
->expr_type
== EXPR_CONSTANT
)
2094 static const char * round
[] = { "UP", "DOWN", "ZERO", "NEAREST",
2095 "COMPATIBLE", "PROCESSOR_DEFINED",
2098 if (!compare_to_allowed_values ("ROUND", round
, NULL
, NULL
,
2099 open
->round
->value
.character
.string
,
2105 /* Checks on the SIGN specifier. */
2108 if (!gfc_notify_std (GFC_STD_F2003
, "SIGN= at %C "
2109 "not allowed in Fortran 95"))
2112 if (!is_char_type ("SIGN", open
->sign
))
2115 if (open
->sign
->expr_type
== EXPR_CONSTANT
)
2117 static const char * sign
[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
2120 if (!compare_to_allowed_values ("SIGN", sign
, NULL
, NULL
,
2121 open
->sign
->value
.character
.string
,
2127 #define warn_or_error(...) \
2130 gfc_warning (0, __VA_ARGS__); \
2133 gfc_error (__VA_ARGS__); \
2138 /* Checks on the RECL specifier. */
2139 if (open
->recl
&& open
->recl
->expr_type
== EXPR_CONSTANT
2140 && open
->recl
->ts
.type
== BT_INTEGER
2141 && mpz_sgn (open
->recl
->value
.integer
) != 1)
2143 warn_or_error ("RECL in OPEN statement at %C must be positive");
2146 /* Checks on the STATUS specifier. */
2147 if (open
->status
&& open
->status
->expr_type
== EXPR_CONSTANT
)
2149 static const char *status
[] = { "OLD", "NEW", "SCRATCH",
2150 "REPLACE", "UNKNOWN", NULL
};
2152 if (!is_char_type ("STATUS", open
->status
))
2155 if (!compare_to_allowed_values ("STATUS", status
, NULL
, NULL
,
2156 open
->status
->value
.character
.string
,
2160 /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2161 the FILE= specifier shall appear. */
2162 if (open
->file
== NULL
2163 && (gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2165 || gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2168 char *s
= gfc_widechar_to_char (open
->status
->value
.character
.string
,
2170 warn_or_error ("The STATUS specified in OPEN statement at %C is "
2171 "%qs and no FILE specifier is present", s
);
2175 /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2176 the FILE= specifier shall not appear. */
2177 if (gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2178 "scratch", 7) == 0 && open
->file
)
2180 warn_or_error ("The STATUS specified in OPEN statement at %C "
2181 "cannot have the value SCRATCH if a FILE specifier "
2186 /* Things that are not allowed for unformatted I/O. */
2187 if (open
->form
&& open
->form
->expr_type
== EXPR_CONSTANT
2188 && (open
->delim
|| open
->decimal
|| open
->encoding
|| open
->round
2189 || open
->sign
|| open
->pad
|| open
->blank
)
2190 && gfc_wide_strncasecmp (open
->form
->value
.character
.string
,
2191 "unformatted", 11) == 0)
2193 const char *spec
= (open
->delim
? "DELIM "
2194 : (open
->pad
? "PAD " : open
->blank
2197 warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
2198 "unformatted I/O", spec
);
2201 if (open
->recl
&& open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
2202 && gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2205 warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
2210 && open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
2211 && !(gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2212 "sequential", 10) == 0
2213 || gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2215 || gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2218 warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
2219 "for stream or sequential ACCESS");
2222 #undef warn_or_error
2224 new_st
.op
= EXEC_OPEN
;
2225 new_st
.ext
.open
= open
;
2229 gfc_syntax_error (ST_OPEN
);
2232 gfc_free_open (open
);
2237 /* Free a gfc_close structure an all its expressions. */
2240 gfc_free_close (gfc_close
*close
)
2245 gfc_free_expr (close
->unit
);
2246 gfc_free_expr (close
->iomsg
);
2247 gfc_free_expr (close
->iostat
);
2248 gfc_free_expr (close
->status
);
2253 /* Match elements of a CLOSE statement. */
2256 match_close_element (gfc_close
*close
)
2260 m
= match_etag (&tag_unit
, &close
->unit
);
2263 m
= match_etag (&tag_status
, &close
->status
);
2266 m
= match_etag (&tag_iomsg
, &close
->iomsg
);
2267 if (m
== MATCH_YES
&& !check_char_variable (close
->iomsg
))
2271 m
= match_out_tag (&tag_iostat
, &close
->iostat
);
2274 m
= match_ltag (&tag_err
, &close
->err
);
2282 /* Match a CLOSE statement. */
2285 gfc_match_close (void)
2291 m
= gfc_match_char ('(');
2295 close
= XCNEW (gfc_close
);
2297 m
= match_close_element (close
);
2299 if (m
== MATCH_ERROR
)
2303 m
= gfc_match_expr (&close
->unit
);
2306 if (m
== MATCH_ERROR
)
2312 if (gfc_match_char (')') == MATCH_YES
)
2314 if (gfc_match_char (',') != MATCH_YES
)
2317 m
= match_close_element (close
);
2318 if (m
== MATCH_ERROR
)
2324 if (gfc_match_eos () == MATCH_NO
)
2327 if (gfc_pure (NULL
))
2329 gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2333 gfc_unset_implicit_pure (NULL
);
2335 warn
= (close
->iostat
|| close
->err
) ? true : false;
2337 /* Checks on the STATUS specifier. */
2338 if (close
->status
&& close
->status
->expr_type
== EXPR_CONSTANT
)
2340 static const char *status
[] = { "KEEP", "DELETE", NULL
};
2342 if (!is_char_type ("STATUS", close
->status
))
2345 if (!compare_to_allowed_values ("STATUS", status
, NULL
, NULL
,
2346 close
->status
->value
.character
.string
,
2351 new_st
.op
= EXEC_CLOSE
;
2352 new_st
.ext
.close
= close
;
2356 gfc_syntax_error (ST_CLOSE
);
2359 gfc_free_close (close
);
2364 /* Resolve everything in a gfc_close structure. */
2367 gfc_resolve_close (gfc_close
*close
)
2369 RESOLVE_TAG (&tag_unit
, close
->unit
);
2370 RESOLVE_TAG (&tag_iomsg
, close
->iomsg
);
2371 RESOLVE_TAG (&tag_iostat
, close
->iostat
);
2372 RESOLVE_TAG (&tag_status
, close
->status
);
2374 if (!gfc_reference_st_label (close
->err
, ST_LABEL_TARGET
))
2377 if (close
->unit
== NULL
)
2379 /* Find a locus from one of the arguments to close, when UNIT is
2381 locus loc
= gfc_current_locus
;
2383 loc
= close
->status
->where
;
2384 else if (close
->iostat
)
2385 loc
= close
->iostat
->where
;
2386 else if (close
->iomsg
)
2387 loc
= close
->iomsg
->where
;
2388 else if (close
->err
)
2389 loc
= close
->err
->where
;
2391 gfc_error ("CLOSE statement at %L requires a UNIT number", &loc
);
2395 if (close
->unit
->expr_type
== EXPR_CONSTANT
2396 && close
->unit
->ts
.type
== BT_INTEGER
2397 && mpz_sgn (close
->unit
->value
.integer
) < 0)
2399 gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2400 &close
->unit
->where
);
2407 /* Free a gfc_filepos structure. */
2410 gfc_free_filepos (gfc_filepos
*fp
)
2412 gfc_free_expr (fp
->unit
);
2413 gfc_free_expr (fp
->iomsg
);
2414 gfc_free_expr (fp
->iostat
);
2419 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
2422 match_file_element (gfc_filepos
*fp
)
2426 m
= match_etag (&tag_unit
, &fp
->unit
);
2429 m
= match_etag (&tag_iomsg
, &fp
->iomsg
);
2430 if (m
== MATCH_YES
&& !check_char_variable (fp
->iomsg
))
2434 m
= match_out_tag (&tag_iostat
, &fp
->iostat
);
2437 m
= match_ltag (&tag_err
, &fp
->err
);
2445 /* Match the second half of the file-positioning statements, REWIND,
2446 BACKSPACE, ENDFILE, or the FLUSH statement. */
2449 match_filepos (gfc_statement st
, gfc_exec_op op
)
2454 fp
= XCNEW (gfc_filepos
);
2456 if (gfc_match_char ('(') == MATCH_NO
)
2458 m
= gfc_match_expr (&fp
->unit
);
2459 if (m
== MATCH_ERROR
)
2467 m
= match_file_element (fp
);
2468 if (m
== MATCH_ERROR
)
2472 m
= gfc_match_expr (&fp
->unit
);
2473 if (m
== MATCH_ERROR
|| m
== MATCH_NO
)
2479 if (gfc_match_char (')') == MATCH_YES
)
2481 if (gfc_match_char (',') != MATCH_YES
)
2484 m
= match_file_element (fp
);
2485 if (m
== MATCH_ERROR
)
2492 if (gfc_match_eos () != MATCH_YES
)
2495 if (gfc_pure (NULL
))
2497 gfc_error ("%s statement not allowed in PURE procedure at %C",
2498 gfc_ascii_statement (st
));
2503 gfc_unset_implicit_pure (NULL
);
2506 new_st
.ext
.filepos
= fp
;
2510 gfc_syntax_error (st
);
2513 gfc_free_filepos (fp
);
2519 gfc_resolve_filepos (gfc_filepos
*fp
)
2521 RESOLVE_TAG (&tag_unit
, fp
->unit
);
2522 RESOLVE_TAG (&tag_iostat
, fp
->iostat
);
2523 RESOLVE_TAG (&tag_iomsg
, fp
->iomsg
);
2524 if (!gfc_reference_st_label (fp
->err
, ST_LABEL_TARGET
))
2527 if (!fp
->unit
&& (fp
->iostat
|| fp
->iomsg
))
2530 where
= fp
->iostat
? fp
->iostat
->where
: fp
->iomsg
->where
;
2531 gfc_error ("UNIT number missing in statement at %L", &where
);
2535 if (fp
->unit
->expr_type
== EXPR_CONSTANT
2536 && fp
->unit
->ts
.type
== BT_INTEGER
2537 && mpz_sgn (fp
->unit
->value
.integer
) < 0)
2539 gfc_error ("UNIT number in statement at %L must be non-negative",
2548 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2549 and the FLUSH statement. */
2552 gfc_match_endfile (void)
2554 return match_filepos (ST_END_FILE
, EXEC_ENDFILE
);
2558 gfc_match_backspace (void)
2560 return match_filepos (ST_BACKSPACE
, EXEC_BACKSPACE
);
2564 gfc_match_rewind (void)
2566 return match_filepos (ST_REWIND
, EXEC_REWIND
);
2570 gfc_match_flush (void)
2572 if (!gfc_notify_std (GFC_STD_F2003
, "FLUSH statement at %C"))
2575 return match_filepos (ST_FLUSH
, EXEC_FLUSH
);
2578 /******************** Data Transfer Statements *********************/
2580 /* Return a default unit number. */
2583 default_unit (io_kind k
)
2592 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, unit
);
2596 /* Match a unit specification for a data transfer statement. */
2599 match_dt_unit (io_kind k
, gfc_dt
*dt
)
2603 if (gfc_match_char ('*') == MATCH_YES
)
2605 if (dt
->io_unit
!= NULL
)
2608 dt
->io_unit
= default_unit (k
);
2612 if (gfc_match_expr (&e
) == MATCH_YES
)
2614 if (dt
->io_unit
!= NULL
)
2627 gfc_error ("Duplicate UNIT specification at %C");
2632 /* Match a format specification. */
2635 match_dt_format (gfc_dt
*dt
)
2639 gfc_st_label
*label
;
2642 where
= gfc_current_locus
;
2644 if (gfc_match_char ('*') == MATCH_YES
)
2646 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2649 dt
->format_label
= &format_asterisk
;
2653 if ((m
= gfc_match_st_label (&label
)) == MATCH_YES
)
2657 /* Need to check if the format label is actually either an operand
2658 to a user-defined operator or is a kind type parameter. That is,
2659 print 2.ip.8 ! .ip. is a user-defined operator return CHARACTER.
2660 print 1_'(I0)', i ! 1_'(I0)' is a default character string. */
2662 gfc_gobble_whitespace ();
2663 c
= gfc_peek_ascii_char ();
2664 if (c
== '.' || c
== '_')
2665 gfc_current_locus
= where
;
2668 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2670 gfc_free_st_label (label
);
2674 if (!gfc_reference_st_label (label
, ST_LABEL_FORMAT
))
2677 dt
->format_label
= label
;
2681 else if (m
== MATCH_ERROR
)
2682 /* The label was zero or too large. Emit the correct diagnosis. */
2685 if (gfc_match_expr (&e
) == MATCH_YES
)
2687 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2692 dt
->format_expr
= e
;
2696 gfc_current_locus
= where
; /* The only case where we have to restore */
2701 gfc_error ("Duplicate format specification at %C");
2706 /* Traverse a namelist that is part of a READ statement to make sure
2707 that none of the variables in the namelist are INTENT(IN). Returns
2708 nonzero if we find such a variable. */
2711 check_namelist (gfc_symbol
*sym
)
2715 for (p
= sym
->namelist
; p
; p
= p
->next
)
2716 if (p
->sym
->attr
.intent
== INTENT_IN
)
2718 gfc_error ("Symbol %qs in namelist %qs is INTENT(IN) at %C",
2719 p
->sym
->name
, sym
->name
);
2727 /* Match a single data transfer element. */
2730 match_dt_element (io_kind k
, gfc_dt
*dt
)
2732 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2736 if (gfc_match (" unit =") == MATCH_YES
)
2738 m
= match_dt_unit (k
, dt
);
2743 if (gfc_match (" fmt =") == MATCH_YES
)
2745 m
= match_dt_format (dt
);
2750 if (gfc_match (" nml = %n", name
) == MATCH_YES
)
2752 if (dt
->namelist
!= NULL
)
2754 gfc_error ("Duplicate NML specification at %C");
2758 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
2761 if (sym
== NULL
|| sym
->attr
.flavor
!= FL_NAMELIST
)
2763 gfc_error ("Symbol %qs at %C must be a NAMELIST group name",
2764 sym
!= NULL
? sym
->name
: name
);
2769 if (k
== M_READ
&& check_namelist (sym
))
2775 m
= match_etag (&tag_e_async
, &dt
->asynchronous
);
2776 if (m
== MATCH_YES
&& !is_char_type ("ASYNCHRONOUS", dt
->asynchronous
))
2780 m
= match_etag (&tag_e_blank
, &dt
->blank
);
2783 m
= match_etag (&tag_e_delim
, &dt
->delim
);
2786 m
= match_etag (&tag_e_pad
, &dt
->pad
);
2789 m
= match_etag (&tag_e_sign
, &dt
->sign
);
2792 m
= match_etag (&tag_e_round
, &dt
->round
);
2795 m
= match_out_tag (&tag_id
, &dt
->id
);
2798 m
= match_etag (&tag_e_decimal
, &dt
->decimal
);
2801 m
= match_etag (&tag_rec
, &dt
->rec
);
2804 m
= match_etag (&tag_spos
, &dt
->pos
);
2807 m
= match_etag (&tag_iomsg
, &dt
->iomsg
);
2808 if (m
== MATCH_YES
&& !check_char_variable (dt
->iomsg
))
2813 m
= match_out_tag (&tag_iostat
, &dt
->iostat
);
2816 m
= match_ltag (&tag_err
, &dt
->err
);
2818 dt
->err_where
= gfc_current_locus
;
2821 m
= match_etag (&tag_advance
, &dt
->advance
);
2824 m
= match_out_tag (&tag_size
, &dt
->size
);
2828 m
= match_ltag (&tag_end
, &dt
->end
);
2833 gfc_error ("END tag at %C not allowed in output statement");
2836 dt
->end_where
= gfc_current_locus
;
2841 m
= match_ltag (&tag_eor
, &dt
->eor
);
2843 dt
->eor_where
= gfc_current_locus
;
2851 /* Free a data transfer structure and everything below it. */
2854 gfc_free_dt (gfc_dt
*dt
)
2859 gfc_free_expr (dt
->io_unit
);
2860 gfc_free_expr (dt
->format_expr
);
2861 gfc_free_expr (dt
->rec
);
2862 gfc_free_expr (dt
->advance
);
2863 gfc_free_expr (dt
->iomsg
);
2864 gfc_free_expr (dt
->iostat
);
2865 gfc_free_expr (dt
->size
);
2866 gfc_free_expr (dt
->pad
);
2867 gfc_free_expr (dt
->delim
);
2868 gfc_free_expr (dt
->sign
);
2869 gfc_free_expr (dt
->round
);
2870 gfc_free_expr (dt
->blank
);
2871 gfc_free_expr (dt
->decimal
);
2872 gfc_free_expr (dt
->pos
);
2873 gfc_free_expr (dt
->dt_io_kind
);
2874 /* dt->extra_comma is a link to dt_io_kind if it is set. */
2879 /* Resolve everything in a gfc_dt structure. */
2882 gfc_resolve_dt (gfc_dt
*dt
, locus
*loc
)
2887 /* This is set in any case. */
2888 gcc_assert (dt
->dt_io_kind
);
2889 k
= dt
->dt_io_kind
->value
.iokind
;
2891 RESOLVE_TAG (&tag_format
, dt
->format_expr
);
2892 RESOLVE_TAG (&tag_rec
, dt
->rec
);
2893 RESOLVE_TAG (&tag_spos
, dt
->pos
);
2894 RESOLVE_TAG (&tag_advance
, dt
->advance
);
2895 RESOLVE_TAG (&tag_id
, dt
->id
);
2896 RESOLVE_TAG (&tag_iomsg
, dt
->iomsg
);
2897 RESOLVE_TAG (&tag_iostat
, dt
->iostat
);
2898 RESOLVE_TAG (&tag_size
, dt
->size
);
2899 RESOLVE_TAG (&tag_e_pad
, dt
->pad
);
2900 RESOLVE_TAG (&tag_e_delim
, dt
->delim
);
2901 RESOLVE_TAG (&tag_e_sign
, dt
->sign
);
2902 RESOLVE_TAG (&tag_e_round
, dt
->round
);
2903 RESOLVE_TAG (&tag_e_blank
, dt
->blank
);
2904 RESOLVE_TAG (&tag_e_decimal
, dt
->decimal
);
2905 RESOLVE_TAG (&tag_e_async
, dt
->asynchronous
);
2910 gfc_error ("UNIT not specified at %L", loc
);
2914 if (gfc_resolve_expr (e
)
2915 && (e
->ts
.type
!= BT_INTEGER
2916 && (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_VARIABLE
)))
2918 /* If there is no extra comma signifying the "format" form of the IO
2919 statement, then this must be an error. */
2920 if (!dt
->extra_comma
)
2922 gfc_error ("UNIT specification at %L must be an INTEGER expression "
2923 "or a CHARACTER variable", &e
->where
);
2928 /* At this point, we have an extra comma. If io_unit has arrived as
2929 type character, we assume its really the "format" form of the I/O
2930 statement. We set the io_unit to the default unit and format to
2931 the character expression. See F95 Standard section 9.4. */
2932 if (e
->ts
.type
== BT_CHARACTER
&& (k
== M_READ
|| k
== M_PRINT
))
2934 dt
->format_expr
= dt
->io_unit
;
2935 dt
->io_unit
= default_unit (k
);
2937 /* Nullify this pointer now so that a warning/error is not
2938 triggered below for the "Extension". */
2939 dt
->extra_comma
= NULL
;
2944 gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
2945 &dt
->extra_comma
->where
);
2951 if (e
->ts
.type
== BT_CHARACTER
)
2953 if (gfc_has_vector_index (e
))
2955 gfc_error ("Internal unit with vector subscript at %L", &e
->where
);
2959 /* If we are writing, make sure the internal unit can be changed. */
2960 gcc_assert (k
!= M_PRINT
);
2962 && !gfc_check_vardef_context (e
, false, false, false,
2963 _("internal unit in WRITE")))
2967 if (e
->rank
&& e
->ts
.type
!= BT_CHARACTER
)
2969 gfc_error ("External IO UNIT cannot be an array at %L", &e
->where
);
2973 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_INTEGER
2974 && mpz_sgn (e
->value
.integer
) < 0)
2976 gfc_error ("UNIT number in statement at %L must be non-negative",
2981 /* If we are reading and have a namelist, check that all namelist symbols
2982 can appear in a variable definition context. */
2983 if (k
== M_READ
&& dt
->namelist
)
2986 for (n
= dt
->namelist
->namelist
; n
; n
= n
->next
)
2991 e
= gfc_get_variable_expr (gfc_find_sym_in_symtree (n
->sym
));
2992 t
= gfc_check_vardef_context (e
, false, false, false, NULL
);
2997 gfc_error ("NAMELIST %qs in READ statement at %L contains"
2998 " the symbol %qs which may not appear in a"
2999 " variable definition context",
3000 dt
->namelist
->name
, loc
, n
->sym
->name
);
3007 && !gfc_notify_std (GFC_STD_GNU
, "Comma before i/o item list at %L",
3008 &dt
->extra_comma
->where
))
3013 if (!gfc_reference_st_label (dt
->err
, ST_LABEL_TARGET
))
3015 if (dt
->err
->defined
== ST_LABEL_UNKNOWN
)
3017 gfc_error ("ERR tag label %d at %L not defined",
3018 dt
->err
->value
, &dt
->err_where
);
3025 if (!gfc_reference_st_label (dt
->end
, ST_LABEL_TARGET
))
3027 if (dt
->end
->defined
== ST_LABEL_UNKNOWN
)
3029 gfc_error ("END tag label %d at %L not defined",
3030 dt
->end
->value
, &dt
->end_where
);
3037 if (!gfc_reference_st_label (dt
->eor
, ST_LABEL_TARGET
))
3039 if (dt
->eor
->defined
== ST_LABEL_UNKNOWN
)
3041 gfc_error ("EOR tag label %d at %L not defined",
3042 dt
->eor
->value
, &dt
->eor_where
);
3047 /* Check the format label actually exists. */
3048 if (dt
->format_label
&& dt
->format_label
!= &format_asterisk
3049 && dt
->format_label
->defined
== ST_LABEL_UNKNOWN
)
3051 gfc_error ("FORMAT label %d at %L not defined", dt
->format_label
->value
,
3052 &dt
->format_label
->where
);
3060 /* Given an io_kind, return its name. */
3063 io_kind_name (io_kind k
)
3082 gfc_internal_error ("io_kind_name(): bad I/O-kind");
3089 /* Match an IO iteration statement of the form:
3091 ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
3093 which is equivalent to a single IO element. This function is
3094 mutually recursive with match_io_element(). */
3096 static match
match_io_element (io_kind
, gfc_code
**);
3099 match_io_iterator (io_kind k
, gfc_code
**result
)
3101 gfc_code
*head
, *tail
, *new_code
;
3109 old_loc
= gfc_current_locus
;
3111 if (gfc_match_char ('(') != MATCH_YES
)
3114 m
= match_io_element (k
, &head
);
3117 if (m
!= MATCH_YES
|| gfc_match_char (',') != MATCH_YES
)
3123 /* Can't be anything but an IO iterator. Build a list. */
3124 iter
= gfc_get_iterator ();
3128 m
= gfc_match_iterator (iter
, 0);
3129 if (m
== MATCH_ERROR
)
3133 gfc_check_do_variable (iter
->var
->symtree
);
3137 m
= match_io_element (k
, &new_code
);
3138 if (m
== MATCH_ERROR
)
3147 tail
= gfc_append_code (tail
, new_code
);
3149 if (gfc_match_char (',') != MATCH_YES
)
3158 if (gfc_match_char (')') != MATCH_YES
)
3161 new_code
= gfc_get_code (EXEC_DO
);
3162 new_code
->ext
.iterator
= iter
;
3164 new_code
->block
= gfc_get_code (EXEC_DO
);
3165 new_code
->block
->next
= head
;
3171 gfc_error ("Syntax error in I/O iterator at %C");
3175 gfc_free_iterator (iter
, 1);
3176 gfc_free_statements (head
);
3177 gfc_current_locus
= old_loc
;
3182 /* Match a single element of an IO list, which is either a single
3183 expression or an IO Iterator. */
3186 match_io_element (io_kind k
, gfc_code
**cpp
)
3194 m
= match_io_iterator (k
, cpp
);
3200 m
= gfc_match_variable (&expr
, 0);
3202 gfc_error ("Expected variable in READ statement at %C");
3206 m
= gfc_match_expr (&expr
);
3208 gfc_error ("Expected expression in %s statement at %C",
3212 if (m
== MATCH_YES
&& k
== M_READ
&& gfc_check_do_variable (expr
->symtree
))
3217 gfc_free_expr (expr
);
3221 cp
= gfc_get_code (EXEC_TRANSFER
);
3224 cp
->ext
.dt
= current_dt
;
3231 /* Match an I/O list, building gfc_code structures as we go. */
3234 match_io_list (io_kind k
, gfc_code
**head_p
)
3236 gfc_code
*head
, *tail
, *new_code
;
3239 *head_p
= head
= tail
= NULL
;
3240 if (gfc_match_eos () == MATCH_YES
)
3245 m
= match_io_element (k
, &new_code
);
3246 if (m
== MATCH_ERROR
)
3251 tail
= gfc_append_code (tail
, new_code
);
3255 if (gfc_match_eos () == MATCH_YES
)
3257 if (gfc_match_char (',') != MATCH_YES
)
3265 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
3268 gfc_free_statements (head
);
3273 /* Attach the data transfer end node. */
3276 terminate_io (gfc_code
*io_code
)
3280 if (io_code
== NULL
)
3281 io_code
= new_st
.block
;
3283 c
= gfc_get_code (EXEC_DT_END
);
3285 /* Point to structure that is already there */
3286 c
->ext
.dt
= new_st
.ext
.dt
;
3287 gfc_append_code (io_code
, c
);
3291 /* Check the constraints for a data transfer statement. The majority of the
3292 constraints appearing in 9.4 of the standard appear here. Some are handled
3293 in resolve_tag and others in gfc_resolve_dt. */
3296 check_io_constraints (io_kind k
, gfc_dt
*dt
, gfc_code
*io_code
,
3299 #define io_constraint(condition,msg,arg)\
3302 gfc_error(msg,arg);\
3308 gfc_symbol
*sym
= NULL
;
3309 bool warn
, unformatted
;
3311 warn
= (dt
->err
|| dt
->iostat
) ? true : false;
3312 unformatted
= dt
->format_expr
== NULL
&& dt
->format_label
== NULL
3313 && dt
->namelist
== NULL
;
3318 if (expr
&& expr
->expr_type
== EXPR_VARIABLE
3319 && expr
->ts
.type
== BT_CHARACTER
)
3321 sym
= expr
->symtree
->n
.sym
;
3323 io_constraint (k
== M_WRITE
&& sym
->attr
.intent
== INTENT_IN
,
3324 "Internal file at %L must not be INTENT(IN)",
3327 io_constraint (gfc_has_vector_index (dt
->io_unit
),
3328 "Internal file incompatible with vector subscript at %L",
3331 io_constraint (dt
->rec
!= NULL
,
3332 "REC tag at %L is incompatible with internal file",
3335 io_constraint (dt
->pos
!= NULL
,
3336 "POS tag at %L is incompatible with internal file",
3339 io_constraint (unformatted
,
3340 "Unformatted I/O not allowed with internal unit at %L",
3341 &dt
->io_unit
->where
);
3343 io_constraint (dt
->asynchronous
!= NULL
,
3344 "ASYNCHRONOUS tag at %L not allowed with internal file",
3345 &dt
->asynchronous
->where
);
3347 if (dt
->namelist
!= NULL
)
3349 if (!gfc_notify_std (GFC_STD_F2003
, "Internal file at %L with "
3350 "namelist", &expr
->where
))
3354 io_constraint (dt
->advance
!= NULL
,
3355 "ADVANCE tag at %L is incompatible with internal file",
3356 &dt
->advance
->where
);
3359 if (expr
&& expr
->ts
.type
!= BT_CHARACTER
)
3362 io_constraint (gfc_pure (NULL
) && (k
== M_READ
|| k
== M_WRITE
),
3363 "IO UNIT in %s statement at %C must be "
3364 "an internal file in a PURE procedure",
3367 if (k
== M_READ
|| k
== M_WRITE
)
3368 gfc_unset_implicit_pure (NULL
);
3373 io_constraint (dt
->end
, "END tag not allowed with output at %L",
3376 io_constraint (dt
->eor
, "EOR tag not allowed with output at %L",
3379 io_constraint (dt
->blank
, "BLANK= specifier not allowed with output at %L",
3382 io_constraint (dt
->pad
, "PAD= specifier not allowed with output at %L",
3385 io_constraint (dt
->size
, "SIZE= specifier not allowed with output at %L",
3390 io_constraint (dt
->size
&& dt
->advance
== NULL
,
3391 "SIZE tag at %L requires an ADVANCE tag",
3394 io_constraint (dt
->eor
&& dt
->advance
== NULL
,
3395 "EOR tag at %L requires an ADVANCE tag",
3399 if (dt
->asynchronous
)
3401 static const char * asynchronous
[] = { "YES", "NO", NULL
};
3403 if (!gfc_reduce_init_expr (dt
->asynchronous
))
3405 gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3406 "expression", &dt
->asynchronous
->where
);
3410 if (!is_char_type ("ASYNCHRONOUS", dt
->asynchronous
))
3413 if (!compare_to_allowed_values
3414 ("ASYNCHRONOUS", asynchronous
, NULL
, NULL
,
3415 dt
->asynchronous
->value
.character
.string
,
3416 io_kind_name (k
), warn
))
3424 || gfc_wide_strlen (dt
->asynchronous
->value
.character
.string
) != 3
3425 || gfc_wide_strncasecmp (dt
->asynchronous
->value
.character
.string
,
3427 io_constraint (not_yes
,
3428 "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3429 "specifier", &dt
->id
->where
);
3434 if (!gfc_notify_std (GFC_STD_F2003
, "DECIMAL= at %C "
3435 "not allowed in Fortran 95"))
3438 if (dt
->decimal
->expr_type
== EXPR_CONSTANT
)
3440 static const char * decimal
[] = { "COMMA", "POINT", NULL
};
3442 if (!is_char_type ("DECIMAL", dt
->decimal
))
3445 if (!compare_to_allowed_values ("DECIMAL", decimal
, NULL
, NULL
,
3446 dt
->decimal
->value
.character
.string
,
3447 io_kind_name (k
), warn
))
3450 io_constraint (unformatted
,
3451 "the DECIMAL= specifier at %L must be with an "
3452 "explicit format expression", &dt
->decimal
->where
);
3458 if (!gfc_notify_std (GFC_STD_F2003
, "BLANK= at %C "
3459 "not allowed in Fortran 95"))
3462 if (!is_char_type ("BLANK", dt
->blank
))
3465 if (dt
->blank
->expr_type
== EXPR_CONSTANT
)
3467 static const char * blank
[] = { "NULL", "ZERO", NULL
};
3470 if (!compare_to_allowed_values ("BLANK", blank
, NULL
, NULL
,
3471 dt
->blank
->value
.character
.string
,
3472 io_kind_name (k
), warn
))
3475 io_constraint (unformatted
,
3476 "the BLANK= specifier at %L must be with an "
3477 "explicit format expression", &dt
->blank
->where
);
3483 if (!gfc_notify_std (GFC_STD_F2003
, "PAD= at %C "
3484 "not allowed in Fortran 95"))
3487 if (!is_char_type ("PAD", dt
->pad
))
3490 if (dt
->pad
->expr_type
== EXPR_CONSTANT
)
3492 static const char * pad
[] = { "YES", "NO", NULL
};
3494 if (!compare_to_allowed_values ("PAD", pad
, NULL
, NULL
,
3495 dt
->pad
->value
.character
.string
,
3496 io_kind_name (k
), warn
))
3499 io_constraint (unformatted
,
3500 "the PAD= specifier at %L must be with an "
3501 "explicit format expression", &dt
->pad
->where
);
3507 if (!gfc_notify_std (GFC_STD_F2003
, "ROUND= at %C "
3508 "not allowed in Fortran 95"))
3511 if (!is_char_type ("ROUND", dt
->round
))
3514 if (dt
->round
->expr_type
== EXPR_CONSTANT
)
3516 static const char * round
[] = { "UP", "DOWN", "ZERO", "NEAREST",
3517 "COMPATIBLE", "PROCESSOR_DEFINED",
3520 if (!compare_to_allowed_values ("ROUND", round
, NULL
, NULL
,
3521 dt
->round
->value
.character
.string
,
3522 io_kind_name (k
), warn
))
3529 /* When implemented, change the following to use gfc_notify_std F2003.
3530 if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C "
3531 "not allowed in Fortran 95") == false)
3532 return MATCH_ERROR; */
3534 if (!is_char_type ("SIGN", dt
->sign
))
3537 if (dt
->sign
->expr_type
== EXPR_CONSTANT
)
3539 static const char * sign
[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3542 if (!compare_to_allowed_values ("SIGN", sign
, NULL
, NULL
,
3543 dt
->sign
->value
.character
.string
,
3544 io_kind_name (k
), warn
))
3547 io_constraint (unformatted
,
3548 "SIGN= specifier at %L must be with an "
3549 "explicit format expression", &dt
->sign
->where
);
3551 io_constraint (k
== M_READ
,
3552 "SIGN= specifier at %L not allowed in a "
3553 "READ statement", &dt
->sign
->where
);
3559 if (!gfc_notify_std (GFC_STD_F2003
, "DELIM= at %C "
3560 "not allowed in Fortran 95"))
3563 if (!is_char_type ("DELIM", dt
->delim
))
3566 if (dt
->delim
->expr_type
== EXPR_CONSTANT
)
3568 static const char *delim
[] = { "APOSTROPHE", "QUOTE", "NONE", NULL
};
3570 if (!compare_to_allowed_values ("DELIM", delim
, NULL
, NULL
,
3571 dt
->delim
->value
.character
.string
,
3572 io_kind_name (k
), warn
))
3575 io_constraint (k
== M_READ
,
3576 "DELIM= specifier at %L not allowed in a "
3577 "READ statement", &dt
->delim
->where
);
3579 io_constraint (dt
->format_label
!= &format_asterisk
3580 && dt
->namelist
== NULL
,
3581 "DELIM= specifier at %L must have FMT=*",
3584 io_constraint (unformatted
&& dt
->namelist
== NULL
,
3585 "DELIM= specifier at %L must be with FMT=* or "
3586 "NML= specifier ", &dt
->delim
->where
);
3592 io_constraint (io_code
&& dt
->namelist
,
3593 "NAMELIST cannot be followed by IO-list at %L",
3596 io_constraint (dt
->format_expr
,
3597 "IO spec-list cannot contain both NAMELIST group name "
3598 "and format specification at %L",
3599 &dt
->format_expr
->where
);
3601 io_constraint (dt
->format_label
,
3602 "IO spec-list cannot contain both NAMELIST group name "
3603 "and format label at %L", spec_end
);
3605 io_constraint (dt
->rec
,
3606 "NAMELIST IO is not allowed with a REC= specifier "
3607 "at %L", &dt
->rec
->where
);
3609 io_constraint (dt
->advance
,
3610 "NAMELIST IO is not allowed with a ADVANCE= specifier "
3611 "at %L", &dt
->advance
->where
);
3616 io_constraint (dt
->end
,
3617 "An END tag is not allowed with a "
3618 "REC= specifier at %L", &dt
->end_where
);
3620 io_constraint (dt
->format_label
== &format_asterisk
,
3621 "FMT=* is not allowed with a REC= specifier "
3624 io_constraint (dt
->pos
,
3625 "POS= is not allowed with REC= specifier "
3626 "at %L", &dt
->pos
->where
);
3631 int not_yes
, not_no
;
3634 io_constraint (dt
->format_label
== &format_asterisk
,
3635 "List directed format(*) is not allowed with a "
3636 "ADVANCE= specifier at %L.", &expr
->where
);
3638 io_constraint (unformatted
,
3639 "the ADVANCE= specifier at %L must appear with an "
3640 "explicit format expression", &expr
->where
);
3642 if (expr
->expr_type
== EXPR_CONSTANT
&& expr
->ts
.type
== BT_CHARACTER
)
3644 const gfc_char_t
*advance
= expr
->value
.character
.string
;
3645 not_no
= gfc_wide_strlen (advance
) != 2
3646 || gfc_wide_strncasecmp (advance
, "no", 2) != 0;
3647 not_yes
= gfc_wide_strlen (advance
) != 3
3648 || gfc_wide_strncasecmp (advance
, "yes", 3) != 0;
3656 io_constraint (not_no
&& not_yes
,
3657 "ADVANCE= specifier at %L must have value = "
3658 "YES or NO.", &expr
->where
);
3660 io_constraint (dt
->size
&& not_no
&& k
== M_READ
,
3661 "SIZE tag at %L requires an ADVANCE = %<NO%>",
3664 io_constraint (dt
->eor
&& not_no
&& k
== M_READ
,
3665 "EOR tag at %L requires an ADVANCE = %<NO%>",
3669 expr
= dt
->format_expr
;
3670 if (!gfc_simplify_expr (expr
, 0)
3671 || !check_format_string (expr
, k
== M_READ
))
3676 #undef io_constraint
3679 /* Match a READ, WRITE or PRINT statement. */
3682 match_io (io_kind k
)
3684 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3693 where
= gfc_current_locus
;
3695 current_dt
= dt
= XCNEW (gfc_dt
);
3696 m
= gfc_match_char ('(');
3699 where
= gfc_current_locus
;
3702 else if (k
== M_PRINT
)
3704 /* Treat the non-standard case of PRINT namelist. */
3705 if ((gfc_current_form
== FORM_FIXED
|| gfc_peek_ascii_char () == ' ')
3706 && gfc_match_name (name
) == MATCH_YES
)
3708 gfc_find_symbol (name
, NULL
, 1, &sym
);
3709 if (sym
&& sym
->attr
.flavor
== FL_NAMELIST
)
3711 if (!gfc_notify_std (GFC_STD_GNU
, "PRINT namelist at "
3712 "%C is an extension"))
3718 dt
->io_unit
= default_unit (k
);
3723 gfc_current_locus
= where
;
3727 if (gfc_current_form
== FORM_FREE
)
3729 char c
= gfc_peek_ascii_char ();
3730 if (c
!= ' ' && c
!= '*' && c
!= '\'' && c
!= '"')
3737 m
= match_dt_format (dt
);
3738 if (m
== MATCH_ERROR
)
3744 dt
->io_unit
= default_unit (k
);
3749 /* Before issuing an error for a malformed 'print (1,*)' type of
3750 error, check for a default-char-expr of the form ('(I0)'). */
3751 if (k
== M_PRINT
&& m
== MATCH_YES
)
3753 /* Reset current locus to get the initial '(' in an expression. */
3754 gfc_current_locus
= where
;
3755 dt
->format_expr
= NULL
;
3756 m
= match_dt_format (dt
);
3758 if (m
== MATCH_ERROR
)
3760 if (m
== MATCH_NO
|| dt
->format_expr
== NULL
)
3764 dt
->io_unit
= default_unit (k
);
3769 /* Match a control list */
3770 if (match_dt_element (k
, dt
) == MATCH_YES
)
3772 if (match_dt_unit (k
, dt
) != MATCH_YES
)
3775 if (gfc_match_char (')') == MATCH_YES
)
3777 if (gfc_match_char (',') != MATCH_YES
)
3780 m
= match_dt_element (k
, dt
);
3783 if (m
== MATCH_ERROR
)
3786 m
= match_dt_format (dt
);
3789 if (m
== MATCH_ERROR
)
3792 where
= gfc_current_locus
;
3794 m
= gfc_match_name (name
);
3797 gfc_find_symbol (name
, NULL
, 1, &sym
);
3798 if (sym
&& sym
->attr
.flavor
== FL_NAMELIST
)
3801 if (k
== M_READ
&& check_namelist (sym
))
3810 gfc_current_locus
= where
;
3812 goto loop
; /* No matches, try regular elements */
3815 if (gfc_match_char (')') == MATCH_YES
)
3817 if (gfc_match_char (',') != MATCH_YES
)
3823 m
= match_dt_element (k
, dt
);
3826 if (m
== MATCH_ERROR
)
3829 if (gfc_match_char (')') == MATCH_YES
)
3831 if (gfc_match_char (',') != MATCH_YES
)
3837 /* Used in check_io_constraints, where no locus is available. */
3838 spec_end
= gfc_current_locus
;
3840 /* Save the IO kind for later use. */
3841 dt
->dt_io_kind
= gfc_get_iokind_expr (&gfc_current_locus
, k
);
3843 /* Optional leading comma (non-standard). We use a gfc_expr structure here
3844 to save the locus. This is used later when resolving transfer statements
3845 that might have a format expression without unit number. */
3846 if (!comma_flag
&& gfc_match_char (',') == MATCH_YES
)
3847 dt
->extra_comma
= dt
->dt_io_kind
;
3850 if (gfc_match_eos () != MATCH_YES
)
3852 if (comma_flag
&& gfc_match_char (',') != MATCH_YES
)
3854 gfc_error ("Expected comma in I/O list at %C");
3859 m
= match_io_list (k
, &io_code
);
3860 if (m
== MATCH_ERROR
)
3866 /* A full IO statement has been matched. Check the constraints. spec_end is
3867 supplied for cases where no locus is supplied. */
3868 m
= check_io_constraints (k
, dt
, io_code
, &spec_end
);
3870 if (m
== MATCH_ERROR
)
3873 new_st
.op
= (k
== M_READ
) ? EXEC_READ
: EXEC_WRITE
;
3875 new_st
.block
= gfc_get_code (new_st
.op
);
3876 new_st
.block
->next
= io_code
;
3878 terminate_io (io_code
);
3883 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
3893 gfc_match_read (void)
3895 return match_io (M_READ
);
3900 gfc_match_write (void)
3902 return match_io (M_WRITE
);
3907 gfc_match_print (void)
3911 m
= match_io (M_PRINT
);
3915 if (gfc_pure (NULL
))
3917 gfc_error ("PRINT statement at %C not allowed within PURE procedure");
3921 gfc_unset_implicit_pure (NULL
);
3927 /* Free a gfc_inquire structure. */
3930 gfc_free_inquire (gfc_inquire
*inquire
)
3933 if (inquire
== NULL
)
3936 gfc_free_expr (inquire
->unit
);
3937 gfc_free_expr (inquire
->file
);
3938 gfc_free_expr (inquire
->iomsg
);
3939 gfc_free_expr (inquire
->iostat
);
3940 gfc_free_expr (inquire
->exist
);
3941 gfc_free_expr (inquire
->opened
);
3942 gfc_free_expr (inquire
->number
);
3943 gfc_free_expr (inquire
->named
);
3944 gfc_free_expr (inquire
->name
);
3945 gfc_free_expr (inquire
->access
);
3946 gfc_free_expr (inquire
->sequential
);
3947 gfc_free_expr (inquire
->direct
);
3948 gfc_free_expr (inquire
->form
);
3949 gfc_free_expr (inquire
->formatted
);
3950 gfc_free_expr (inquire
->unformatted
);
3951 gfc_free_expr (inquire
->recl
);
3952 gfc_free_expr (inquire
->nextrec
);
3953 gfc_free_expr (inquire
->blank
);
3954 gfc_free_expr (inquire
->position
);
3955 gfc_free_expr (inquire
->action
);
3956 gfc_free_expr (inquire
->read
);
3957 gfc_free_expr (inquire
->write
);
3958 gfc_free_expr (inquire
->readwrite
);
3959 gfc_free_expr (inquire
->delim
);
3960 gfc_free_expr (inquire
->encoding
);
3961 gfc_free_expr (inquire
->pad
);
3962 gfc_free_expr (inquire
->iolength
);
3963 gfc_free_expr (inquire
->convert
);
3964 gfc_free_expr (inquire
->strm_pos
);
3965 gfc_free_expr (inquire
->asynchronous
);
3966 gfc_free_expr (inquire
->decimal
);
3967 gfc_free_expr (inquire
->pending
);
3968 gfc_free_expr (inquire
->id
);
3969 gfc_free_expr (inquire
->sign
);
3970 gfc_free_expr (inquire
->size
);
3971 gfc_free_expr (inquire
->round
);
3976 /* Match an element of an INQUIRE statement. */
3978 #define RETM if (m != MATCH_NO) return m;
3981 match_inquire_element (gfc_inquire
*inquire
)
3985 m
= match_etag (&tag_unit
, &inquire
->unit
);
3986 RETM m
= match_etag (&tag_file
, &inquire
->file
);
3987 RETM m
= match_ltag (&tag_err
, &inquire
->err
);
3988 RETM m
= match_etag (&tag_iomsg
, &inquire
->iomsg
);
3989 if (m
== MATCH_YES
&& !check_char_variable (inquire
->iomsg
))
3991 RETM m
= match_out_tag (&tag_iostat
, &inquire
->iostat
);
3992 RETM m
= match_vtag (&tag_exist
, &inquire
->exist
);
3993 RETM m
= match_vtag (&tag_opened
, &inquire
->opened
);
3994 RETM m
= match_vtag (&tag_named
, &inquire
->named
);
3995 RETM m
= match_vtag (&tag_name
, &inquire
->name
);
3996 RETM m
= match_out_tag (&tag_number
, &inquire
->number
);
3997 RETM m
= match_vtag (&tag_s_access
, &inquire
->access
);
3998 RETM m
= match_vtag (&tag_sequential
, &inquire
->sequential
);
3999 RETM m
= match_vtag (&tag_direct
, &inquire
->direct
);
4000 RETM m
= match_vtag (&tag_s_form
, &inquire
->form
);
4001 RETM m
= match_vtag (&tag_formatted
, &inquire
->formatted
);
4002 RETM m
= match_vtag (&tag_unformatted
, &inquire
->unformatted
);
4003 RETM m
= match_out_tag (&tag_s_recl
, &inquire
->recl
);
4004 RETM m
= match_out_tag (&tag_nextrec
, &inquire
->nextrec
);
4005 RETM m
= match_vtag (&tag_s_blank
, &inquire
->blank
);
4006 RETM m
= match_vtag (&tag_s_position
, &inquire
->position
);
4007 RETM m
= match_vtag (&tag_s_action
, &inquire
->action
);
4008 RETM m
= match_vtag (&tag_read
, &inquire
->read
);
4009 RETM m
= match_vtag (&tag_write
, &inquire
->write
);
4010 RETM m
= match_vtag (&tag_readwrite
, &inquire
->readwrite
);
4011 RETM m
= match_vtag (&tag_s_async
, &inquire
->asynchronous
);
4012 if (m
== MATCH_YES
&& !is_char_type ("ASYNCHRONOUS", inquire
->asynchronous
))
4014 RETM m
= match_vtag (&tag_s_delim
, &inquire
->delim
);
4015 RETM m
= match_vtag (&tag_s_decimal
, &inquire
->decimal
);
4016 RETM m
= match_out_tag (&tag_size
, &inquire
->size
);
4017 RETM m
= match_vtag (&tag_s_encoding
, &inquire
->encoding
);
4018 RETM m
= match_vtag (&tag_s_round
, &inquire
->round
);
4019 RETM m
= match_vtag (&tag_s_sign
, &inquire
->sign
);
4020 RETM m
= match_vtag (&tag_s_pad
, &inquire
->pad
);
4021 RETM m
= match_out_tag (&tag_iolength
, &inquire
->iolength
);
4022 RETM m
= match_vtag (&tag_convert
, &inquire
->convert
);
4023 RETM m
= match_out_tag (&tag_strm_out
, &inquire
->strm_pos
);
4024 RETM m
= match_vtag (&tag_pending
, &inquire
->pending
);
4025 RETM m
= match_vtag (&tag_id
, &inquire
->id
);
4026 RETM m
= match_vtag (&tag_s_iqstream
, &inquire
->iqstream
);
4027 RETM
return MATCH_NO
;
4034 gfc_match_inquire (void)
4036 gfc_inquire
*inquire
;
4041 m
= gfc_match_char ('(');
4045 inquire
= XCNEW (gfc_inquire
);
4047 loc
= gfc_current_locus
;
4049 m
= match_inquire_element (inquire
);
4050 if (m
== MATCH_ERROR
)
4054 m
= gfc_match_expr (&inquire
->unit
);
4055 if (m
== MATCH_ERROR
)
4061 /* See if we have the IOLENGTH form of the inquire statement. */
4062 if (inquire
->iolength
!= NULL
)
4064 if (gfc_match_char (')') != MATCH_YES
)
4067 m
= match_io_list (M_INQUIRE
, &code
);
4068 if (m
== MATCH_ERROR
)
4073 new_st
.op
= EXEC_IOLENGTH
;
4074 new_st
.expr1
= inquire
->iolength
;
4075 new_st
.ext
.inquire
= inquire
;
4077 if (gfc_pure (NULL
))
4079 gfc_free_statements (code
);
4080 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4084 gfc_unset_implicit_pure (NULL
);
4086 new_st
.block
= gfc_get_code (EXEC_IOLENGTH
);
4087 terminate_io (code
);
4088 new_st
.block
->next
= code
;
4092 /* At this point, we have the non-IOLENGTH inquire statement. */
4095 if (gfc_match_char (')') == MATCH_YES
)
4097 if (gfc_match_char (',') != MATCH_YES
)
4100 m
= match_inquire_element (inquire
);
4101 if (m
== MATCH_ERROR
)
4106 if (inquire
->iolength
!= NULL
)
4108 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
4113 if (gfc_match_eos () != MATCH_YES
)
4116 if (inquire
->unit
!= NULL
&& inquire
->file
!= NULL
)
4118 gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
4119 "UNIT specifiers", &loc
);
4123 if (inquire
->unit
== NULL
&& inquire
->file
== NULL
)
4125 gfc_error ("INQUIRE statement at %L requires either FILE or "
4126 "UNIT specifier", &loc
);
4130 if (inquire
->unit
!= NULL
&& inquire
->unit
->expr_type
== EXPR_CONSTANT
4131 && inquire
->unit
->ts
.type
== BT_INTEGER
4132 && mpz_get_si (inquire
->unit
->value
.integer
) == GFC_INTERNAL_UNIT
)
4134 gfc_error ("UNIT number in INQUIRE statement at %L can not be -1", &loc
);
4138 if (gfc_pure (NULL
))
4140 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4144 gfc_unset_implicit_pure (NULL
);
4146 if (inquire
->id
!= NULL
&& inquire
->pending
== NULL
)
4148 gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
4149 "the ID= specifier", &loc
);
4153 new_st
.op
= EXEC_INQUIRE
;
4154 new_st
.ext
.inquire
= inquire
;
4158 gfc_syntax_error (ST_INQUIRE
);
4161 gfc_free_inquire (inquire
);
4166 /* Resolve everything in a gfc_inquire structure. */
4169 gfc_resolve_inquire (gfc_inquire
*inquire
)
4171 RESOLVE_TAG (&tag_unit
, inquire
->unit
);
4172 RESOLVE_TAG (&tag_file
, inquire
->file
);
4173 RESOLVE_TAG (&tag_id
, inquire
->id
);
4175 /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4176 contexts. Thus, use an extended RESOLVE_TAG macro for that. */
4177 #define INQUIRE_RESOLVE_TAG(tag, expr) \
4178 RESOLVE_TAG (tag, expr); \
4182 sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
4183 if (gfc_check_vardef_context ((expr), false, false, false, \
4184 context) == false) \
4187 INQUIRE_RESOLVE_TAG (&tag_iomsg
, inquire
->iomsg
);
4188 INQUIRE_RESOLVE_TAG (&tag_iostat
, inquire
->iostat
);
4189 INQUIRE_RESOLVE_TAG (&tag_exist
, inquire
->exist
);
4190 INQUIRE_RESOLVE_TAG (&tag_opened
, inquire
->opened
);
4191 INQUIRE_RESOLVE_TAG (&tag_number
, inquire
->number
);
4192 INQUIRE_RESOLVE_TAG (&tag_named
, inquire
->named
);
4193 INQUIRE_RESOLVE_TAG (&tag_name
, inquire
->name
);
4194 INQUIRE_RESOLVE_TAG (&tag_s_access
, inquire
->access
);
4195 INQUIRE_RESOLVE_TAG (&tag_sequential
, inquire
->sequential
);
4196 INQUIRE_RESOLVE_TAG (&tag_direct
, inquire
->direct
);
4197 INQUIRE_RESOLVE_TAG (&tag_s_form
, inquire
->form
);
4198 INQUIRE_RESOLVE_TAG (&tag_formatted
, inquire
->formatted
);
4199 INQUIRE_RESOLVE_TAG (&tag_unformatted
, inquire
->unformatted
);
4200 INQUIRE_RESOLVE_TAG (&tag_s_recl
, inquire
->recl
);
4201 INQUIRE_RESOLVE_TAG (&tag_nextrec
, inquire
->nextrec
);
4202 INQUIRE_RESOLVE_TAG (&tag_s_blank
, inquire
->blank
);
4203 INQUIRE_RESOLVE_TAG (&tag_s_position
, inquire
->position
);
4204 INQUIRE_RESOLVE_TAG (&tag_s_action
, inquire
->action
);
4205 INQUIRE_RESOLVE_TAG (&tag_read
, inquire
->read
);
4206 INQUIRE_RESOLVE_TAG (&tag_write
, inquire
->write
);
4207 INQUIRE_RESOLVE_TAG (&tag_readwrite
, inquire
->readwrite
);
4208 INQUIRE_RESOLVE_TAG (&tag_s_delim
, inquire
->delim
);
4209 INQUIRE_RESOLVE_TAG (&tag_s_pad
, inquire
->pad
);
4210 INQUIRE_RESOLVE_TAG (&tag_s_encoding
, inquire
->encoding
);
4211 INQUIRE_RESOLVE_TAG (&tag_s_round
, inquire
->round
);
4212 INQUIRE_RESOLVE_TAG (&tag_iolength
, inquire
->iolength
);
4213 INQUIRE_RESOLVE_TAG (&tag_convert
, inquire
->convert
);
4214 INQUIRE_RESOLVE_TAG (&tag_strm_out
, inquire
->strm_pos
);
4215 INQUIRE_RESOLVE_TAG (&tag_s_async
, inquire
->asynchronous
);
4216 INQUIRE_RESOLVE_TAG (&tag_s_sign
, inquire
->sign
);
4217 INQUIRE_RESOLVE_TAG (&tag_s_round
, inquire
->round
);
4218 INQUIRE_RESOLVE_TAG (&tag_pending
, inquire
->pending
);
4219 INQUIRE_RESOLVE_TAG (&tag_size
, inquire
->size
);
4220 INQUIRE_RESOLVE_TAG (&tag_s_decimal
, inquire
->decimal
);
4221 INQUIRE_RESOLVE_TAG (&tag_s_iqstream
, inquire
->iqstream
);
4222 #undef INQUIRE_RESOLVE_TAG
4224 if (!gfc_reference_st_label (inquire
->err
, ST_LABEL_TARGET
))
4232 gfc_free_wait (gfc_wait
*wait
)
4237 gfc_free_expr (wait
->unit
);
4238 gfc_free_expr (wait
->iostat
);
4239 gfc_free_expr (wait
->iomsg
);
4240 gfc_free_expr (wait
->id
);
4246 gfc_resolve_wait (gfc_wait
*wait
)
4248 RESOLVE_TAG (&tag_unit
, wait
->unit
);
4249 RESOLVE_TAG (&tag_iomsg
, wait
->iomsg
);
4250 RESOLVE_TAG (&tag_iostat
, wait
->iostat
);
4251 RESOLVE_TAG (&tag_id
, wait
->id
);
4253 if (!gfc_reference_st_label (wait
->err
, ST_LABEL_TARGET
))
4256 if (!gfc_reference_st_label (wait
->end
, ST_LABEL_TARGET
))
4262 /* Match an element of a WAIT statement. */
4264 #define RETM if (m != MATCH_NO) return m;
4267 match_wait_element (gfc_wait
*wait
)
4271 m
= match_etag (&tag_unit
, &wait
->unit
);
4272 RETM m
= match_ltag (&tag_err
, &wait
->err
);
4273 RETM m
= match_ltag (&tag_end
, &wait
->eor
);
4274 RETM m
= match_ltag (&tag_eor
, &wait
->end
);
4275 RETM m
= match_etag (&tag_iomsg
, &wait
->iomsg
);
4276 if (m
== MATCH_YES
&& !check_char_variable (wait
->iomsg
))
4278 RETM m
= match_out_tag (&tag_iostat
, &wait
->iostat
);
4279 RETM m
= match_etag (&tag_id
, &wait
->id
);
4280 RETM
return MATCH_NO
;
4287 gfc_match_wait (void)
4292 m
= gfc_match_char ('(');
4296 wait
= XCNEW (gfc_wait
);
4298 m
= match_wait_element (wait
);
4299 if (m
== MATCH_ERROR
)
4303 m
= gfc_match_expr (&wait
->unit
);
4304 if (m
== MATCH_ERROR
)
4312 if (gfc_match_char (')') == MATCH_YES
)
4314 if (gfc_match_char (',') != MATCH_YES
)
4317 m
= match_wait_element (wait
);
4318 if (m
== MATCH_ERROR
)
4324 if (!gfc_notify_std (GFC_STD_F2003
, "WAIT at %C "
4325 "not allowed in Fortran 95"))
4328 if (gfc_pure (NULL
))
4330 gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4334 gfc_unset_implicit_pure (NULL
);
4336 new_st
.op
= EXEC_WAIT
;
4337 new_st
.ext
.wait
= wait
;
4342 gfc_syntax_error (ST_WAIT
);
4345 gfc_free_wait (wait
);