1 /* Deal with I/O statements & related stuff.
2 Copyright (C) 2000-2017 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_readonly
= {"READONLY", " readonly", NULL
, BT_UNKNOWN
},
42 tag_shared
= {"SHARE", " shared", NULL
, BT_UNKNOWN
},
43 tag_noshared
= {"SHARE", " noshared", NULL
, BT_UNKNOWN
},
44 tag_e_share
= {"SHARE", " share =", " %e", BT_CHARACTER
},
45 tag_v_share
= {"SHARE", " share =", " %v", BT_CHARACTER
},
46 tag_cc
= {"CARRIAGECONTROL", " carriagecontrol =", " %e",
48 tag_v_cc
= {"CARRIAGECONTROL", " carriagecontrol =", " %v",
50 tag_file
= {"FILE", " file =", " %e", BT_CHARACTER
},
51 tag_status
= {"STATUS", " status =", " %e", BT_CHARACTER
},
52 tag_e_access
= {"ACCESS", " access =", " %e", BT_CHARACTER
},
53 tag_e_form
= {"FORM", " form =", " %e", BT_CHARACTER
},
54 tag_e_recl
= {"RECL", " recl =", " %e", BT_INTEGER
},
55 tag_e_blank
= {"BLANK", " blank =", " %e", BT_CHARACTER
},
56 tag_e_position
= {"POSITION", " position =", " %e", BT_CHARACTER
},
57 tag_e_action
= {"ACTION", " action =", " %e", BT_CHARACTER
},
58 tag_e_delim
= {"DELIM", " delim =", " %e", BT_CHARACTER
},
59 tag_e_pad
= {"PAD", " pad =", " %e", BT_CHARACTER
},
60 tag_e_decimal
= {"DECIMAL", " decimal =", " %e", BT_CHARACTER
},
61 tag_e_encoding
= {"ENCODING", " encoding =", " %e", BT_CHARACTER
},
62 tag_e_async
= {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER
},
63 tag_e_round
= {"ROUND", " round =", " %e", BT_CHARACTER
},
64 tag_e_sign
= {"SIGN", " sign =", " %e", BT_CHARACTER
},
65 tag_unit
= {"UNIT", " unit =", " %e", BT_INTEGER
},
66 tag_advance
= {"ADVANCE", " advance =", " %e", BT_CHARACTER
},
67 tag_rec
= {"REC", " rec =", " %e", BT_INTEGER
},
68 tag_spos
= {"POSITION", " pos =", " %e", BT_INTEGER
},
69 tag_format
= {"FORMAT", NULL
, NULL
, BT_CHARACTER
},
70 tag_iomsg
= {"IOMSG", " iomsg =", " %e", BT_CHARACTER
},
71 tag_iostat
= {"IOSTAT", " iostat =", " %v", BT_INTEGER
},
72 tag_size
= {"SIZE", " size =", " %v", BT_INTEGER
},
73 tag_exist
= {"EXIST", " exist =", " %v", BT_LOGICAL
},
74 tag_opened
= {"OPENED", " opened =", " %v", BT_LOGICAL
},
75 tag_named
= {"NAMED", " named =", " %v", BT_LOGICAL
},
76 tag_name
= {"NAME", " name =", " %v", BT_CHARACTER
},
77 tag_number
= {"NUMBER", " number =", " %v", BT_INTEGER
},
78 tag_s_access
= {"ACCESS", " access =", " %v", BT_CHARACTER
},
79 tag_sequential
= {"SEQUENTIAL", " sequential =", " %v", BT_CHARACTER
},
80 tag_direct
= {"DIRECT", " direct =", " %v", BT_CHARACTER
},
81 tag_s_form
= {"FORM", " form =", " %v", BT_CHARACTER
},
82 tag_formatted
= {"FORMATTED", " formatted =", " %v", BT_CHARACTER
},
83 tag_unformatted
= {"UNFORMATTED", " unformatted =", " %v", BT_CHARACTER
},
84 tag_s_recl
= {"RECL", " recl =", " %v", BT_INTEGER
},
85 tag_nextrec
= {"NEXTREC", " nextrec =", " %v", BT_INTEGER
},
86 tag_s_blank
= {"BLANK", " blank =", " %v", BT_CHARACTER
},
87 tag_s_position
= {"POSITION", " position =", " %v", BT_CHARACTER
},
88 tag_s_action
= {"ACTION", " action =", " %v", BT_CHARACTER
},
89 tag_read
= {"READ", " read =", " %v", BT_CHARACTER
},
90 tag_write
= {"WRITE", " write =", " %v", BT_CHARACTER
},
91 tag_readwrite
= {"READWRITE", " readwrite =", " %v", BT_CHARACTER
},
92 tag_s_delim
= {"DELIM", " delim =", " %v", BT_CHARACTER
},
93 tag_s_pad
= {"PAD", " pad =", " %v", BT_CHARACTER
},
94 tag_s_decimal
= {"DECIMAL", " decimal =", " %v", BT_CHARACTER
},
95 tag_s_encoding
= {"ENCODING", " encoding =", " %v", BT_CHARACTER
},
96 tag_s_async
= {"ASYNCHRONOUS", " asynchronous =", " %v", BT_CHARACTER
},
97 tag_s_round
= {"ROUND", " round =", " %v", BT_CHARACTER
},
98 tag_s_sign
= {"SIGN", " sign =", " %v", BT_CHARACTER
},
99 tag_iolength
= {"IOLENGTH", " iolength =", " %v", BT_INTEGER
},
100 tag_convert
= {"CONVERT", " convert =", " %e", BT_CHARACTER
},
101 tag_strm_out
= {"POS", " pos =", " %v", BT_INTEGER
},
102 tag_err
= {"ERR", " err =", " %l", BT_UNKNOWN
},
103 tag_end
= {"END", " end =", " %l", BT_UNKNOWN
},
104 tag_eor
= {"EOR", " eor =", " %l", BT_UNKNOWN
},
105 tag_id
= {"ID", " id =", " %v", BT_INTEGER
},
106 tag_pending
= {"PENDING", " pending =", " %v", BT_LOGICAL
},
107 tag_newunit
= {"NEWUNIT", " newunit =", " %v", BT_INTEGER
},
108 tag_s_iqstream
= {"STREAM", " stream =", " %v", BT_CHARACTER
};
110 static gfc_dt
*current_dt
;
112 #define RESOLVE_TAG(x, y) if (!resolve_tag (x, y)) return false;
114 /* Are we currently processing an asynchronous I/O statement? */
118 /**************** Fortran 95 FORMAT parser *****************/
120 /* FORMAT tokens returned by format_lex(). */
123 FMT_NONE
, FMT_UNKNOWN
, FMT_SIGNED_INT
, FMT_ZERO
, FMT_POSINT
, FMT_PERIOD
,
124 FMT_COMMA
, FMT_COLON
, FMT_SLASH
, FMT_DOLLAR
, FMT_LPAREN
,
125 FMT_RPAREN
, FMT_X
, FMT_SIGN
, FMT_BLANK
, FMT_CHAR
, FMT_P
, FMT_IBOZ
, FMT_F
,
126 FMT_E
, FMT_EN
, FMT_ES
, FMT_G
, FMT_L
, FMT_A
, FMT_D
, FMT_H
, FMT_END
,
127 FMT_ERROR
, FMT_DC
, FMT_DP
, FMT_T
, FMT_TR
, FMT_TL
, FMT_STAR
, FMT_RC
,
128 FMT_RD
, FMT_RN
, FMT_RP
, FMT_RU
, FMT_RZ
, FMT_DT
131 /* Local variables for checking format strings. The saved_token is
132 used to back up by a single format token during the parsing
134 static gfc_char_t
*format_string
;
135 static int format_string_pos
;
136 static int format_length
, use_last_char
;
137 static char error_element
;
138 static locus format_locus
;
140 static format_token saved_token
;
143 { MODE_STRING
, MODE_FORMAT
, MODE_COPY
}
147 /* Return the next character in the format string. */
150 next_char (gfc_instring in_string
)
162 if (mode
== MODE_STRING
)
163 c
= *format_string
++;
166 c
= gfc_next_char_literal (in_string
);
171 if (flag_backslash
&& c
== '\\')
173 locus old_locus
= gfc_current_locus
;
175 if (gfc_match_special_char (&c
) == MATCH_NO
)
176 gfc_current_locus
= old_locus
;
178 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
179 gfc_warning (0, "Extension: backslash character at %C");
182 if (mode
== MODE_COPY
)
183 *format_string
++ = c
;
185 if (mode
!= MODE_STRING
)
186 format_locus
= gfc_current_locus
;
190 c
= gfc_wide_toupper (c
);
195 /* Back up one character position. Only works once. */
203 /* Eat up the spaces and return a character. */
206 next_char_not_space ()
211 error_element
= c
= next_char (NONSTRING
);
213 gfc_warning (OPT_Wtabs
, "Nonconforming tab character in format at %C");
215 while (gfc_is_whitespace (c
));
219 static int value
= 0;
221 /* Simple lexical analyzer for getting the next token in a FORMAT
232 if (saved_token
!= FMT_NONE
)
235 saved_token
= FMT_NONE
;
239 c
= next_char_not_space ();
249 c
= next_char_not_space ();
260 c
= next_char_not_space ();
262 value
= 10 * value
+ c
- '0';
271 token
= FMT_SIGNED_INT
;
290 c
= next_char_not_space ();
293 value
= 10 * value
+ c
- '0';
301 token
= zflag
? FMT_ZERO
: FMT_POSINT
;
325 c
= next_char_not_space ();
353 c
= next_char_not_space ();
354 if (c
!= 'P' && c
!= 'S')
361 c
= next_char_not_space ();
362 if (c
== 'N' || c
== 'Z')
380 c
= next_char (INSTRING_WARN
);
389 c
= next_char (NONSTRING
);
423 c
= next_char_not_space ();
453 c
= next_char_not_space ();
456 if (!gfc_notify_std (GFC_STD_F2003
, "DP format "
457 "specifier not allowed at %C"))
463 if (!gfc_notify_std (GFC_STD_F2003
, "DC format "
464 "specifier not allowed at %C"))
470 if (!gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: DT format "
471 "specifier not allowed at %C"))
474 c
= next_char_not_space ();
475 if (c
== '\'' || c
== '"')
482 c
= next_char (INSTRING_WARN
);
491 c
= next_char (NONSTRING
);
525 c
= next_char_not_space ();
571 token_to_string (format_token t
)
590 /* Check a format statement. The format string, either from a FORMAT
591 statement or a constant in an I/O statement has already been parsed
592 by itself, and we are checking it for validity. The dual origin
593 means that the warning message is a little less than great. */
596 check_format (bool is_input
)
598 const char *posint_required
= _("Positive width required");
599 const char *nonneg_required
= _("Nonnegative width required");
600 const char *unexpected_element
= _("Unexpected element %qc in format "
602 const char *unexpected_end
= _("Unexpected end of format string");
603 const char *zero_width
= _("Zero width in format descriptor");
605 const char *error
= NULL
;
612 saved_token
= FMT_NONE
;
616 format_string_pos
= 0;
623 error
= _("Missing leading left parenthesis");
631 goto finished
; /* Empty format is legal */
635 /* In this state, the next thing has to be a format item. */
652 error
= _("Left parenthesis required after %<*%>");
677 /* Signed integer can only precede a P format. */
683 error
= _("Expected P edit descriptor");
690 /* P requires a prior number. */
691 error
= _("P descriptor requires leading scale factor");
695 /* X requires a prior number if we're being pedantic. */
696 if (mode
!= MODE_FORMAT
)
697 format_locus
.nextc
+= format_string_pos
;
698 if (!gfc_notify_std (GFC_STD_GNU
, "X descriptor requires leading "
699 "space count at %L", &format_locus
))
716 goto extension_optional_comma
;
727 if (!gfc_notify_std (GFC_STD_GNU
, "$ descriptor at %L", &format_locus
))
729 if (t
!= FMT_RPAREN
|| level
> 0)
731 gfc_warning (0, "$ should be the last specifier in format at %L",
733 goto optional_comma_1
;
755 error
= unexpected_end
;
759 error
= unexpected_element
;
764 /* In this state, t must currently be a data descriptor.
765 Deal with things that can/must follow the descriptor. */
776 /* No comma after P allowed only for F, E, EN, ES, D, or G.
781 if (!(gfc_option
.allow_std
& GFC_STD_F2003
) && t
!= FMT_COMMA
782 && t
!= FMT_F
&& t
!= FMT_E
&& t
!= FMT_EN
&& t
!= FMT_ES
783 && t
!= FMT_D
&& t
!= FMT_G
&& t
!= FMT_RPAREN
&& t
!= FMT_SLASH
)
785 error
= _("Comma required after P descriptor");
796 if (t
!= FMT_F
&& t
!= FMT_E
&& t
!= FMT_EN
&& t
!= FMT_ES
&& t
!= FMT_D
797 && t
!= FMT_G
&& t
!= FMT_RPAREN
&& t
!= FMT_SLASH
)
799 error
= _("Comma required after P descriptor");
813 error
= _("Positive width required with T descriptor");
824 if (mode
!= MODE_FORMAT
)
825 format_locus
.nextc
+= format_string_pos
;
828 switch (gfc_notification_std (GFC_STD_GNU
))
831 gfc_warning (0, "Extension: Zero width after L "
832 "descriptor at %L", &format_locus
);
835 gfc_error ("Extension: Zero width after L "
836 "descriptor at %L", &format_locus
);
847 gfc_notify_std (GFC_STD_GNU
, "Missing positive width after "
848 "L descriptor at %L", &format_locus
);
871 if (t
== FMT_G
&& u
== FMT_ZERO
)
878 if (!gfc_notify_std (GFC_STD_F2008
, "%<G0%> in format at %L",
890 error
= posint_required
;
896 error
= _("E specifier not allowed with g0 descriptor");
905 format_locus
.nextc
+= format_string_pos
;
906 gfc_error ("Positive width required in format "
907 "specifier %s at %L", token_to_string (t
),
918 /* Warn if -std=legacy, otherwise error. */
919 format_locus
.nextc
+= format_string_pos
;
920 if (gfc_option
.warn_std
!= 0)
922 gfc_error ("Period required in format "
923 "specifier %s at %L", token_to_string (t
),
929 gfc_warning (0, "Period required in format "
930 "specifier %s at %L", token_to_string (t
),
932 /* If we go to finished, we need to unwind this
933 before the next round. */
934 format_locus
.nextc
-= format_string_pos
;
942 if (u
!= FMT_ZERO
&& u
!= FMT_POSINT
)
944 error
= nonneg_required
;
951 /* Look for optional exponent. */
966 error
= _("Positive exponent width required");
997 error
= posint_required
;
1007 if (t
!= FMT_RPAREN
)
1009 error
= _("Right parenthesis expected at %C");
1015 error
= unexpected_element
;
1024 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
1026 error
= nonneg_required
;
1029 else if (is_input
&& t
== FMT_ZERO
)
1031 error
= posint_required
;
1038 if (t
!= FMT_PERIOD
)
1040 /* Warn if -std=legacy, otherwise error. */
1041 if (gfc_option
.warn_std
!= 0)
1043 error
= _("Period required in format specifier");
1046 if (mode
!= MODE_FORMAT
)
1047 format_locus
.nextc
+= format_string_pos
;
1048 gfc_warning (0, "Period required in format specifier at %L",
1057 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
1059 error
= nonneg_required
;
1066 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
1068 if (mode
!= MODE_FORMAT
)
1069 format_locus
.nextc
+= format_string_pos
;
1070 gfc_warning (0, "The H format specifier at %L is"
1071 " a Fortran 95 deleted feature", &format_locus
);
1073 if (mode
== MODE_STRING
)
1075 format_string
+= value
;
1076 format_length
-= value
;
1077 format_string_pos
+= repeat
;
1083 next_char (INSTRING_WARN
);
1093 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
1095 error
= nonneg_required
;
1098 else if (is_input
&& t
== FMT_ZERO
)
1100 error
= posint_required
;
1107 if (t
!= FMT_PERIOD
)
1116 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
1118 error
= nonneg_required
;
1126 error
= unexpected_element
;
1131 /* Between a descriptor and what comes next. */
1149 goto optional_comma
;
1152 error
= unexpected_end
;
1156 if (mode
!= MODE_FORMAT
)
1157 format_locus
.nextc
+= format_string_pos
- 1;
1158 if (!gfc_notify_std (GFC_STD_GNU
, "Missing comma at %L", &format_locus
))
1160 /* If we do not actually return a failure, we need to unwind this
1161 before the next round. */
1162 if (mode
!= MODE_FORMAT
)
1163 format_locus
.nextc
-= format_string_pos
;
1168 /* Optional comma is a weird between state where we've just finished
1169 reading a colon, slash, dollar or P descriptor. */
1186 /* Assume that we have another format item. */
1193 extension_optional_comma
:
1194 /* As a GNU extension, permit a missing comma after a string literal. */
1211 goto optional_comma
;
1214 error
= unexpected_end
;
1218 if (mode
!= MODE_FORMAT
)
1219 format_locus
.nextc
+= format_string_pos
;
1220 if (!gfc_notify_std (GFC_STD_GNU
, "Missing comma at %L", &format_locus
))
1222 /* If we do not actually return a failure, we need to unwind this
1223 before the next round. */
1224 if (mode
!= MODE_FORMAT
)
1225 format_locus
.nextc
-= format_string_pos
;
1233 if (mode
!= MODE_FORMAT
)
1234 format_locus
.nextc
+= format_string_pos
;
1235 if (error
== unexpected_element
)
1236 gfc_error (error
, error_element
, &format_locus
);
1238 gfc_error ("%s in format string at %L", error
, &format_locus
);
1247 /* Given an expression node that is a constant string, see if it looks
1248 like a format string. */
1251 check_format_string (gfc_expr
*e
, bool is_input
)
1255 if (!e
|| e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1259 format_string
= e
->value
.character
.string
;
1261 /* More elaborate measures are needed to show where a problem is within a
1262 format string that has been calculated, but that's probably not worth the
1264 format_locus
= e
->where
;
1265 rv
= check_format (is_input
);
1266 /* check for extraneous characters at the end of an otherwise valid format
1267 string, like '(A10,I3)F5'
1268 start at the end and move back to the last character processed,
1270 if (rv
&& e
->value
.character
.length
> format_string_pos
)
1271 for (i
=e
->value
.character
.length
-1;i
>format_string_pos
-1;i
--)
1272 if (e
->value
.character
.string
[i
] != ' ')
1274 format_locus
.nextc
+= format_length
+ 1;
1276 "Extraneous characters in format at %L", &format_locus
);
1283 /************ Fortran I/O statement matchers *************/
1285 /* Match a FORMAT statement. This amounts to actually parsing the
1286 format descriptors in order to correctly locate the end of the
1290 gfc_match_format (void)
1295 if (gfc_current_ns
->proc_name
1296 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1298 gfc_error ("Format statement in module main block at %C");
1302 /* Before parsing the rest of a FORMAT statement, check F2008:c1206. */
1303 if ((gfc_current_state () == COMP_FUNCTION
1304 || gfc_current_state () == COMP_SUBROUTINE
)
1305 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
1307 gfc_error ("FORMAT statement at %C cannot appear within an INTERFACE");
1311 if (gfc_statement_label
== NULL
)
1313 gfc_error ("Missing format label at %C");
1316 gfc_gobble_whitespace ();
1321 start
= gfc_current_locus
;
1323 if (!check_format (false))
1326 if (gfc_match_eos () != MATCH_YES
)
1328 gfc_syntax_error (ST_FORMAT
);
1332 /* The label doesn't get created until after the statement is done
1333 being matched, so we have to leave the string for later. */
1335 gfc_current_locus
= start
; /* Back to the beginning */
1338 new_st
.op
= EXEC_NOP
;
1340 e
= gfc_get_character_expr (gfc_default_character_kind
, &start
,
1341 NULL
, format_length
);
1342 format_string
= e
->value
.character
.string
;
1343 gfc_statement_label
->format
= e
;
1346 check_format (false); /* Guaranteed to succeed */
1347 gfc_match_eos (); /* Guaranteed to succeed */
1353 /* Check for a CHARACTER variable. The check for scalar is done in
1357 check_char_variable (gfc_expr
*e
)
1359 if (e
->expr_type
!= EXPR_VARIABLE
|| e
->ts
.type
!= BT_CHARACTER
)
1361 gfc_error("IOMSG must be a scalar-default-char-variable at %L", &e
->where
);
1369 is_char_type (const char *name
, gfc_expr
*e
)
1371 gfc_resolve_expr (e
);
1373 if (e
->ts
.type
!= BT_CHARACTER
)
1375 gfc_error ("%s requires a scalar-default-char-expr at %L",
1383 /* Match an expression I/O tag of some sort. */
1386 match_etag (const io_tag
*tag
, gfc_expr
**v
)
1391 m
= gfc_match (tag
->spec
);
1395 m
= gfc_match (tag
->value
, &result
);
1398 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1404 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1405 gfc_free_expr (result
);
1414 /* Match a variable I/O tag of some sort. */
1417 match_vtag (const io_tag
*tag
, gfc_expr
**v
)
1422 m
= gfc_match (tag
->spec
);
1426 m
= gfc_match (tag
->value
, &result
);
1429 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1435 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1436 gfc_free_expr (result
);
1440 if (result
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1442 gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag
->name
);
1443 gfc_free_expr (result
);
1447 bool impure
= gfc_impure_variable (result
->symtree
->n
.sym
);
1448 if (impure
&& gfc_pure (NULL
))
1450 gfc_error ("Variable %s cannot be assigned in PURE procedure at %C",
1452 gfc_free_expr (result
);
1457 gfc_unset_implicit_pure (NULL
);
1464 /* Match I/O tags that cause variables to become redefined. */
1467 match_out_tag (const io_tag
*tag
, gfc_expr
**result
)
1471 m
= match_vtag (tag
, result
);
1473 gfc_check_do_variable ((*result
)->symtree
);
1479 /* Match a label I/O tag. */
1482 match_ltag (const io_tag
*tag
, gfc_st_label
** label
)
1488 m
= gfc_match (tag
->spec
);
1492 m
= gfc_match (tag
->value
, label
);
1495 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1501 gfc_error ("Duplicate %s label specification at %C", tag
->name
);
1505 if (!gfc_reference_st_label (*label
, ST_LABEL_TARGET
))
1512 /* Match a tag using match_etag, but only if -fdec is enabled. */
1514 match_dec_etag (const io_tag
*tag
, gfc_expr
**e
)
1516 match m
= match_etag (tag
, e
);
1517 if (flag_dec
&& m
!= MATCH_NO
)
1519 else if (m
!= MATCH_NO
)
1521 gfc_error ("%s at %C is a DEC extension, enable with "
1522 "%<-fdec%>", tag
->name
);
1529 /* Match a tag using match_vtag, but only if -fdec is enabled. */
1531 match_dec_vtag (const io_tag
*tag
, gfc_expr
**e
)
1533 match m
= match_vtag(tag
, e
);
1534 if (flag_dec
&& m
!= MATCH_NO
)
1536 else if (m
!= MATCH_NO
)
1538 gfc_error ("%s at %C is a DEC extension, enable with "
1539 "%<-fdec%>", tag
->name
);
1546 /* Match a DEC I/O flag tag - a tag with no expression such as READONLY. */
1549 match_dec_ftag (const io_tag
*tag
, gfc_open
*o
)
1553 m
= gfc_match (tag
->spec
);
1559 gfc_error ("%s at %C is a DEC extension, enable with "
1560 "%<-fdec%>", tag
->name
);
1564 /* Just set the READONLY flag, which we use at runtime to avoid delete on
1566 if (tag
== &tag_readonly
)
1572 /* Interpret SHARED as SHARE='DENYNONE' (read lock). */
1573 else if (tag
== &tag_shared
)
1575 if (o
->share
!= NULL
)
1577 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1580 o
->share
= gfc_get_character_expr (gfc_default_character_kind
,
1581 &gfc_current_locus
, "denynone", 8);
1585 /* Interpret NOSHARED as SHARE='DENYRW' (exclusive lock). */
1586 else if (tag
== &tag_noshared
)
1588 if (o
->share
!= NULL
)
1590 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1593 o
->share
= gfc_get_character_expr (gfc_default_character_kind
,
1594 &gfc_current_locus
, "denyrw", 6);
1598 /* We handle all DEC tags above. */
1603 /* Resolution of the FORMAT tag, to be called from resolve_tag. */
1606 resolve_tag_format (const gfc_expr
*e
)
1608 if (e
->expr_type
== EXPR_CONSTANT
1609 && (e
->ts
.type
!= BT_CHARACTER
1610 || e
->ts
.kind
!= gfc_default_character_kind
))
1612 gfc_error ("Constant expression in FORMAT tag at %L must be "
1613 "of type default CHARACTER", &e
->where
);
1617 /* If e's rank is zero and e is not an element of an array, it should be
1618 of integer or character type. The integer variable should be
1621 && (e
->expr_type
!= EXPR_VARIABLE
1622 || e
->symtree
== NULL
1623 || e
->symtree
->n
.sym
->as
== NULL
1624 || e
->symtree
->n
.sym
->as
->rank
== 0))
1626 if ((e
->ts
.type
!= BT_CHARACTER
1627 || e
->ts
.kind
!= gfc_default_character_kind
)
1628 && e
->ts
.type
!= BT_INTEGER
)
1630 gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER "
1631 "or of INTEGER", &e
->where
);
1634 else if (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_VARIABLE
)
1636 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGNED variable in "
1637 "FORMAT tag at %L", &e
->where
))
1639 if (e
->symtree
->n
.sym
->attr
.assign
!= 1)
1641 gfc_error ("Variable %qs at %L has not been assigned a "
1642 "format label", e
->symtree
->n
.sym
->name
, &e
->where
);
1646 else if (e
->ts
.type
== BT_INTEGER
)
1648 gfc_error ("Scalar %qs in FORMAT tag at %L is not an ASSIGNED "
1649 "variable", gfc_basic_typename (e
->ts
.type
), &e
->where
);
1656 /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
1657 It may be assigned an Hollerith constant. */
1658 if (e
->ts
.type
!= BT_CHARACTER
)
1660 if (!gfc_notify_std (GFC_STD_LEGACY
, "Non-character in FORMAT tag "
1661 "at %L", &e
->where
))
1664 if (e
->rank
== 0 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
)
1666 gfc_error ("Non-character assumed shape array element in FORMAT"
1667 " tag at %L", &e
->where
);
1671 if (e
->rank
== 0 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
)
1673 gfc_error ("Non-character assumed size array element in FORMAT"
1674 " tag at %L", &e
->where
);
1678 if (e
->rank
== 0 && e
->symtree
->n
.sym
->attr
.pointer
)
1680 gfc_error ("Non-character pointer array element in FORMAT tag at %L",
1690 /* Do expression resolution and type-checking on an expression tag. */
1693 resolve_tag (const io_tag
*tag
, gfc_expr
*e
)
1698 if (!gfc_resolve_expr (e
))
1701 if (tag
== &tag_format
)
1702 return resolve_tag_format (e
);
1704 if (e
->ts
.type
!= tag
->type
)
1706 gfc_error ("%s tag at %L must be of type %s", tag
->name
,
1707 &e
->where
, gfc_basic_typename (tag
->type
));
1711 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= gfc_default_character_kind
)
1713 gfc_error ("%s tag at %L must be a character string of default kind",
1714 tag
->name
, &e
->where
);
1720 gfc_error ("%s tag at %L must be scalar", tag
->name
, &e
->where
);
1724 if (tag
== &tag_iomsg
)
1726 if (!gfc_notify_std (GFC_STD_F2003
, "IOMSG tag at %L", &e
->where
))
1730 if ((tag
== &tag_iostat
|| tag
== &tag_size
|| tag
== &tag_iolength
1731 || tag
== &tag_number
|| tag
== &tag_nextrec
|| tag
== &tag_s_recl
)
1732 && e
->ts
.kind
!= gfc_default_integer_kind
)
1734 if (!gfc_notify_std (GFC_STD_F2003
, "Fortran 95 requires default "
1735 "INTEGER in %s tag at %L", tag
->name
, &e
->where
))
1739 if (e
->ts
.kind
!= gfc_default_logical_kind
&&
1740 (tag
== &tag_exist
|| tag
== &tag_named
|| tag
== &tag_opened
1741 || tag
== &tag_pending
))
1743 if (!gfc_notify_std (GFC_STD_F2008
, "Non-default LOGICAL kind "
1744 "in %s tag at %L", tag
->name
, &e
->where
))
1748 if (tag
== &tag_newunit
)
1750 if (!gfc_notify_std (GFC_STD_F2008
, "NEWUNIT specifier at %L",
1755 /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */
1756 if (tag
== &tag_newunit
|| tag
== &tag_iostat
1757 || tag
== &tag_size
|| tag
== &tag_iomsg
)
1761 sprintf (context
, _("%s tag"), tag
->name
);
1762 if (!gfc_check_vardef_context (e
, false, false, false, context
))
1766 if (tag
== &tag_convert
)
1768 if (!gfc_notify_std (GFC_STD_GNU
, "CONVERT tag at %L", &e
->where
))
1776 /* Match a single tag of an OPEN statement. */
1779 match_open_element (gfc_open
*open
)
1783 m
= match_etag (&tag_e_async
, &open
->asynchronous
);
1784 if (m
== MATCH_YES
&& !is_char_type ("ASYNCHRONOUS", open
->asynchronous
))
1788 m
= match_etag (&tag_unit
, &open
->unit
);
1791 m
= match_etag (&tag_iomsg
, &open
->iomsg
);
1792 if (m
== MATCH_YES
&& !check_char_variable (open
->iomsg
))
1796 m
= match_out_tag (&tag_iostat
, &open
->iostat
);
1799 m
= match_etag (&tag_file
, &open
->file
);
1802 m
= match_etag (&tag_status
, &open
->status
);
1805 m
= match_etag (&tag_e_access
, &open
->access
);
1808 m
= match_etag (&tag_e_form
, &open
->form
);
1811 m
= match_etag (&tag_e_recl
, &open
->recl
);
1814 m
= match_etag (&tag_e_blank
, &open
->blank
);
1817 m
= match_etag (&tag_e_position
, &open
->position
);
1820 m
= match_etag (&tag_e_action
, &open
->action
);
1823 m
= match_etag (&tag_e_delim
, &open
->delim
);
1826 m
= match_etag (&tag_e_pad
, &open
->pad
);
1829 m
= match_etag (&tag_e_decimal
, &open
->decimal
);
1832 m
= match_etag (&tag_e_encoding
, &open
->encoding
);
1835 m
= match_etag (&tag_e_round
, &open
->round
);
1838 m
= match_etag (&tag_e_sign
, &open
->sign
);
1841 m
= match_ltag (&tag_err
, &open
->err
);
1844 m
= match_etag (&tag_convert
, &open
->convert
);
1847 m
= match_out_tag (&tag_newunit
, &open
->newunit
);
1851 /* The following are extensions enabled with -fdec. */
1852 m
= match_dec_etag (&tag_e_share
, &open
->share
);
1855 m
= match_dec_etag (&tag_cc
, &open
->cc
);
1858 m
= match_dec_ftag (&tag_readonly
, open
);
1861 m
= match_dec_ftag (&tag_shared
, open
);
1864 m
= match_dec_ftag (&tag_noshared
, open
);
1872 /* Free the gfc_open structure and all the expressions it contains. */
1875 gfc_free_open (gfc_open
*open
)
1880 gfc_free_expr (open
->unit
);
1881 gfc_free_expr (open
->iomsg
);
1882 gfc_free_expr (open
->iostat
);
1883 gfc_free_expr (open
->file
);
1884 gfc_free_expr (open
->status
);
1885 gfc_free_expr (open
->access
);
1886 gfc_free_expr (open
->form
);
1887 gfc_free_expr (open
->recl
);
1888 gfc_free_expr (open
->blank
);
1889 gfc_free_expr (open
->position
);
1890 gfc_free_expr (open
->action
);
1891 gfc_free_expr (open
->delim
);
1892 gfc_free_expr (open
->pad
);
1893 gfc_free_expr (open
->decimal
);
1894 gfc_free_expr (open
->encoding
);
1895 gfc_free_expr (open
->round
);
1896 gfc_free_expr (open
->sign
);
1897 gfc_free_expr (open
->convert
);
1898 gfc_free_expr (open
->asynchronous
);
1899 gfc_free_expr (open
->newunit
);
1900 gfc_free_expr (open
->share
);
1901 gfc_free_expr (open
->cc
);
1906 /* Resolve everything in a gfc_open structure. */
1909 gfc_resolve_open (gfc_open
*open
)
1912 RESOLVE_TAG (&tag_unit
, open
->unit
);
1913 RESOLVE_TAG (&tag_iomsg
, open
->iomsg
);
1914 RESOLVE_TAG (&tag_iostat
, open
->iostat
);
1915 RESOLVE_TAG (&tag_file
, open
->file
);
1916 RESOLVE_TAG (&tag_status
, open
->status
);
1917 RESOLVE_TAG (&tag_e_access
, open
->access
);
1918 RESOLVE_TAG (&tag_e_form
, open
->form
);
1919 RESOLVE_TAG (&tag_e_recl
, open
->recl
);
1920 RESOLVE_TAG (&tag_e_blank
, open
->blank
);
1921 RESOLVE_TAG (&tag_e_position
, open
->position
);
1922 RESOLVE_TAG (&tag_e_action
, open
->action
);
1923 RESOLVE_TAG (&tag_e_delim
, open
->delim
);
1924 RESOLVE_TAG (&tag_e_pad
, open
->pad
);
1925 RESOLVE_TAG (&tag_e_decimal
, open
->decimal
);
1926 RESOLVE_TAG (&tag_e_encoding
, open
->encoding
);
1927 RESOLVE_TAG (&tag_e_async
, open
->asynchronous
);
1928 RESOLVE_TAG (&tag_e_round
, open
->round
);
1929 RESOLVE_TAG (&tag_e_sign
, open
->sign
);
1930 RESOLVE_TAG (&tag_convert
, open
->convert
);
1931 RESOLVE_TAG (&tag_newunit
, open
->newunit
);
1932 RESOLVE_TAG (&tag_e_share
, open
->share
);
1933 RESOLVE_TAG (&tag_cc
, open
->cc
);
1935 if (!gfc_reference_st_label (open
->err
, ST_LABEL_TARGET
))
1942 /* Check if a given value for a SPECIFIER is either in the list of values
1943 allowed in F95 or F2003, issuing an error message and returning a zero
1944 value if it is not allowed. */
1947 compare_to_allowed_values (const char *specifier
, const char *allowed
[],
1948 const char *allowed_f2003
[],
1949 const char *allowed_gnu
[], gfc_char_t
*value
,
1950 const char *statement
, bool warn
,
1955 compare_to_allowed_values (const char *specifier
, const char *allowed
[],
1956 const char *allowed_f2003
[],
1957 const char *allowed_gnu
[], gfc_char_t
*value
,
1958 const char *statement
, bool warn
, int *num
)
1963 len
= gfc_wide_strlen (value
);
1966 for (len
--; len
> 0; len
--)
1967 if (value
[len
] != ' ')
1972 for (i
= 0; allowed
[i
]; i
++)
1973 if (len
== strlen (allowed
[i
])
1974 && gfc_wide_strncasecmp (value
, allowed
[i
], strlen (allowed
[i
])) == 0)
1981 for (i
= 0; allowed_f2003
&& allowed_f2003
[i
]; i
++)
1982 if (len
== strlen (allowed_f2003
[i
])
1983 && gfc_wide_strncasecmp (value
, allowed_f2003
[i
],
1984 strlen (allowed_f2003
[i
])) == 0)
1986 notification n
= gfc_notification_std (GFC_STD_F2003
);
1988 if (n
== WARNING
|| (warn
&& n
== ERROR
))
1990 gfc_warning (0, "Fortran 2003: %s specifier in %s statement at %C "
1991 "has value %qs", specifier
, statement
,
1998 gfc_notify_std (GFC_STD_F2003
, "%s specifier in "
1999 "%s statement at %C has value %qs", specifier
,
2000 statement
, allowed_f2003
[i
]);
2008 for (i
= 0; allowed_gnu
&& allowed_gnu
[i
]; i
++)
2009 if (len
== strlen (allowed_gnu
[i
])
2010 && gfc_wide_strncasecmp (value
, allowed_gnu
[i
],
2011 strlen (allowed_gnu
[i
])) == 0)
2013 notification n
= gfc_notification_std (GFC_STD_GNU
);
2015 if (n
== WARNING
|| (warn
&& n
== ERROR
))
2017 gfc_warning (0, "Extension: %s specifier in %s statement at %C "
2018 "has value %qs", specifier
, statement
,
2025 gfc_notify_std (GFC_STD_GNU
, "%s specifier in "
2026 "%s statement at %C has value %qs", specifier
,
2027 statement
, allowed_gnu
[i
]);
2037 char *s
= gfc_widechar_to_char (value
, -1);
2039 "%s specifier in %s statement at %C has invalid value %qs",
2040 specifier
, statement
, s
);
2046 char *s
= gfc_widechar_to_char (value
, -1);
2047 gfc_error ("%s specifier in %s statement at %C has invalid value %qs",
2048 specifier
, statement
, s
);
2055 /* Match an OPEN statement. */
2058 gfc_match_open (void)
2064 m
= gfc_match_char ('(');
2068 open
= XCNEW (gfc_open
);
2070 m
= match_open_element (open
);
2072 if (m
== MATCH_ERROR
)
2076 m
= gfc_match_expr (&open
->unit
);
2077 if (m
== MATCH_ERROR
)
2083 if (gfc_match_char (')') == MATCH_YES
)
2085 if (gfc_match_char (',') != MATCH_YES
)
2088 m
= match_open_element (open
);
2089 if (m
== MATCH_ERROR
)
2095 if (gfc_match_eos () == MATCH_NO
)
2098 if (gfc_pure (NULL
))
2100 gfc_error ("OPEN statement not allowed in PURE procedure at %C");
2104 gfc_unset_implicit_pure (NULL
);
2106 warn
= (open
->err
|| open
->iostat
) ? true : false;
2108 /* Checks on NEWUNIT specifier. */
2113 gfc_error ("UNIT specifier not allowed with NEWUNIT at %C");
2117 if (!open
->file
&& open
->status
)
2119 if (open
->status
->expr_type
== EXPR_CONSTANT
2120 && gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2123 gfc_error ("NEWUNIT specifier must have FILE= "
2124 "or STATUS='scratch' at %C");
2129 else if (!open
->unit
)
2131 gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified");
2135 /* Checks on the ACCESS specifier. */
2136 if (open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
)
2138 static const char *access_f95
[] = { "SEQUENTIAL", "DIRECT", NULL
};
2139 static const char *access_f2003
[] = { "STREAM", NULL
};
2140 static const char *access_gnu
[] = { "APPEND", NULL
};
2142 if (!is_char_type ("ACCESS", open
->access
))
2145 if (!compare_to_allowed_values ("ACCESS", access_f95
, access_f2003
,
2147 open
->access
->value
.character
.string
,
2152 /* Checks on the ACTION specifier. */
2153 if (open
->action
&& open
->action
->expr_type
== EXPR_CONSTANT
)
2155 gfc_char_t
*str
= open
->action
->value
.character
.string
;
2156 static const char *action
[] = { "READ", "WRITE", "READWRITE", NULL
};
2158 if (!is_char_type ("ACTION", open
->action
))
2161 if (!compare_to_allowed_values ("ACTION", action
, NULL
, NULL
,
2165 /* With READONLY, only allow ACTION='READ'. */
2166 if (open
->readonly
&& (gfc_wide_strlen (str
) != 4
2167 || gfc_wide_strncasecmp (str
, "READ", 4) != 0))
2169 gfc_error ("ACTION type conflicts with READONLY specifier at %C");
2173 /* If we see READONLY and no ACTION, set ACTION='READ'. */
2174 else if (open
->readonly
&& open
->action
== NULL
)
2176 open
->action
= gfc_get_character_expr (gfc_default_character_kind
,
2177 &gfc_current_locus
, "read", 4);
2180 /* Checks on the ASYNCHRONOUS specifier. */
2181 if (open
->asynchronous
)
2183 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS= at %C "
2184 "not allowed in Fortran 95"))
2187 if (!is_char_type ("ASYNCHRONOUS", open
->asynchronous
))
2190 if (open
->asynchronous
->expr_type
== EXPR_CONSTANT
)
2192 static const char * asynchronous
[] = { "YES", "NO", NULL
};
2194 if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous
,
2195 NULL
, NULL
, open
->asynchronous
->value
.character
.string
,
2201 /* Checks on the BLANK specifier. */
2204 if (!gfc_notify_std (GFC_STD_F2003
, "BLANK= at %C "
2205 "not allowed in Fortran 95"))
2208 if (!is_char_type ("BLANK", open
->blank
))
2211 if (open
->blank
->expr_type
== EXPR_CONSTANT
)
2213 static const char *blank
[] = { "ZERO", "NULL", NULL
};
2215 if (!compare_to_allowed_values ("BLANK", blank
, NULL
, NULL
,
2216 open
->blank
->value
.character
.string
,
2222 /* Checks on the CARRIAGECONTROL specifier. */
2225 if (!is_char_type ("CARRIAGECONTROL", open
->cc
))
2228 if (open
->cc
->expr_type
== EXPR_CONSTANT
)
2230 static const char *cc
[] = { "LIST", "FORTRAN", "NONE", NULL
};
2231 if (!compare_to_allowed_values ("CARRIAGECONTROL", cc
, NULL
, NULL
,
2232 open
->cc
->value
.character
.string
,
2238 /* Checks on the DECIMAL specifier. */
2241 if (!gfc_notify_std (GFC_STD_F2003
, "DECIMAL= at %C "
2242 "not allowed in Fortran 95"))
2245 if (!is_char_type ("DECIMAL", open
->decimal
))
2248 if (open
->decimal
->expr_type
== EXPR_CONSTANT
)
2250 static const char * decimal
[] = { "COMMA", "POINT", NULL
};
2252 if (!compare_to_allowed_values ("DECIMAL", decimal
, NULL
, NULL
,
2253 open
->decimal
->value
.character
.string
,
2259 /* Checks on the DELIM specifier. */
2262 if (open
->delim
->expr_type
== EXPR_CONSTANT
)
2264 static const char *delim
[] = { "APOSTROPHE", "QUOTE", "NONE", NULL
};
2266 if (!is_char_type ("DELIM", open
->delim
))
2269 if (!compare_to_allowed_values ("DELIM", delim
, NULL
, NULL
,
2270 open
->delim
->value
.character
.string
,
2276 /* Checks on the ENCODING specifier. */
2279 if (!gfc_notify_std (GFC_STD_F2003
, "ENCODING= at %C "
2280 "not allowed in Fortran 95"))
2283 if (!is_char_type ("ENCODING", open
->encoding
))
2286 if (open
->encoding
->expr_type
== EXPR_CONSTANT
)
2288 static const char * encoding
[] = { "DEFAULT", "UTF-8", NULL
};
2290 if (!compare_to_allowed_values ("ENCODING", encoding
, NULL
, NULL
,
2291 open
->encoding
->value
.character
.string
,
2297 /* Checks on the FORM specifier. */
2298 if (open
->form
&& open
->form
->expr_type
== EXPR_CONSTANT
)
2300 static const char *form
[] = { "FORMATTED", "UNFORMATTED", NULL
};
2302 if (!is_char_type ("FORM", open
->form
))
2305 if (!compare_to_allowed_values ("FORM", form
, NULL
, NULL
,
2306 open
->form
->value
.character
.string
,
2311 /* Checks on the PAD specifier. */
2312 if (open
->pad
&& open
->pad
->expr_type
== EXPR_CONSTANT
)
2314 static const char *pad
[] = { "YES", "NO", NULL
};
2316 if (!is_char_type ("PAD", open
->pad
))
2319 if (!compare_to_allowed_values ("PAD", pad
, NULL
, NULL
,
2320 open
->pad
->value
.character
.string
,
2325 /* Checks on the POSITION specifier. */
2326 if (open
->position
&& open
->position
->expr_type
== EXPR_CONSTANT
)
2328 static const char *position
[] = { "ASIS", "REWIND", "APPEND", NULL
};
2330 if (!is_char_type ("POSITION", open
->position
))
2333 if (!compare_to_allowed_values ("POSITION", position
, NULL
, NULL
,
2334 open
->position
->value
.character
.string
,
2339 /* Checks on the ROUND specifier. */
2342 if (!gfc_notify_std (GFC_STD_F2003
, "ROUND= at %C "
2343 "not allowed in Fortran 95"))
2346 if (!is_char_type ("ROUND", open
->round
))
2349 if (open
->round
->expr_type
== EXPR_CONSTANT
)
2351 static const char * round
[] = { "UP", "DOWN", "ZERO", "NEAREST",
2352 "COMPATIBLE", "PROCESSOR_DEFINED",
2355 if (!compare_to_allowed_values ("ROUND", round
, NULL
, NULL
,
2356 open
->round
->value
.character
.string
,
2362 /* Checks on the SHARE specifier. */
2365 if (!is_char_type ("SHARE", open
->share
))
2368 if (open
->share
->expr_type
== EXPR_CONSTANT
)
2370 static const char *share
[] = { "DENYNONE", "DENYRW", NULL
};
2371 if (!compare_to_allowed_values ("SHARE", share
, NULL
, NULL
,
2372 open
->share
->value
.character
.string
,
2378 /* Checks on the SIGN specifier. */
2381 if (!gfc_notify_std (GFC_STD_F2003
, "SIGN= at %C "
2382 "not allowed in Fortran 95"))
2385 if (!is_char_type ("SIGN", open
->sign
))
2388 if (open
->sign
->expr_type
== EXPR_CONSTANT
)
2390 static const char * sign
[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
2393 if (!compare_to_allowed_values ("SIGN", sign
, NULL
, NULL
,
2394 open
->sign
->value
.character
.string
,
2400 #define warn_or_error(...) \
2403 gfc_warning (0, __VA_ARGS__); \
2406 gfc_error (__VA_ARGS__); \
2411 /* Checks on the RECL specifier. */
2412 if (open
->recl
&& open
->recl
->expr_type
== EXPR_CONSTANT
2413 && open
->recl
->ts
.type
== BT_INTEGER
2414 && mpz_sgn (open
->recl
->value
.integer
) != 1)
2416 warn_or_error ("RECL in OPEN statement at %C must be positive");
2419 /* Checks on the STATUS specifier. */
2420 if (open
->status
&& open
->status
->expr_type
== EXPR_CONSTANT
)
2422 static const char *status
[] = { "OLD", "NEW", "SCRATCH",
2423 "REPLACE", "UNKNOWN", NULL
};
2425 if (!is_char_type ("STATUS", open
->status
))
2428 if (!compare_to_allowed_values ("STATUS", status
, NULL
, NULL
,
2429 open
->status
->value
.character
.string
,
2433 /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2434 the FILE= specifier shall appear. */
2435 if (open
->file
== NULL
2436 && (gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2438 || gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2441 char *s
= gfc_widechar_to_char (open
->status
->value
.character
.string
,
2443 warn_or_error ("The STATUS specified in OPEN statement at %C is "
2444 "%qs and no FILE specifier is present", s
);
2448 /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2449 the FILE= specifier shall not appear. */
2450 if (gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2451 "scratch", 7) == 0 && open
->file
)
2453 warn_or_error ("The STATUS specified in OPEN statement at %C "
2454 "cannot have the value SCRATCH if a FILE specifier "
2459 /* Things that are not allowed for unformatted I/O. */
2460 if (open
->form
&& open
->form
->expr_type
== EXPR_CONSTANT
2461 && (open
->delim
|| open
->decimal
|| open
->encoding
|| open
->round
2462 || open
->sign
|| open
->pad
|| open
->blank
)
2463 && gfc_wide_strncasecmp (open
->form
->value
.character
.string
,
2464 "unformatted", 11) == 0)
2466 const char *spec
= (open
->delim
? "DELIM "
2467 : (open
->pad
? "PAD " : open
->blank
2470 warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
2471 "unformatted I/O", spec
);
2474 if (open
->recl
&& open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
2475 && gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2478 warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
2483 && open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
2484 && !(gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2485 "sequential", 10) == 0
2486 || gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2488 || gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2491 warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
2492 "for stream or sequential ACCESS");
2495 #undef warn_or_error
2497 new_st
.op
= EXEC_OPEN
;
2498 new_st
.ext
.open
= open
;
2502 gfc_syntax_error (ST_OPEN
);
2505 gfc_free_open (open
);
2510 /* Free a gfc_close structure an all its expressions. */
2513 gfc_free_close (gfc_close
*close
)
2518 gfc_free_expr (close
->unit
);
2519 gfc_free_expr (close
->iomsg
);
2520 gfc_free_expr (close
->iostat
);
2521 gfc_free_expr (close
->status
);
2526 /* Match elements of a CLOSE statement. */
2529 match_close_element (gfc_close
*close
)
2533 m
= match_etag (&tag_unit
, &close
->unit
);
2536 m
= match_etag (&tag_status
, &close
->status
);
2539 m
= match_etag (&tag_iomsg
, &close
->iomsg
);
2540 if (m
== MATCH_YES
&& !check_char_variable (close
->iomsg
))
2544 m
= match_out_tag (&tag_iostat
, &close
->iostat
);
2547 m
= match_ltag (&tag_err
, &close
->err
);
2555 /* Match a CLOSE statement. */
2558 gfc_match_close (void)
2564 m
= gfc_match_char ('(');
2568 close
= XCNEW (gfc_close
);
2570 m
= match_close_element (close
);
2572 if (m
== MATCH_ERROR
)
2576 m
= gfc_match_expr (&close
->unit
);
2579 if (m
== MATCH_ERROR
)
2585 if (gfc_match_char (')') == MATCH_YES
)
2587 if (gfc_match_char (',') != MATCH_YES
)
2590 m
= match_close_element (close
);
2591 if (m
== MATCH_ERROR
)
2597 if (gfc_match_eos () == MATCH_NO
)
2600 if (gfc_pure (NULL
))
2602 gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2606 gfc_unset_implicit_pure (NULL
);
2608 warn
= (close
->iostat
|| close
->err
) ? true : false;
2610 /* Checks on the STATUS specifier. */
2611 if (close
->status
&& close
->status
->expr_type
== EXPR_CONSTANT
)
2613 static const char *status
[] = { "KEEP", "DELETE", NULL
};
2615 if (!is_char_type ("STATUS", close
->status
))
2618 if (!compare_to_allowed_values ("STATUS", status
, NULL
, NULL
,
2619 close
->status
->value
.character
.string
,
2624 new_st
.op
= EXEC_CLOSE
;
2625 new_st
.ext
.close
= close
;
2629 gfc_syntax_error (ST_CLOSE
);
2632 gfc_free_close (close
);
2637 /* Resolve everything in a gfc_close structure. */
2640 gfc_resolve_close (gfc_close
*close
)
2642 RESOLVE_TAG (&tag_unit
, close
->unit
);
2643 RESOLVE_TAG (&tag_iomsg
, close
->iomsg
);
2644 RESOLVE_TAG (&tag_iostat
, close
->iostat
);
2645 RESOLVE_TAG (&tag_status
, close
->status
);
2647 if (!gfc_reference_st_label (close
->err
, ST_LABEL_TARGET
))
2650 if (close
->unit
== NULL
)
2652 /* Find a locus from one of the arguments to close, when UNIT is
2654 locus loc
= gfc_current_locus
;
2656 loc
= close
->status
->where
;
2657 else if (close
->iostat
)
2658 loc
= close
->iostat
->where
;
2659 else if (close
->iomsg
)
2660 loc
= close
->iomsg
->where
;
2661 else if (close
->err
)
2662 loc
= close
->err
->where
;
2664 gfc_error ("CLOSE statement at %L requires a UNIT number", &loc
);
2668 if (close
->unit
->expr_type
== EXPR_CONSTANT
2669 && close
->unit
->ts
.type
== BT_INTEGER
2670 && mpz_sgn (close
->unit
->value
.integer
) < 0)
2672 gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2673 &close
->unit
->where
);
2680 /* Free a gfc_filepos structure. */
2683 gfc_free_filepos (gfc_filepos
*fp
)
2685 gfc_free_expr (fp
->unit
);
2686 gfc_free_expr (fp
->iomsg
);
2687 gfc_free_expr (fp
->iostat
);
2692 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
2695 match_file_element (gfc_filepos
*fp
)
2699 m
= match_etag (&tag_unit
, &fp
->unit
);
2702 m
= match_etag (&tag_iomsg
, &fp
->iomsg
);
2703 if (m
== MATCH_YES
&& !check_char_variable (fp
->iomsg
))
2707 m
= match_out_tag (&tag_iostat
, &fp
->iostat
);
2710 m
= match_ltag (&tag_err
, &fp
->err
);
2718 /* Match the second half of the file-positioning statements, REWIND,
2719 BACKSPACE, ENDFILE, or the FLUSH statement. */
2722 match_filepos (gfc_statement st
, gfc_exec_op op
)
2727 fp
= XCNEW (gfc_filepos
);
2729 if (gfc_match_char ('(') == MATCH_NO
)
2731 m
= gfc_match_expr (&fp
->unit
);
2732 if (m
== MATCH_ERROR
)
2740 m
= match_file_element (fp
);
2741 if (m
== MATCH_ERROR
)
2745 m
= gfc_match_expr (&fp
->unit
);
2746 if (m
== MATCH_ERROR
|| m
== MATCH_NO
)
2752 if (gfc_match_char (')') == MATCH_YES
)
2754 if (gfc_match_char (',') != MATCH_YES
)
2757 m
= match_file_element (fp
);
2758 if (m
== MATCH_ERROR
)
2765 if (gfc_match_eos () != MATCH_YES
)
2768 if (gfc_pure (NULL
))
2770 gfc_error ("%s statement not allowed in PURE procedure at %C",
2771 gfc_ascii_statement (st
));
2776 gfc_unset_implicit_pure (NULL
);
2779 new_st
.ext
.filepos
= fp
;
2783 gfc_syntax_error (st
);
2786 gfc_free_filepos (fp
);
2792 gfc_resolve_filepos (gfc_filepos
*fp
)
2794 RESOLVE_TAG (&tag_unit
, fp
->unit
);
2795 RESOLVE_TAG (&tag_iostat
, fp
->iostat
);
2796 RESOLVE_TAG (&tag_iomsg
, fp
->iomsg
);
2797 if (!gfc_reference_st_label (fp
->err
, ST_LABEL_TARGET
))
2800 if (!fp
->unit
&& (fp
->iostat
|| fp
->iomsg
))
2803 where
= fp
->iostat
? fp
->iostat
->where
: fp
->iomsg
->where
;
2804 gfc_error ("UNIT number missing in statement at %L", &where
);
2808 if (fp
->unit
->expr_type
== EXPR_CONSTANT
2809 && fp
->unit
->ts
.type
== BT_INTEGER
2810 && mpz_sgn (fp
->unit
->value
.integer
) < 0)
2812 gfc_error ("UNIT number in statement at %L must be non-negative",
2821 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2822 and the FLUSH statement. */
2825 gfc_match_endfile (void)
2827 return match_filepos (ST_END_FILE
, EXEC_ENDFILE
);
2831 gfc_match_backspace (void)
2833 return match_filepos (ST_BACKSPACE
, EXEC_BACKSPACE
);
2837 gfc_match_rewind (void)
2839 return match_filepos (ST_REWIND
, EXEC_REWIND
);
2843 gfc_match_flush (void)
2845 if (!gfc_notify_std (GFC_STD_F2003
, "FLUSH statement at %C"))
2848 return match_filepos (ST_FLUSH
, EXEC_FLUSH
);
2851 /******************** Data Transfer Statements *********************/
2853 /* Return a default unit number. */
2856 default_unit (io_kind k
)
2865 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, unit
);
2869 /* Match a unit specification for a data transfer statement. */
2872 match_dt_unit (io_kind k
, gfc_dt
*dt
)
2877 if (gfc_match_char ('*') == MATCH_YES
)
2879 if (dt
->io_unit
!= NULL
)
2882 dt
->io_unit
= default_unit (k
);
2884 c
= gfc_peek_ascii_char ();
2886 gfc_error_now ("Missing format with default unit at %C");
2891 if (gfc_match_expr (&e
) == MATCH_YES
)
2893 if (dt
->io_unit
!= NULL
)
2906 gfc_error ("Duplicate UNIT specification at %C");
2911 /* Match a format specification. */
2914 match_dt_format (gfc_dt
*dt
)
2918 gfc_st_label
*label
;
2921 where
= gfc_current_locus
;
2923 if (gfc_match_char ('*') == MATCH_YES
)
2925 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2928 dt
->format_label
= &format_asterisk
;
2932 if ((m
= gfc_match_st_label (&label
)) == MATCH_YES
)
2936 /* Need to check if the format label is actually either an operand
2937 to a user-defined operator or is a kind type parameter. That is,
2938 print 2.ip.8 ! .ip. is a user-defined operator return CHARACTER.
2939 print 1_'(I0)', i ! 1_'(I0)' is a default character string. */
2941 gfc_gobble_whitespace ();
2942 c
= gfc_peek_ascii_char ();
2943 if (c
== '.' || c
== '_')
2944 gfc_current_locus
= where
;
2947 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2949 gfc_free_st_label (label
);
2953 if (!gfc_reference_st_label (label
, ST_LABEL_FORMAT
))
2956 dt
->format_label
= label
;
2960 else if (m
== MATCH_ERROR
)
2961 /* The label was zero or too large. Emit the correct diagnosis. */
2964 if (gfc_match_expr (&e
) == MATCH_YES
)
2966 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2971 dt
->format_expr
= e
;
2975 gfc_current_locus
= where
; /* The only case where we have to restore */
2980 gfc_error ("Duplicate format specification at %C");
2984 /* Check for formatted read and write DTIO procedures. */
2987 dtio_procs_present (gfc_symbol
*sym
, io_kind k
)
2989 gfc_symbol
*derived
;
2991 if (sym
&& sym
->ts
.u
.derived
)
2993 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
2994 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
2995 else if (sym
->ts
.type
== BT_DERIVED
)
2996 derived
= sym
->ts
.u
.derived
;
2999 if ((k
== M_WRITE
|| k
== M_PRINT
) &&
3000 (gfc_find_specific_dtio_proc (derived
, true, true) != NULL
))
3002 if ((k
== M_READ
) &&
3003 (gfc_find_specific_dtio_proc (derived
, false, true) != NULL
))
3009 /* Traverse a namelist that is part of a READ statement to make sure
3010 that none of the variables in the namelist are INTENT(IN). Returns
3011 nonzero if we find such a variable. */
3014 check_namelist (gfc_symbol
*sym
)
3018 for (p
= sym
->namelist
; p
; p
= p
->next
)
3019 if (p
->sym
->attr
.intent
== INTENT_IN
)
3021 gfc_error ("Symbol %qs in namelist %qs is INTENT(IN) at %C",
3022 p
->sym
->name
, sym
->name
);
3030 /* Match a single data transfer element. */
3033 match_dt_element (io_kind k
, gfc_dt
*dt
)
3035 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3039 if (gfc_match (" unit =") == MATCH_YES
)
3041 m
= match_dt_unit (k
, dt
);
3046 if (gfc_match (" fmt =") == MATCH_YES
)
3048 m
= match_dt_format (dt
);
3053 if (gfc_match (" nml = %n", name
) == MATCH_YES
)
3055 if (dt
->namelist
!= NULL
)
3057 gfc_error ("Duplicate NML specification at %C");
3061 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
3064 if (sym
== NULL
|| sym
->attr
.flavor
!= FL_NAMELIST
)
3066 gfc_error ("Symbol %qs at %C must be a NAMELIST group name",
3067 sym
!= NULL
? sym
->name
: name
);
3072 if (k
== M_READ
&& check_namelist (sym
))
3078 m
= match_etag (&tag_e_async
, &dt
->asynchronous
);
3079 if (m
== MATCH_YES
&& !is_char_type ("ASYNCHRONOUS", dt
->asynchronous
))
3083 m
= match_etag (&tag_e_blank
, &dt
->blank
);
3086 m
= match_etag (&tag_e_delim
, &dt
->delim
);
3089 m
= match_etag (&tag_e_pad
, &dt
->pad
);
3092 m
= match_etag (&tag_e_sign
, &dt
->sign
);
3095 m
= match_etag (&tag_e_round
, &dt
->round
);
3098 m
= match_out_tag (&tag_id
, &dt
->id
);
3101 m
= match_etag (&tag_e_decimal
, &dt
->decimal
);
3104 m
= match_etag (&tag_rec
, &dt
->rec
);
3107 m
= match_etag (&tag_spos
, &dt
->pos
);
3110 m
= match_etag (&tag_iomsg
, &dt
->iomsg
);
3111 if (m
== MATCH_YES
&& !check_char_variable (dt
->iomsg
))
3116 m
= match_out_tag (&tag_iostat
, &dt
->iostat
);
3119 m
= match_ltag (&tag_err
, &dt
->err
);
3121 dt
->err_where
= gfc_current_locus
;
3124 m
= match_etag (&tag_advance
, &dt
->advance
);
3127 m
= match_out_tag (&tag_size
, &dt
->size
);
3131 m
= match_ltag (&tag_end
, &dt
->end
);
3136 gfc_error ("END tag at %C not allowed in output statement");
3139 dt
->end_where
= gfc_current_locus
;
3144 m
= match_ltag (&tag_eor
, &dt
->eor
);
3146 dt
->eor_where
= gfc_current_locus
;
3154 /* Free a data transfer structure and everything below it. */
3157 gfc_free_dt (gfc_dt
*dt
)
3162 gfc_free_expr (dt
->io_unit
);
3163 gfc_free_expr (dt
->format_expr
);
3164 gfc_free_expr (dt
->rec
);
3165 gfc_free_expr (dt
->advance
);
3166 gfc_free_expr (dt
->iomsg
);
3167 gfc_free_expr (dt
->iostat
);
3168 gfc_free_expr (dt
->size
);
3169 gfc_free_expr (dt
->pad
);
3170 gfc_free_expr (dt
->delim
);
3171 gfc_free_expr (dt
->sign
);
3172 gfc_free_expr (dt
->round
);
3173 gfc_free_expr (dt
->blank
);
3174 gfc_free_expr (dt
->decimal
);
3175 gfc_free_expr (dt
->pos
);
3176 gfc_free_expr (dt
->dt_io_kind
);
3177 /* dt->extra_comma is a link to dt_io_kind if it is set. */
3182 /* Resolve everything in a gfc_dt structure. */
3185 gfc_resolve_dt (gfc_dt
*dt
, locus
*loc
)
3190 /* This is set in any case. */
3191 gcc_assert (dt
->dt_io_kind
);
3192 k
= dt
->dt_io_kind
->value
.iokind
;
3194 RESOLVE_TAG (&tag_format
, dt
->format_expr
);
3195 RESOLVE_TAG (&tag_rec
, dt
->rec
);
3196 RESOLVE_TAG (&tag_spos
, dt
->pos
);
3197 RESOLVE_TAG (&tag_advance
, dt
->advance
);
3198 RESOLVE_TAG (&tag_id
, dt
->id
);
3199 RESOLVE_TAG (&tag_iomsg
, dt
->iomsg
);
3200 RESOLVE_TAG (&tag_iostat
, dt
->iostat
);
3201 RESOLVE_TAG (&tag_size
, dt
->size
);
3202 RESOLVE_TAG (&tag_e_pad
, dt
->pad
);
3203 RESOLVE_TAG (&tag_e_delim
, dt
->delim
);
3204 RESOLVE_TAG (&tag_e_sign
, dt
->sign
);
3205 RESOLVE_TAG (&tag_e_round
, dt
->round
);
3206 RESOLVE_TAG (&tag_e_blank
, dt
->blank
);
3207 RESOLVE_TAG (&tag_e_decimal
, dt
->decimal
);
3208 RESOLVE_TAG (&tag_e_async
, dt
->asynchronous
);
3213 gfc_error ("UNIT not specified at %L", loc
);
3217 if (gfc_resolve_expr (e
)
3218 && (e
->ts
.type
!= BT_INTEGER
3219 && (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_VARIABLE
)))
3221 /* If there is no extra comma signifying the "format" form of the IO
3222 statement, then this must be an error. */
3223 if (!dt
->extra_comma
)
3225 gfc_error ("UNIT specification at %L must be an INTEGER expression "
3226 "or a CHARACTER variable", &e
->where
);
3231 /* At this point, we have an extra comma. If io_unit has arrived as
3232 type character, we assume its really the "format" form of the I/O
3233 statement. We set the io_unit to the default unit and format to
3234 the character expression. See F95 Standard section 9.4. */
3235 if (e
->ts
.type
== BT_CHARACTER
&& (k
== M_READ
|| k
== M_PRINT
))
3237 dt
->format_expr
= dt
->io_unit
;
3238 dt
->io_unit
= default_unit (k
);
3240 /* Nullify this pointer now so that a warning/error is not
3241 triggered below for the "Extension". */
3242 dt
->extra_comma
= NULL
;
3247 gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
3248 &dt
->extra_comma
->where
);
3254 if (e
->ts
.type
== BT_CHARACTER
)
3256 if (gfc_has_vector_index (e
))
3258 gfc_error ("Internal unit with vector subscript at %L", &e
->where
);
3262 /* If we are writing, make sure the internal unit can be changed. */
3263 gcc_assert (k
!= M_PRINT
);
3265 && !gfc_check_vardef_context (e
, false, false, false,
3266 _("internal unit in WRITE")))
3270 if (e
->rank
&& e
->ts
.type
!= BT_CHARACTER
)
3272 gfc_error ("External IO UNIT cannot be an array at %L", &e
->where
);
3276 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_INTEGER
3277 && mpz_sgn (e
->value
.integer
) < 0)
3279 gfc_error ("UNIT number in statement at %L must be non-negative",
3284 /* If we are reading and have a namelist, check that all namelist symbols
3285 can appear in a variable definition context. */
3289 for (n
= dt
->namelist
->namelist
; n
; n
= n
->next
)
3296 e
= gfc_get_variable_expr (gfc_find_sym_in_symtree (n
->sym
));
3297 t
= gfc_check_vardef_context (e
, false, false, false, NULL
);
3302 gfc_error ("NAMELIST %qs in READ statement at %L contains"
3303 " the symbol %qs which may not appear in a"
3304 " variable definition context",
3305 dt
->namelist
->name
, loc
, n
->sym
->name
);
3310 t
= dtio_procs_present (n
->sym
, k
);
3312 if (n
->sym
->ts
.type
== BT_CLASS
&& !t
)
3314 gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
3315 "polymorphic and requires a defined input/output "
3316 "procedure", n
->sym
->name
, dt
->namelist
->name
, loc
);
3320 if ((n
->sym
->ts
.type
== BT_DERIVED
)
3321 && (n
->sym
->ts
.u
.derived
->attr
.alloc_comp
3322 || n
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
3324 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
3325 "namelist %qs at %L with ALLOCATABLE "
3326 "or POINTER components", n
->sym
->name
,
3327 dt
->namelist
->name
, loc
))
3332 gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
3333 "ALLOCATABLE or POINTER components and thus requires "
3334 "a defined input/output procedure", n
->sym
->name
,
3335 dt
->namelist
->name
, loc
);
3343 && !gfc_notify_std (GFC_STD_LEGACY
, "Comma before i/o item list at %L",
3344 &dt
->extra_comma
->where
))
3349 if (!gfc_reference_st_label (dt
->err
, ST_LABEL_TARGET
))
3351 if (dt
->err
->defined
== ST_LABEL_UNKNOWN
)
3353 gfc_error ("ERR tag label %d at %L not defined",
3354 dt
->err
->value
, &dt
->err_where
);
3361 if (!gfc_reference_st_label (dt
->end
, ST_LABEL_TARGET
))
3363 if (dt
->end
->defined
== ST_LABEL_UNKNOWN
)
3365 gfc_error ("END tag label %d at %L not defined",
3366 dt
->end
->value
, &dt
->end_where
);
3373 if (!gfc_reference_st_label (dt
->eor
, ST_LABEL_TARGET
))
3375 if (dt
->eor
->defined
== ST_LABEL_UNKNOWN
)
3377 gfc_error ("EOR tag label %d at %L not defined",
3378 dt
->eor
->value
, &dt
->eor_where
);
3383 /* Check the format label actually exists. */
3384 if (dt
->format_label
&& dt
->format_label
!= &format_asterisk
3385 && dt
->format_label
->defined
== ST_LABEL_UNKNOWN
)
3387 gfc_error ("FORMAT label %d at %L not defined", dt
->format_label
->value
,
3396 /* Given an io_kind, return its name. */
3399 io_kind_name (io_kind k
)
3418 gfc_internal_error ("io_kind_name(): bad I/O-kind");
3425 /* Match an IO iteration statement of the form:
3427 ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
3429 which is equivalent to a single IO element. This function is
3430 mutually recursive with match_io_element(). */
3432 static match
match_io_element (io_kind
, gfc_code
**);
3435 match_io_iterator (io_kind k
, gfc_code
**result
)
3437 gfc_code
*head
, *tail
, *new_code
;
3445 old_loc
= gfc_current_locus
;
3447 if (gfc_match_char ('(') != MATCH_YES
)
3450 m
= match_io_element (k
, &head
);
3453 if (m
!= MATCH_YES
|| gfc_match_char (',') != MATCH_YES
)
3459 /* Can't be anything but an IO iterator. Build a list. */
3460 iter
= gfc_get_iterator ();
3464 m
= gfc_match_iterator (iter
, 0);
3465 if (m
== MATCH_ERROR
)
3469 gfc_check_do_variable (iter
->var
->symtree
);
3473 m
= match_io_element (k
, &new_code
);
3474 if (m
== MATCH_ERROR
)
3483 tail
= gfc_append_code (tail
, new_code
);
3485 if (gfc_match_char (',') != MATCH_YES
)
3494 if (gfc_match_char (')') != MATCH_YES
)
3497 new_code
= gfc_get_code (EXEC_DO
);
3498 new_code
->ext
.iterator
= iter
;
3500 new_code
->block
= gfc_get_code (EXEC_DO
);
3501 new_code
->block
->next
= head
;
3507 gfc_error ("Syntax error in I/O iterator at %C");
3511 gfc_free_iterator (iter
, 1);
3512 gfc_free_statements (head
);
3513 gfc_current_locus
= old_loc
;
3518 /* Match a single element of an IO list, which is either a single
3519 expression or an IO Iterator. */
3522 match_io_element (io_kind k
, gfc_code
**cpp
)
3530 m
= match_io_iterator (k
, cpp
);
3536 m
= gfc_match_variable (&expr
, 0);
3538 gfc_error ("Expected variable in READ statement at %C");
3542 m
= gfc_match_expr (&expr
);
3544 gfc_error ("Expected expression in %s statement at %C",
3548 if (m
== MATCH_YES
&& k
== M_READ
&& gfc_check_do_variable (expr
->symtree
))
3553 gfc_free_expr (expr
);
3557 cp
= gfc_get_code (EXEC_TRANSFER
);
3560 cp
->ext
.dt
= current_dt
;
3567 /* Match an I/O list, building gfc_code structures as we go. */
3570 match_io_list (io_kind k
, gfc_code
**head_p
)
3572 gfc_code
*head
, *tail
, *new_code
;
3575 *head_p
= head
= tail
= NULL
;
3576 if (gfc_match_eos () == MATCH_YES
)
3581 m
= match_io_element (k
, &new_code
);
3582 if (m
== MATCH_ERROR
)
3587 tail
= gfc_append_code (tail
, new_code
);
3591 if (gfc_match_eos () == MATCH_YES
)
3593 if (gfc_match_char (',') != MATCH_YES
)
3601 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
3604 gfc_free_statements (head
);
3609 /* Attach the data transfer end node. */
3612 terminate_io (gfc_code
*io_code
)
3616 if (io_code
== NULL
)
3617 io_code
= new_st
.block
;
3619 c
= gfc_get_code (EXEC_DT_END
);
3621 /* Point to structure that is already there */
3622 c
->ext
.dt
= new_st
.ext
.dt
;
3623 gfc_append_code (io_code
, c
);
3627 /* Check the constraints for a data transfer statement. The majority of the
3628 constraints appearing in 9.4 of the standard appear here. Some are handled
3629 in resolve_tag and others in gfc_resolve_dt. Also set the async_io_dt flag
3630 and, if necessary, the asynchronous flag on the SIZE argument. */
3633 check_io_constraints (io_kind k
, gfc_dt
*dt
, gfc_code
*io_code
,
3636 #define io_constraint(condition,msg,arg)\
3639 gfc_error(msg,arg);\
3645 gfc_symbol
*sym
= NULL
;
3646 bool warn
, unformatted
;
3648 warn
= (dt
->err
|| dt
->iostat
) ? true : false;
3649 unformatted
= dt
->format_expr
== NULL
&& dt
->format_label
== NULL
3650 && dt
->namelist
== NULL
;
3655 if (expr
&& expr
->expr_type
== EXPR_VARIABLE
3656 && expr
->ts
.type
== BT_CHARACTER
)
3658 sym
= expr
->symtree
->n
.sym
;
3660 io_constraint (k
== M_WRITE
&& sym
->attr
.intent
== INTENT_IN
,
3661 "Internal file at %L must not be INTENT(IN)",
3664 io_constraint (gfc_has_vector_index (dt
->io_unit
),
3665 "Internal file incompatible with vector subscript at %L",
3668 io_constraint (dt
->rec
!= NULL
,
3669 "REC tag at %L is incompatible with internal file",
3672 io_constraint (dt
->pos
!= NULL
,
3673 "POS tag at %L is incompatible with internal file",
3676 io_constraint (unformatted
,
3677 "Unformatted I/O not allowed with internal unit at %L",
3678 &dt
->io_unit
->where
);
3680 io_constraint (dt
->asynchronous
!= NULL
,
3681 "ASYNCHRONOUS tag at %L not allowed with internal file",
3682 &dt
->asynchronous
->where
);
3684 if (dt
->namelist
!= NULL
)
3686 if (!gfc_notify_std (GFC_STD_F2003
, "Internal file at %L with "
3687 "namelist", &expr
->where
))
3691 io_constraint (dt
->advance
!= NULL
,
3692 "ADVANCE tag at %L is incompatible with internal file",
3693 &dt
->advance
->where
);
3696 if (expr
&& expr
->ts
.type
!= BT_CHARACTER
)
3699 io_constraint (gfc_pure (NULL
) && (k
== M_READ
|| k
== M_WRITE
),
3700 "IO UNIT in %s statement at %C must be "
3701 "an internal file in a PURE procedure",
3704 if (k
== M_READ
|| k
== M_WRITE
)
3705 gfc_unset_implicit_pure (NULL
);
3710 io_constraint (dt
->end
, "END tag not allowed with output at %L",
3713 io_constraint (dt
->eor
, "EOR tag not allowed with output at %L",
3716 io_constraint (dt
->blank
, "BLANK= specifier not allowed with output at %L",
3719 io_constraint (dt
->pad
, "PAD= specifier not allowed with output at %L",
3722 io_constraint (dt
->size
, "SIZE= specifier not allowed with output at %L",
3727 io_constraint (dt
->size
&& dt
->advance
== NULL
,
3728 "SIZE tag at %L requires an ADVANCE tag",
3731 io_constraint (dt
->eor
&& dt
->advance
== NULL
,
3732 "EOR tag at %L requires an ADVANCE tag",
3736 if (dt
->asynchronous
)
3739 static const char * asynchronous
[] = { "YES", "NO", NULL
};
3741 if (!gfc_reduce_init_expr (dt
->asynchronous
))
3743 gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3744 "expression", &dt
->asynchronous
->where
);
3748 if (!is_char_type ("ASYNCHRONOUS", dt
->asynchronous
))
3751 if (!compare_to_allowed_values
3752 ("ASYNCHRONOUS", asynchronous
, NULL
, NULL
,
3753 dt
->asynchronous
->value
.character
.string
,
3754 io_kind_name (k
), warn
, &num
))
3757 /* Best to put this here because the yes/no info is still around. */
3758 async_io_dt
= num
== 0;
3759 if (async_io_dt
&& dt
->size
)
3760 dt
->size
->symtree
->n
.sym
->attr
.asynchronous
= 1;
3763 async_io_dt
= false;
3769 || gfc_wide_strlen (dt
->asynchronous
->value
.character
.string
) != 3
3770 || gfc_wide_strncasecmp (dt
->asynchronous
->value
.character
.string
,
3772 io_constraint (not_yes
,
3773 "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3774 "specifier", &dt
->id
->where
);
3779 if (!gfc_notify_std (GFC_STD_F2003
, "DECIMAL= at %C "
3780 "not allowed in Fortran 95"))
3783 if (dt
->decimal
->expr_type
== EXPR_CONSTANT
)
3785 static const char * decimal
[] = { "COMMA", "POINT", NULL
};
3787 if (!is_char_type ("DECIMAL", dt
->decimal
))
3790 if (!compare_to_allowed_values ("DECIMAL", decimal
, NULL
, NULL
,
3791 dt
->decimal
->value
.character
.string
,
3792 io_kind_name (k
), warn
))
3795 io_constraint (unformatted
,
3796 "the DECIMAL= specifier at %L must be with an "
3797 "explicit format expression", &dt
->decimal
->where
);
3803 if (!gfc_notify_std (GFC_STD_F2003
, "BLANK= at %C "
3804 "not allowed in Fortran 95"))
3807 if (!is_char_type ("BLANK", dt
->blank
))
3810 if (dt
->blank
->expr_type
== EXPR_CONSTANT
)
3812 static const char * blank
[] = { "NULL", "ZERO", NULL
};
3815 if (!compare_to_allowed_values ("BLANK", blank
, NULL
, NULL
,
3816 dt
->blank
->value
.character
.string
,
3817 io_kind_name (k
), warn
))
3820 io_constraint (unformatted
,
3821 "the BLANK= specifier at %L must be with an "
3822 "explicit format expression", &dt
->blank
->where
);
3828 if (!gfc_notify_std (GFC_STD_F2003
, "PAD= at %C "
3829 "not allowed in Fortran 95"))
3832 if (!is_char_type ("PAD", dt
->pad
))
3835 if (dt
->pad
->expr_type
== EXPR_CONSTANT
)
3837 static const char * pad
[] = { "YES", "NO", NULL
};
3839 if (!compare_to_allowed_values ("PAD", pad
, NULL
, NULL
,
3840 dt
->pad
->value
.character
.string
,
3841 io_kind_name (k
), warn
))
3844 io_constraint (unformatted
,
3845 "the PAD= specifier at %L must be with an "
3846 "explicit format expression", &dt
->pad
->where
);
3852 if (!gfc_notify_std (GFC_STD_F2003
, "ROUND= at %C "
3853 "not allowed in Fortran 95"))
3856 if (!is_char_type ("ROUND", dt
->round
))
3859 if (dt
->round
->expr_type
== EXPR_CONSTANT
)
3861 static const char * round
[] = { "UP", "DOWN", "ZERO", "NEAREST",
3862 "COMPATIBLE", "PROCESSOR_DEFINED",
3865 if (!compare_to_allowed_values ("ROUND", round
, NULL
, NULL
,
3866 dt
->round
->value
.character
.string
,
3867 io_kind_name (k
), warn
))
3874 /* When implemented, change the following to use gfc_notify_std F2003.
3875 if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C "
3876 "not allowed in Fortran 95") == false)
3877 return MATCH_ERROR; */
3879 if (!is_char_type ("SIGN", dt
->sign
))
3882 if (dt
->sign
->expr_type
== EXPR_CONSTANT
)
3884 static const char * sign
[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3887 if (!compare_to_allowed_values ("SIGN", sign
, NULL
, NULL
,
3888 dt
->sign
->value
.character
.string
,
3889 io_kind_name (k
), warn
))
3892 io_constraint (unformatted
,
3893 "SIGN= specifier at %L must be with an "
3894 "explicit format expression", &dt
->sign
->where
);
3896 io_constraint (k
== M_READ
,
3897 "SIGN= specifier at %L not allowed in a "
3898 "READ statement", &dt
->sign
->where
);
3904 if (!gfc_notify_std (GFC_STD_F2003
, "DELIM= at %C "
3905 "not allowed in Fortran 95"))
3908 if (!is_char_type ("DELIM", dt
->delim
))
3911 if (dt
->delim
->expr_type
== EXPR_CONSTANT
)
3913 static const char *delim
[] = { "APOSTROPHE", "QUOTE", "NONE", NULL
};
3915 if (!compare_to_allowed_values ("DELIM", delim
, NULL
, NULL
,
3916 dt
->delim
->value
.character
.string
,
3917 io_kind_name (k
), warn
))
3920 io_constraint (k
== M_READ
,
3921 "DELIM= specifier at %L not allowed in a "
3922 "READ statement", &dt
->delim
->where
);
3924 io_constraint (dt
->format_label
!= &format_asterisk
3925 && dt
->namelist
== NULL
,
3926 "DELIM= specifier at %L must have FMT=*",
3929 io_constraint (unformatted
&& dt
->namelist
== NULL
,
3930 "DELIM= specifier at %L must be with FMT=* or "
3931 "NML= specifier", &dt
->delim
->where
);
3937 io_constraint (io_code
&& dt
->namelist
,
3938 "NAMELIST cannot be followed by IO-list at %L",
3941 io_constraint (dt
->format_expr
,
3942 "IO spec-list cannot contain both NAMELIST group name "
3943 "and format specification at %L",
3944 &dt
->format_expr
->where
);
3946 io_constraint (dt
->format_label
,
3947 "IO spec-list cannot contain both NAMELIST group name "
3948 "and format label at %L", spec_end
);
3950 io_constraint (dt
->rec
,
3951 "NAMELIST IO is not allowed with a REC= specifier "
3952 "at %L", &dt
->rec
->where
);
3954 io_constraint (dt
->advance
,
3955 "NAMELIST IO is not allowed with a ADVANCE= specifier "
3956 "at %L", &dt
->advance
->where
);
3961 io_constraint (dt
->end
,
3962 "An END tag is not allowed with a "
3963 "REC= specifier at %L", &dt
->end_where
);
3965 io_constraint (dt
->format_label
== &format_asterisk
,
3966 "FMT=* is not allowed with a REC= specifier "
3969 io_constraint (dt
->pos
,
3970 "POS= is not allowed with REC= specifier "
3971 "at %L", &dt
->pos
->where
);
3976 int not_yes
, not_no
;
3979 io_constraint (dt
->format_label
== &format_asterisk
,
3980 "List directed format(*) is not allowed with a "
3981 "ADVANCE= specifier at %L.", &expr
->where
);
3983 io_constraint (unformatted
,
3984 "the ADVANCE= specifier at %L must appear with an "
3985 "explicit format expression", &expr
->where
);
3987 if (expr
->expr_type
== EXPR_CONSTANT
&& expr
->ts
.type
== BT_CHARACTER
)
3989 const gfc_char_t
*advance
= expr
->value
.character
.string
;
3990 not_no
= gfc_wide_strlen (advance
) != 2
3991 || gfc_wide_strncasecmp (advance
, "no", 2) != 0;
3992 not_yes
= gfc_wide_strlen (advance
) != 3
3993 || gfc_wide_strncasecmp (advance
, "yes", 3) != 0;
4001 io_constraint (not_no
&& not_yes
,
4002 "ADVANCE= specifier at %L must have value = "
4003 "YES or NO.", &expr
->where
);
4005 io_constraint (dt
->size
&& not_no
&& k
== M_READ
,
4006 "SIZE tag at %L requires an ADVANCE = %<NO%>",
4009 io_constraint (dt
->eor
&& not_no
&& k
== M_READ
,
4010 "EOR tag at %L requires an ADVANCE = %<NO%>",
4014 expr
= dt
->format_expr
;
4015 if (!gfc_simplify_expr (expr
, 0)
4016 || !check_format_string (expr
, k
== M_READ
))
4021 #undef io_constraint
4024 /* Match a READ, WRITE or PRINT statement. */
4027 match_io (io_kind k
)
4029 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4034 locus spec_end
, control
;
4038 where
= gfc_current_locus
;
4040 current_dt
= dt
= XCNEW (gfc_dt
);
4041 m
= gfc_match_char ('(');
4044 where
= gfc_current_locus
;
4047 else if (k
== M_PRINT
)
4049 /* Treat the non-standard case of PRINT namelist. */
4050 if ((gfc_current_form
== FORM_FIXED
|| gfc_peek_ascii_char () == ' ')
4051 && gfc_match_name (name
) == MATCH_YES
)
4053 gfc_find_symbol (name
, NULL
, 1, &sym
);
4054 if (sym
&& sym
->attr
.flavor
== FL_NAMELIST
)
4056 if (!gfc_notify_std (GFC_STD_GNU
, "PRINT namelist at "
4057 "%C is an extension"))
4063 dt
->io_unit
= default_unit (k
);
4068 gfc_current_locus
= where
;
4072 if (gfc_current_form
== FORM_FREE
)
4074 char c
= gfc_peek_ascii_char ();
4075 if (c
!= ' ' && c
!= '*' && c
!= '\'' && c
!= '"')
4082 m
= match_dt_format (dt
);
4083 if (m
== MATCH_ERROR
)
4089 dt
->io_unit
= default_unit (k
);
4094 /* Before issuing an error for a malformed 'print (1,*)' type of
4095 error, check for a default-char-expr of the form ('(I0)'). */
4098 control
= gfc_current_locus
;
4101 /* Reset current locus to get the initial '(' in an expression. */
4102 gfc_current_locus
= where
;
4103 dt
->format_expr
= NULL
;
4104 m
= match_dt_format (dt
);
4106 if (m
== MATCH_ERROR
)
4108 if (m
== MATCH_NO
|| dt
->format_expr
== NULL
)
4112 dt
->io_unit
= default_unit (k
);
4117 /* Commit any pending symbols now so that when we undo
4118 symbols later we wont lose them. */
4119 gfc_commit_symbols ();
4120 /* Reset current locus to get the initial '(' in an expression. */
4121 gfc_current_locus
= where
;
4122 dt
->format_expr
= NULL
;
4123 m
= gfc_match_expr (&dt
->format_expr
);
4127 && dt
->format_expr
->ts
.type
== BT_CHARACTER
)
4130 dt
->io_unit
= default_unit (k
);
4135 gfc_free_expr (dt
->format_expr
);
4136 dt
->format_expr
= NULL
;
4137 gfc_current_locus
= control
;
4143 gfc_undo_symbols ();
4144 gfc_free_expr (dt
->format_expr
);
4145 dt
->format_expr
= NULL
;
4146 gfc_current_locus
= control
;
4152 /* Match a control list */
4153 if (match_dt_element (k
, dt
) == MATCH_YES
)
4155 if (match_dt_unit (k
, dt
) != MATCH_YES
)
4158 if (gfc_match_char (')') == MATCH_YES
)
4160 if (gfc_match_char (',') != MATCH_YES
)
4163 m
= match_dt_element (k
, dt
);
4166 if (m
== MATCH_ERROR
)
4169 m
= match_dt_format (dt
);
4172 if (m
== MATCH_ERROR
)
4175 where
= gfc_current_locus
;
4177 m
= gfc_match_name (name
);
4180 gfc_find_symbol (name
, NULL
, 1, &sym
);
4181 if (sym
&& sym
->attr
.flavor
== FL_NAMELIST
)
4184 if (k
== M_READ
&& check_namelist (sym
))
4193 gfc_current_locus
= where
;
4195 goto loop
; /* No matches, try regular elements */
4198 if (gfc_match_char (')') == MATCH_YES
)
4200 if (gfc_match_char (',') != MATCH_YES
)
4206 m
= match_dt_element (k
, dt
);
4209 if (m
== MATCH_ERROR
)
4212 if (gfc_match_char (')') == MATCH_YES
)
4214 if (gfc_match_char (',') != MATCH_YES
)
4220 /* Used in check_io_constraints, where no locus is available. */
4221 spec_end
= gfc_current_locus
;
4223 /* Save the IO kind for later use. */
4224 dt
->dt_io_kind
= gfc_get_iokind_expr (&gfc_current_locus
, k
);
4226 /* Optional leading comma (non-standard). We use a gfc_expr structure here
4227 to save the locus. This is used later when resolving transfer statements
4228 that might have a format expression without unit number. */
4229 if (!comma_flag
&& gfc_match_char (',') == MATCH_YES
)
4230 dt
->extra_comma
= dt
->dt_io_kind
;
4233 if (gfc_match_eos () != MATCH_YES
)
4235 if (comma_flag
&& gfc_match_char (',') != MATCH_YES
)
4237 gfc_error ("Expected comma in I/O list at %C");
4242 m
= match_io_list (k
, &io_code
);
4243 if (m
== MATCH_ERROR
)
4249 /* See if we want to use defaults for missing exponents in real transfers. */
4251 dt
->default_exp
= 1;
4253 /* A full IO statement has been matched. Check the constraints. spec_end is
4254 supplied for cases where no locus is supplied. */
4255 m
= check_io_constraints (k
, dt
, io_code
, &spec_end
);
4257 if (m
== MATCH_ERROR
)
4260 new_st
.op
= (k
== M_READ
) ? EXEC_READ
: EXEC_WRITE
;
4262 new_st
.block
= gfc_get_code (new_st
.op
);
4263 new_st
.block
->next
= io_code
;
4265 terminate_io (io_code
);
4270 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
4280 gfc_match_read (void)
4282 return match_io (M_READ
);
4287 gfc_match_write (void)
4289 return match_io (M_WRITE
);
4294 gfc_match_print (void)
4298 m
= match_io (M_PRINT
);
4302 if (gfc_pure (NULL
))
4304 gfc_error ("PRINT statement at %C not allowed within PURE procedure");
4308 gfc_unset_implicit_pure (NULL
);
4314 /* Free a gfc_inquire structure. */
4317 gfc_free_inquire (gfc_inquire
*inquire
)
4320 if (inquire
== NULL
)
4323 gfc_free_expr (inquire
->unit
);
4324 gfc_free_expr (inquire
->file
);
4325 gfc_free_expr (inquire
->iomsg
);
4326 gfc_free_expr (inquire
->iostat
);
4327 gfc_free_expr (inquire
->exist
);
4328 gfc_free_expr (inquire
->opened
);
4329 gfc_free_expr (inquire
->number
);
4330 gfc_free_expr (inquire
->named
);
4331 gfc_free_expr (inquire
->name
);
4332 gfc_free_expr (inquire
->access
);
4333 gfc_free_expr (inquire
->sequential
);
4334 gfc_free_expr (inquire
->direct
);
4335 gfc_free_expr (inquire
->form
);
4336 gfc_free_expr (inquire
->formatted
);
4337 gfc_free_expr (inquire
->unformatted
);
4338 gfc_free_expr (inquire
->recl
);
4339 gfc_free_expr (inquire
->nextrec
);
4340 gfc_free_expr (inquire
->blank
);
4341 gfc_free_expr (inquire
->position
);
4342 gfc_free_expr (inquire
->action
);
4343 gfc_free_expr (inquire
->read
);
4344 gfc_free_expr (inquire
->write
);
4345 gfc_free_expr (inquire
->readwrite
);
4346 gfc_free_expr (inquire
->delim
);
4347 gfc_free_expr (inquire
->encoding
);
4348 gfc_free_expr (inquire
->pad
);
4349 gfc_free_expr (inquire
->iolength
);
4350 gfc_free_expr (inquire
->convert
);
4351 gfc_free_expr (inquire
->strm_pos
);
4352 gfc_free_expr (inquire
->asynchronous
);
4353 gfc_free_expr (inquire
->decimal
);
4354 gfc_free_expr (inquire
->pending
);
4355 gfc_free_expr (inquire
->id
);
4356 gfc_free_expr (inquire
->sign
);
4357 gfc_free_expr (inquire
->size
);
4358 gfc_free_expr (inquire
->round
);
4359 gfc_free_expr (inquire
->share
);
4360 gfc_free_expr (inquire
->cc
);
4365 /* Match an element of an INQUIRE statement. */
4367 #define RETM if (m != MATCH_NO) return m;
4370 match_inquire_element (gfc_inquire
*inquire
)
4374 m
= match_etag (&tag_unit
, &inquire
->unit
);
4375 RETM m
= match_etag (&tag_file
, &inquire
->file
);
4376 RETM m
= match_ltag (&tag_err
, &inquire
->err
);
4377 RETM m
= match_etag (&tag_iomsg
, &inquire
->iomsg
);
4378 if (m
== MATCH_YES
&& !check_char_variable (inquire
->iomsg
))
4380 RETM m
= match_out_tag (&tag_iostat
, &inquire
->iostat
);
4381 RETM m
= match_vtag (&tag_exist
, &inquire
->exist
);
4382 RETM m
= match_vtag (&tag_opened
, &inquire
->opened
);
4383 RETM m
= match_vtag (&tag_named
, &inquire
->named
);
4384 RETM m
= match_vtag (&tag_name
, &inquire
->name
);
4385 RETM m
= match_out_tag (&tag_number
, &inquire
->number
);
4386 RETM m
= match_vtag (&tag_s_access
, &inquire
->access
);
4387 RETM m
= match_vtag (&tag_sequential
, &inquire
->sequential
);
4388 RETM m
= match_vtag (&tag_direct
, &inquire
->direct
);
4389 RETM m
= match_vtag (&tag_s_form
, &inquire
->form
);
4390 RETM m
= match_vtag (&tag_formatted
, &inquire
->formatted
);
4391 RETM m
= match_vtag (&tag_unformatted
, &inquire
->unformatted
);
4392 RETM m
= match_out_tag (&tag_s_recl
, &inquire
->recl
);
4393 RETM m
= match_out_tag (&tag_nextrec
, &inquire
->nextrec
);
4394 RETM m
= match_vtag (&tag_s_blank
, &inquire
->blank
);
4395 RETM m
= match_vtag (&tag_s_position
, &inquire
->position
);
4396 RETM m
= match_vtag (&tag_s_action
, &inquire
->action
);
4397 RETM m
= match_vtag (&tag_read
, &inquire
->read
);
4398 RETM m
= match_vtag (&tag_write
, &inquire
->write
);
4399 RETM m
= match_vtag (&tag_readwrite
, &inquire
->readwrite
);
4400 RETM m
= match_vtag (&tag_s_async
, &inquire
->asynchronous
);
4401 if (m
== MATCH_YES
&& !is_char_type ("ASYNCHRONOUS", inquire
->asynchronous
))
4403 RETM m
= match_vtag (&tag_s_delim
, &inquire
->delim
);
4404 RETM m
= match_vtag (&tag_s_decimal
, &inquire
->decimal
);
4405 RETM m
= match_out_tag (&tag_size
, &inquire
->size
);
4406 RETM m
= match_vtag (&tag_s_encoding
, &inquire
->encoding
);
4407 RETM m
= match_vtag (&tag_s_round
, &inquire
->round
);
4408 RETM m
= match_vtag (&tag_s_sign
, &inquire
->sign
);
4409 RETM m
= match_vtag (&tag_s_pad
, &inquire
->pad
);
4410 RETM m
= match_out_tag (&tag_iolength
, &inquire
->iolength
);
4411 RETM m
= match_vtag (&tag_convert
, &inquire
->convert
);
4412 RETM m
= match_out_tag (&tag_strm_out
, &inquire
->strm_pos
);
4413 RETM m
= match_vtag (&tag_pending
, &inquire
->pending
);
4414 RETM m
= match_vtag (&tag_id
, &inquire
->id
);
4415 RETM m
= match_vtag (&tag_s_iqstream
, &inquire
->iqstream
);
4416 RETM m
= match_dec_vtag (&tag_v_share
, &inquire
->share
);
4417 RETM m
= match_dec_vtag (&tag_v_cc
, &inquire
->cc
);
4418 RETM
return MATCH_NO
;
4425 gfc_match_inquire (void)
4427 gfc_inquire
*inquire
;
4432 m
= gfc_match_char ('(');
4436 inquire
= XCNEW (gfc_inquire
);
4438 loc
= gfc_current_locus
;
4440 m
= match_inquire_element (inquire
);
4441 if (m
== MATCH_ERROR
)
4445 m
= gfc_match_expr (&inquire
->unit
);
4446 if (m
== MATCH_ERROR
)
4452 /* See if we have the IOLENGTH form of the inquire statement. */
4453 if (inquire
->iolength
!= NULL
)
4455 if (gfc_match_char (')') != MATCH_YES
)
4458 m
= match_io_list (M_INQUIRE
, &code
);
4459 if (m
== MATCH_ERROR
)
4464 new_st
.op
= EXEC_IOLENGTH
;
4465 new_st
.expr1
= inquire
->iolength
;
4466 new_st
.ext
.inquire
= inquire
;
4468 if (gfc_pure (NULL
))
4470 gfc_free_statements (code
);
4471 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4475 gfc_unset_implicit_pure (NULL
);
4477 new_st
.block
= gfc_get_code (EXEC_IOLENGTH
);
4478 terminate_io (code
);
4479 new_st
.block
->next
= code
;
4483 /* At this point, we have the non-IOLENGTH inquire statement. */
4486 if (gfc_match_char (')') == MATCH_YES
)
4488 if (gfc_match_char (',') != MATCH_YES
)
4491 m
= match_inquire_element (inquire
);
4492 if (m
== MATCH_ERROR
)
4497 if (inquire
->iolength
!= NULL
)
4499 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
4504 if (gfc_match_eos () != MATCH_YES
)
4507 if (inquire
->unit
!= NULL
&& inquire
->file
!= NULL
)
4509 gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
4510 "UNIT specifiers", &loc
);
4514 if (inquire
->unit
== NULL
&& inquire
->file
== NULL
)
4516 gfc_error ("INQUIRE statement at %L requires either FILE or "
4517 "UNIT specifier", &loc
);
4521 if (inquire
->unit
!= NULL
&& inquire
->unit
->expr_type
== EXPR_CONSTANT
4522 && inquire
->unit
->ts
.type
== BT_INTEGER
4523 && ((mpz_get_si (inquire
->unit
->value
.integer
) == GFC_INTERNAL_UNIT4
)
4524 || (mpz_get_si (inquire
->unit
->value
.integer
) == GFC_INTERNAL_UNIT
)))
4526 gfc_error ("UNIT number in INQUIRE statement at %L can not "
4527 "be %d", &loc
, (int) mpz_get_si (inquire
->unit
->value
.integer
));
4531 if (gfc_pure (NULL
))
4533 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4537 gfc_unset_implicit_pure (NULL
);
4539 if (inquire
->id
!= NULL
&& inquire
->pending
== NULL
)
4541 gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
4542 "the ID= specifier", &loc
);
4546 new_st
.op
= EXEC_INQUIRE
;
4547 new_st
.ext
.inquire
= inquire
;
4551 gfc_syntax_error (ST_INQUIRE
);
4554 gfc_free_inquire (inquire
);
4559 /* Resolve everything in a gfc_inquire structure. */
4562 gfc_resolve_inquire (gfc_inquire
*inquire
)
4564 RESOLVE_TAG (&tag_unit
, inquire
->unit
);
4565 RESOLVE_TAG (&tag_file
, inquire
->file
);
4566 RESOLVE_TAG (&tag_id
, inquire
->id
);
4568 /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4569 contexts. Thus, use an extended RESOLVE_TAG macro for that. */
4570 #define INQUIRE_RESOLVE_TAG(tag, expr) \
4571 RESOLVE_TAG (tag, expr); \
4575 sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
4576 if (gfc_check_vardef_context ((expr), false, false, false, \
4577 context) == false) \
4580 INQUIRE_RESOLVE_TAG (&tag_iomsg
, inquire
->iomsg
);
4581 INQUIRE_RESOLVE_TAG (&tag_iostat
, inquire
->iostat
);
4582 INQUIRE_RESOLVE_TAG (&tag_exist
, inquire
->exist
);
4583 INQUIRE_RESOLVE_TAG (&tag_opened
, inquire
->opened
);
4584 INQUIRE_RESOLVE_TAG (&tag_number
, inquire
->number
);
4585 INQUIRE_RESOLVE_TAG (&tag_named
, inquire
->named
);
4586 INQUIRE_RESOLVE_TAG (&tag_name
, inquire
->name
);
4587 INQUIRE_RESOLVE_TAG (&tag_s_access
, inquire
->access
);
4588 INQUIRE_RESOLVE_TAG (&tag_sequential
, inquire
->sequential
);
4589 INQUIRE_RESOLVE_TAG (&tag_direct
, inquire
->direct
);
4590 INQUIRE_RESOLVE_TAG (&tag_s_form
, inquire
->form
);
4591 INQUIRE_RESOLVE_TAG (&tag_formatted
, inquire
->formatted
);
4592 INQUIRE_RESOLVE_TAG (&tag_unformatted
, inquire
->unformatted
);
4593 INQUIRE_RESOLVE_TAG (&tag_s_recl
, inquire
->recl
);
4594 INQUIRE_RESOLVE_TAG (&tag_nextrec
, inquire
->nextrec
);
4595 INQUIRE_RESOLVE_TAG (&tag_s_blank
, inquire
->blank
);
4596 INQUIRE_RESOLVE_TAG (&tag_s_position
, inquire
->position
);
4597 INQUIRE_RESOLVE_TAG (&tag_s_action
, inquire
->action
);
4598 INQUIRE_RESOLVE_TAG (&tag_read
, inquire
->read
);
4599 INQUIRE_RESOLVE_TAG (&tag_write
, inquire
->write
);
4600 INQUIRE_RESOLVE_TAG (&tag_readwrite
, inquire
->readwrite
);
4601 INQUIRE_RESOLVE_TAG (&tag_s_delim
, inquire
->delim
);
4602 INQUIRE_RESOLVE_TAG (&tag_s_pad
, inquire
->pad
);
4603 INQUIRE_RESOLVE_TAG (&tag_s_encoding
, inquire
->encoding
);
4604 INQUIRE_RESOLVE_TAG (&tag_s_round
, inquire
->round
);
4605 INQUIRE_RESOLVE_TAG (&tag_iolength
, inquire
->iolength
);
4606 INQUIRE_RESOLVE_TAG (&tag_convert
, inquire
->convert
);
4607 INQUIRE_RESOLVE_TAG (&tag_strm_out
, inquire
->strm_pos
);
4608 INQUIRE_RESOLVE_TAG (&tag_s_async
, inquire
->asynchronous
);
4609 INQUIRE_RESOLVE_TAG (&tag_s_sign
, inquire
->sign
);
4610 INQUIRE_RESOLVE_TAG (&tag_s_round
, inquire
->round
);
4611 INQUIRE_RESOLVE_TAG (&tag_pending
, inquire
->pending
);
4612 INQUIRE_RESOLVE_TAG (&tag_size
, inquire
->size
);
4613 INQUIRE_RESOLVE_TAG (&tag_s_decimal
, inquire
->decimal
);
4614 INQUIRE_RESOLVE_TAG (&tag_s_iqstream
, inquire
->iqstream
);
4615 INQUIRE_RESOLVE_TAG (&tag_v_share
, inquire
->share
);
4616 INQUIRE_RESOLVE_TAG (&tag_v_cc
, inquire
->cc
);
4617 #undef INQUIRE_RESOLVE_TAG
4619 if (!gfc_reference_st_label (inquire
->err
, ST_LABEL_TARGET
))
4627 gfc_free_wait (gfc_wait
*wait
)
4632 gfc_free_expr (wait
->unit
);
4633 gfc_free_expr (wait
->iostat
);
4634 gfc_free_expr (wait
->iomsg
);
4635 gfc_free_expr (wait
->id
);
4641 gfc_resolve_wait (gfc_wait
*wait
)
4643 RESOLVE_TAG (&tag_unit
, wait
->unit
);
4644 RESOLVE_TAG (&tag_iomsg
, wait
->iomsg
);
4645 RESOLVE_TAG (&tag_iostat
, wait
->iostat
);
4646 RESOLVE_TAG (&tag_id
, wait
->id
);
4648 if (!gfc_reference_st_label (wait
->err
, ST_LABEL_TARGET
))
4651 if (!gfc_reference_st_label (wait
->end
, ST_LABEL_TARGET
))
4657 /* Match an element of a WAIT statement. */
4659 #define RETM if (m != MATCH_NO) return m;
4662 match_wait_element (gfc_wait
*wait
)
4666 m
= match_etag (&tag_unit
, &wait
->unit
);
4667 RETM m
= match_ltag (&tag_err
, &wait
->err
);
4668 RETM m
= match_ltag (&tag_end
, &wait
->end
);
4669 RETM m
= match_ltag (&tag_eor
, &wait
->eor
);
4670 RETM m
= match_etag (&tag_iomsg
, &wait
->iomsg
);
4671 if (m
== MATCH_YES
&& !check_char_variable (wait
->iomsg
))
4673 RETM m
= match_out_tag (&tag_iostat
, &wait
->iostat
);
4674 RETM m
= match_etag (&tag_id
, &wait
->id
);
4675 RETM
return MATCH_NO
;
4682 gfc_match_wait (void)
4687 m
= gfc_match_char ('(');
4691 wait
= XCNEW (gfc_wait
);
4693 m
= match_wait_element (wait
);
4694 if (m
== MATCH_ERROR
)
4698 m
= gfc_match_expr (&wait
->unit
);
4699 if (m
== MATCH_ERROR
)
4707 if (gfc_match_char (')') == MATCH_YES
)
4709 if (gfc_match_char (',') != MATCH_YES
)
4712 m
= match_wait_element (wait
);
4713 if (m
== MATCH_ERROR
)
4719 if (!gfc_notify_std (GFC_STD_F2003
, "WAIT at %C "
4720 "not allowed in Fortran 95"))
4723 if (gfc_pure (NULL
))
4725 gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4729 gfc_unset_implicit_pure (NULL
);
4731 new_st
.op
= EXEC_WAIT
;
4732 new_st
.ext
.wait
= wait
;
4737 gfc_syntax_error (ST_WAIT
);
4740 gfc_free_wait (wait
);