1 /* Deal with I/O statements & related stuff.
2 Copyright (C) 2000-2014 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
,
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
120 /* Local variables for checking format strings. The saved_token is
121 used to back up by a single format token during the parsing
123 static gfc_char_t
*format_string
;
124 static int format_string_pos
;
125 static int format_length
, use_last_char
;
126 static char error_element
;
127 static locus format_locus
;
129 static format_token saved_token
;
132 { MODE_STRING
, MODE_FORMAT
, MODE_COPY
}
136 /* Return the next character in the format string. */
139 next_char (gfc_instring in_string
)
151 if (mode
== MODE_STRING
)
152 c
= *format_string
++;
155 c
= gfc_next_char_literal (in_string
);
160 if (gfc_option
.flag_backslash
&& c
== '\\')
162 locus old_locus
= gfc_current_locus
;
164 if (gfc_match_special_char (&c
) == MATCH_NO
)
165 gfc_current_locus
= old_locus
;
167 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
168 gfc_warning ("Extension: backslash character at %C");
171 if (mode
== MODE_COPY
)
172 *format_string
++ = c
;
174 if (mode
!= MODE_STRING
)
175 format_locus
= gfc_current_locus
;
179 c
= gfc_wide_toupper (c
);
184 /* Back up one character position. Only works once. */
192 /* Eat up the spaces and return a character. */
195 next_char_not_space (bool *error
)
200 error_element
= c
= next_char (NONSTRING
);
203 if (gfc_option
.allow_std
& GFC_STD_GNU
)
204 gfc_warning ("Extension: Tab character in format at %C");
207 gfc_error ("Extension: Tab character in format at %C");
213 while (gfc_is_whitespace (c
));
217 static int value
= 0;
219 /* Simple lexical analyzer for getting the next token in a FORMAT
231 if (saved_token
!= FMT_NONE
)
234 saved_token
= FMT_NONE
;
238 c
= next_char_not_space (&error
);
248 c
= next_char_not_space (&error
);
259 c
= next_char_not_space (&error
);
261 value
= 10 * value
+ c
- '0';
270 token
= FMT_SIGNED_INT
;
289 c
= next_char_not_space (&error
);
292 value
= 10 * value
+ c
- '0';
300 token
= zflag
? FMT_ZERO
: FMT_POSINT
;
324 c
= next_char_not_space (&error
);
352 c
= next_char_not_space (&error
);
353 if (c
!= 'P' && c
!= 'S')
360 c
= next_char_not_space (&error
);
361 if (c
== 'N' || c
== 'Z')
379 c
= next_char (INSTRING_WARN
);
388 c
= next_char (INSTRING_NOWARN
);
422 c
= next_char_not_space (&error
);
452 c
= next_char_not_space (&error
);
455 if (!gfc_notify_std (GFC_STD_F2003
, "DP format "
456 "specifier not allowed at %C"))
462 if (!gfc_notify_std (GFC_STD_F2003
, "DC format "
463 "specifier not allowed at %C"))
475 c
= next_char_not_space (&error
);
524 token_to_string (format_token t
)
543 /* Check a format statement. The format string, either from a FORMAT
544 statement or a constant in an I/O statement has already been parsed
545 by itself, and we are checking it for validity. The dual origin
546 means that the warning message is a little less than great. */
549 check_format (bool is_input
)
551 const char *posint_required
= _("Positive width required");
552 const char *nonneg_required
= _("Nonnegative width required");
553 const char *unexpected_element
= _("Unexpected element '%c' in format string"
555 const char *unexpected_end
= _("Unexpected end of format string");
556 const char *zero_width
= _("Zero width in format descriptor");
565 saved_token
= FMT_NONE
;
569 format_string_pos
= 0;
576 error
= _("Missing leading left parenthesis");
584 goto finished
; /* Empty format is legal */
588 /* In this state, the next thing has to be a format item. */
605 error
= _("Left parenthesis required after '*'");
630 /* Signed integer can only precede a P format. */
636 error
= _("Expected P edit descriptor");
643 /* P requires a prior number. */
644 error
= _("P descriptor requires leading scale factor");
648 /* X requires a prior number if we're being pedantic. */
649 if (mode
!= MODE_FORMAT
)
650 format_locus
.nextc
+= format_string_pos
;
651 if (!gfc_notify_std (GFC_STD_GNU
, "X descriptor requires leading "
652 "space count at %L", &format_locus
))
669 goto extension_optional_comma
;
680 if (!gfc_notify_std (GFC_STD_GNU
, "$ descriptor at %L", &format_locus
))
682 if (t
!= FMT_RPAREN
|| level
> 0)
684 gfc_warning ("$ should be the last specifier in format at %L",
686 goto optional_comma_1
;
707 error
= unexpected_end
;
711 error
= unexpected_element
;
716 /* In this state, t must currently be a data descriptor.
717 Deal with things that can/must follow the descriptor. */
728 /* No comma after P allowed only for F, E, EN, ES, D, or G.
733 if (!(gfc_option
.allow_std
& GFC_STD_F2003
) && t
!= FMT_COMMA
734 && t
!= FMT_F
&& t
!= FMT_E
&& t
!= FMT_EN
&& t
!= FMT_ES
735 && t
!= FMT_D
&& t
!= FMT_G
&& t
!= FMT_RPAREN
&& t
!= FMT_SLASH
)
737 error
= _("Comma required after P descriptor");
748 if (t
!= FMT_F
&& t
!= FMT_E
&& t
!= FMT_EN
&& t
!= FMT_ES
&& t
!= FMT_D
749 && t
!= FMT_G
&& t
!= FMT_RPAREN
&& t
!= FMT_SLASH
)
751 error
= _("Comma required after P descriptor");
765 error
= _("Positive width required with T descriptor");
777 switch (gfc_notification_std (GFC_STD_GNU
))
780 if (mode
!= MODE_FORMAT
)
781 format_locus
.nextc
+= format_string_pos
;
782 gfc_warning ("Extension: Missing positive width after L "
783 "descriptor at %L", &format_locus
);
788 error
= posint_required
;
819 if (t
== FMT_G
&& u
== FMT_ZERO
)
826 if (!gfc_notify_std (GFC_STD_F2008
, "'G0' in format at %L",
838 error
= posint_required
;
844 error
= _("E specifier not allowed with g0 descriptor");
853 format_locus
.nextc
+= format_string_pos
;
854 gfc_error ("Positive width required in format "
855 "specifier %s at %L", token_to_string (t
),
866 /* Warn if -std=legacy, otherwise error. */
867 format_locus
.nextc
+= format_string_pos
;
868 if (gfc_option
.warn_std
!= 0)
870 gfc_error ("Period required in format "
871 "specifier %s at %L", token_to_string (t
),
877 gfc_warning ("Period required in format "
878 "specifier %s at %L", token_to_string (t
),
880 /* If we go to finished, we need to unwind this
881 before the next round. */
882 format_locus
.nextc
-= format_string_pos
;
890 if (u
!= FMT_ZERO
&& u
!= FMT_POSINT
)
892 error
= nonneg_required
;
899 /* Look for optional exponent. */
914 error
= _("Positive exponent width required");
925 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
927 error
= nonneg_required
;
930 else if (is_input
&& t
== FMT_ZERO
)
932 error
= posint_required
;
941 /* Warn if -std=legacy, otherwise error. */
942 if (gfc_option
.warn_std
!= 0)
944 error
= _("Period required in format specifier");
947 if (mode
!= MODE_FORMAT
)
948 format_locus
.nextc
+= format_string_pos
;
949 gfc_warning ("Period required in format specifier at %L",
958 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
960 error
= nonneg_required
;
967 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
969 if (mode
!= MODE_FORMAT
)
970 format_locus
.nextc
+= format_string_pos
;
971 gfc_warning ("The H format specifier at %L is"
972 " a Fortran 95 deleted feature", &format_locus
);
974 if (mode
== MODE_STRING
)
976 format_string
+= value
;
977 format_length
-= value
;
978 format_string_pos
+= repeat
;
984 next_char (INSTRING_WARN
);
994 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
996 error
= nonneg_required
;
999 else if (is_input
&& t
== FMT_ZERO
)
1001 error
= posint_required
;
1008 if (t
!= FMT_PERIOD
)
1017 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
1019 error
= nonneg_required
;
1027 error
= unexpected_element
;
1032 /* Between a descriptor and what comes next. */
1050 goto optional_comma
;
1053 error
= unexpected_end
;
1057 if (mode
!= MODE_FORMAT
)
1058 format_locus
.nextc
+= format_string_pos
- 1;
1059 if (!gfc_notify_std (GFC_STD_GNU
, "Missing comma at %L", &format_locus
))
1061 /* If we do not actually return a failure, we need to unwind this
1062 before the next round. */
1063 if (mode
!= MODE_FORMAT
)
1064 format_locus
.nextc
-= format_string_pos
;
1069 /* Optional comma is a weird between state where we've just finished
1070 reading a colon, slash, dollar or P descriptor. */
1087 /* Assume that we have another format item. */
1094 extension_optional_comma
:
1095 /* As a GNU extension, permit a missing comma after a string literal. */
1112 goto optional_comma
;
1115 error
= unexpected_end
;
1119 if (mode
!= MODE_FORMAT
)
1120 format_locus
.nextc
+= format_string_pos
;
1121 if (!gfc_notify_std (GFC_STD_GNU
, "Missing comma at %L", &format_locus
))
1123 /* If we do not actually return a failure, we need to unwind this
1124 before the next round. */
1125 if (mode
!= MODE_FORMAT
)
1126 format_locus
.nextc
-= format_string_pos
;
1134 if (mode
!= MODE_FORMAT
)
1135 format_locus
.nextc
+= format_string_pos
;
1136 if (error
== unexpected_element
)
1137 gfc_error (error
, error_element
, &format_locus
);
1139 gfc_error ("%s in format string at %L", error
, &format_locus
);
1148 /* Given an expression node that is a constant string, see if it looks
1149 like a format string. */
1152 check_format_string (gfc_expr
*e
, bool is_input
)
1156 if (!e
|| e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1160 format_string
= e
->value
.character
.string
;
1162 /* More elaborate measures are needed to show where a problem is within a
1163 format string that has been calculated, but that's probably not worth the
1165 format_locus
= e
->where
;
1166 rv
= check_format (is_input
);
1167 /* check for extraneous characters at the end of an otherwise valid format
1168 string, like '(A10,I3)F5'
1169 start at the end and move back to the last character processed,
1171 if (rv
&& e
->value
.character
.length
> format_string_pos
)
1172 for (i
=e
->value
.character
.length
-1;i
>format_string_pos
-1;i
--)
1173 if (e
->value
.character
.string
[i
] != ' ')
1175 format_locus
.nextc
+= format_length
+ 1;
1176 gfc_warning ("Extraneous characters in format at %L", &format_locus
);
1183 /************ Fortran 95 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 if (gfc_statement_label
== NULL
)
1204 gfc_error ("Missing format label at %C");
1207 gfc_gobble_whitespace ();
1212 start
= gfc_current_locus
;
1214 if (!check_format (false))
1217 if (gfc_match_eos () != MATCH_YES
)
1219 gfc_syntax_error (ST_FORMAT
);
1223 /* The label doesn't get created until after the statement is done
1224 being matched, so we have to leave the string for later. */
1226 gfc_current_locus
= start
; /* Back to the beginning */
1229 new_st
.op
= EXEC_NOP
;
1231 e
= gfc_get_character_expr (gfc_default_character_kind
, &start
,
1232 NULL
, format_length
);
1233 format_string
= e
->value
.character
.string
;
1234 gfc_statement_label
->format
= e
;
1237 check_format (false); /* Guaranteed to succeed */
1238 gfc_match_eos (); /* Guaranteed to succeed */
1244 /* Match an expression I/O tag of some sort. */
1247 match_etag (const io_tag
*tag
, gfc_expr
**v
)
1252 m
= gfc_match (tag
->spec
);
1256 m
= gfc_match (tag
->value
, &result
);
1259 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1265 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1266 gfc_free_expr (result
);
1275 /* Match a variable I/O tag of some sort. */
1278 match_vtag (const io_tag
*tag
, gfc_expr
**v
)
1283 m
= gfc_match (tag
->spec
);
1287 m
= gfc_match (tag
->value
, &result
);
1290 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1296 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1297 gfc_free_expr (result
);
1301 if (result
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1303 gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag
->name
);
1304 gfc_free_expr (result
);
1308 bool impure
= gfc_impure_variable (result
->symtree
->n
.sym
);
1309 if (impure
&& gfc_pure (NULL
))
1311 gfc_error ("Variable %s cannot be assigned in PURE procedure at %C",
1313 gfc_free_expr (result
);
1318 gfc_unset_implicit_pure (NULL
);
1325 /* Match I/O tags that cause variables to become redefined. */
1328 match_out_tag (const io_tag
*tag
, gfc_expr
**result
)
1332 m
= match_vtag (tag
, result
);
1334 gfc_check_do_variable ((*result
)->symtree
);
1340 /* Match a label I/O tag. */
1343 match_ltag (const io_tag
*tag
, gfc_st_label
** label
)
1349 m
= gfc_match (tag
->spec
);
1353 m
= gfc_match (tag
->value
, label
);
1356 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1362 gfc_error ("Duplicate %s label specification at %C", tag
->name
);
1366 if (!gfc_reference_st_label (*label
, ST_LABEL_TARGET
))
1373 /* Resolution of the FORMAT tag, to be called from resolve_tag. */
1376 resolve_tag_format (const gfc_expr
*e
)
1378 if (e
->expr_type
== EXPR_CONSTANT
1379 && (e
->ts
.type
!= BT_CHARACTER
1380 || e
->ts
.kind
!= gfc_default_character_kind
))
1382 gfc_error ("Constant expression in FORMAT tag at %L must be "
1383 "of type default CHARACTER", &e
->where
);
1387 /* If e's rank is zero and e is not an element of an array, it should be
1388 of integer or character type. The integer variable should be
1391 && (e
->expr_type
!= EXPR_VARIABLE
1392 || e
->symtree
== NULL
1393 || e
->symtree
->n
.sym
->as
== NULL
1394 || e
->symtree
->n
.sym
->as
->rank
== 0))
1396 if ((e
->ts
.type
!= BT_CHARACTER
1397 || e
->ts
.kind
!= gfc_default_character_kind
)
1398 && e
->ts
.type
!= BT_INTEGER
)
1400 gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER "
1401 "or of INTEGER", &e
->where
);
1404 else if (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_VARIABLE
)
1406 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGNED variable in "
1407 "FORMAT tag at %L", &e
->where
))
1409 if (e
->symtree
->n
.sym
->attr
.assign
!= 1)
1411 gfc_error ("Variable '%s' at %L has not been assigned a "
1412 "format label", e
->symtree
->n
.sym
->name
, &e
->where
);
1416 else if (e
->ts
.type
== BT_INTEGER
)
1418 gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
1419 "variable", gfc_basic_typename (e
->ts
.type
), &e
->where
);
1426 /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
1427 It may be assigned an Hollerith constant. */
1428 if (e
->ts
.type
!= BT_CHARACTER
)
1430 if (!gfc_notify_std (GFC_STD_LEGACY
, "Non-character in FORMAT tag "
1431 "at %L", &e
->where
))
1434 if (e
->rank
== 0 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
)
1436 gfc_error ("Non-character assumed shape array element in FORMAT"
1437 " tag at %L", &e
->where
);
1441 if (e
->rank
== 0 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
)
1443 gfc_error ("Non-character assumed size array element in FORMAT"
1444 " tag at %L", &e
->where
);
1448 if (e
->rank
== 0 && e
->symtree
->n
.sym
->attr
.pointer
)
1450 gfc_error ("Non-character pointer array element in FORMAT tag at %L",
1460 /* Do expression resolution and type-checking on an expression tag. */
1463 resolve_tag (const io_tag
*tag
, gfc_expr
*e
)
1468 if (!gfc_resolve_expr (e
))
1471 if (tag
== &tag_format
)
1472 return resolve_tag_format (e
);
1474 if (e
->ts
.type
!= tag
->type
)
1476 gfc_error ("%s tag at %L must be of type %s", tag
->name
,
1477 &e
->where
, gfc_basic_typename (tag
->type
));
1481 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= gfc_default_character_kind
)
1483 gfc_error ("%s tag at %L must be a character string of default kind",
1484 tag
->name
, &e
->where
);
1490 gfc_error ("%s tag at %L must be scalar", tag
->name
, &e
->where
);
1494 if (tag
== &tag_iomsg
)
1496 if (!gfc_notify_std (GFC_STD_F2003
, "IOMSG tag at %L", &e
->where
))
1500 if ((tag
== &tag_iostat
|| tag
== &tag_size
|| tag
== &tag_iolength
)
1501 && e
->ts
.kind
!= gfc_default_integer_kind
)
1503 if (!gfc_notify_std (GFC_STD_F2003
, "Fortran 95 requires default "
1504 "INTEGER in %s tag at %L", tag
->name
, &e
->where
))
1508 if (tag
== &tag_exist
&& e
->ts
.kind
!= gfc_default_logical_kind
)
1510 if (!gfc_notify_std (GFC_STD_F2008
, "Nondefault LOGICAL "
1511 "in %s tag at %L", tag
->name
, &e
->where
))
1515 if (tag
== &tag_newunit
)
1517 if (!gfc_notify_std (GFC_STD_F2008
, "NEWUNIT specifier at %L",
1522 /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */
1523 if (tag
== &tag_newunit
|| tag
== &tag_iostat
1524 || tag
== &tag_size
|| tag
== &tag_iomsg
)
1528 sprintf (context
, _("%s tag"), tag
->name
);
1529 if (!gfc_check_vardef_context (e
, false, false, false, context
))
1533 if (tag
== &tag_convert
)
1535 if (!gfc_notify_std (GFC_STD_GNU
, "CONVERT tag at %L", &e
->where
))
1543 /* Match a single tag of an OPEN statement. */
1546 match_open_element (gfc_open
*open
)
1550 m
= match_etag (&tag_e_async
, &open
->asynchronous
);
1553 m
= match_etag (&tag_unit
, &open
->unit
);
1556 m
= match_out_tag (&tag_iomsg
, &open
->iomsg
);
1559 m
= match_out_tag (&tag_iostat
, &open
->iostat
);
1562 m
= match_etag (&tag_file
, &open
->file
);
1565 m
= match_etag (&tag_status
, &open
->status
);
1568 m
= match_etag (&tag_e_access
, &open
->access
);
1571 m
= match_etag (&tag_e_form
, &open
->form
);
1574 m
= match_etag (&tag_e_recl
, &open
->recl
);
1577 m
= match_etag (&tag_e_blank
, &open
->blank
);
1580 m
= match_etag (&tag_e_position
, &open
->position
);
1583 m
= match_etag (&tag_e_action
, &open
->action
);
1586 m
= match_etag (&tag_e_delim
, &open
->delim
);
1589 m
= match_etag (&tag_e_pad
, &open
->pad
);
1592 m
= match_etag (&tag_e_decimal
, &open
->decimal
);
1595 m
= match_etag (&tag_e_encoding
, &open
->encoding
);
1598 m
= match_etag (&tag_e_round
, &open
->round
);
1601 m
= match_etag (&tag_e_sign
, &open
->sign
);
1604 m
= match_ltag (&tag_err
, &open
->err
);
1607 m
= match_etag (&tag_convert
, &open
->convert
);
1610 m
= match_out_tag (&tag_newunit
, &open
->newunit
);
1618 /* Free the gfc_open structure and all the expressions it contains. */
1621 gfc_free_open (gfc_open
*open
)
1626 gfc_free_expr (open
->unit
);
1627 gfc_free_expr (open
->iomsg
);
1628 gfc_free_expr (open
->iostat
);
1629 gfc_free_expr (open
->file
);
1630 gfc_free_expr (open
->status
);
1631 gfc_free_expr (open
->access
);
1632 gfc_free_expr (open
->form
);
1633 gfc_free_expr (open
->recl
);
1634 gfc_free_expr (open
->blank
);
1635 gfc_free_expr (open
->position
);
1636 gfc_free_expr (open
->action
);
1637 gfc_free_expr (open
->delim
);
1638 gfc_free_expr (open
->pad
);
1639 gfc_free_expr (open
->decimal
);
1640 gfc_free_expr (open
->encoding
);
1641 gfc_free_expr (open
->round
);
1642 gfc_free_expr (open
->sign
);
1643 gfc_free_expr (open
->convert
);
1644 gfc_free_expr (open
->asynchronous
);
1645 gfc_free_expr (open
->newunit
);
1650 /* Resolve everything in a gfc_open structure. */
1653 gfc_resolve_open (gfc_open
*open
)
1656 RESOLVE_TAG (&tag_unit
, open
->unit
);
1657 RESOLVE_TAG (&tag_iomsg
, open
->iomsg
);
1658 RESOLVE_TAG (&tag_iostat
, open
->iostat
);
1659 RESOLVE_TAG (&tag_file
, open
->file
);
1660 RESOLVE_TAG (&tag_status
, open
->status
);
1661 RESOLVE_TAG (&tag_e_access
, open
->access
);
1662 RESOLVE_TAG (&tag_e_form
, open
->form
);
1663 RESOLVE_TAG (&tag_e_recl
, open
->recl
);
1664 RESOLVE_TAG (&tag_e_blank
, open
->blank
);
1665 RESOLVE_TAG (&tag_e_position
, open
->position
);
1666 RESOLVE_TAG (&tag_e_action
, open
->action
);
1667 RESOLVE_TAG (&tag_e_delim
, open
->delim
);
1668 RESOLVE_TAG (&tag_e_pad
, open
->pad
);
1669 RESOLVE_TAG (&tag_e_decimal
, open
->decimal
);
1670 RESOLVE_TAG (&tag_e_encoding
, open
->encoding
);
1671 RESOLVE_TAG (&tag_e_async
, open
->asynchronous
);
1672 RESOLVE_TAG (&tag_e_round
, open
->round
);
1673 RESOLVE_TAG (&tag_e_sign
, open
->sign
);
1674 RESOLVE_TAG (&tag_convert
, open
->convert
);
1675 RESOLVE_TAG (&tag_newunit
, open
->newunit
);
1677 if (!gfc_reference_st_label (open
->err
, ST_LABEL_TARGET
))
1684 /* Check if a given value for a SPECIFIER is either in the list of values
1685 allowed in F95 or F2003, issuing an error message and returning a zero
1686 value if it is not allowed. */
1689 compare_to_allowed_values (const char *specifier
, const char *allowed
[],
1690 const char *allowed_f2003
[],
1691 const char *allowed_gnu
[], gfc_char_t
*value
,
1692 const char *statement
, bool warn
)
1697 len
= gfc_wide_strlen (value
);
1700 for (len
--; len
> 0; len
--)
1701 if (value
[len
] != ' ')
1706 for (i
= 0; allowed
[i
]; i
++)
1707 if (len
== strlen (allowed
[i
])
1708 && gfc_wide_strncasecmp (value
, allowed
[i
], strlen (allowed
[i
])) == 0)
1711 for (i
= 0; allowed_f2003
&& allowed_f2003
[i
]; i
++)
1712 if (len
== strlen (allowed_f2003
[i
])
1713 && gfc_wide_strncasecmp (value
, allowed_f2003
[i
],
1714 strlen (allowed_f2003
[i
])) == 0)
1716 notification n
= gfc_notification_std (GFC_STD_F2003
);
1718 if (n
== WARNING
|| (warn
&& n
== ERROR
))
1720 gfc_warning ("Fortran 2003: %s specifier in %s statement at %C "
1721 "has value '%s'", specifier
, statement
,
1728 gfc_notify_std (GFC_STD_F2003
, "%s specifier in "
1729 "%s statement at %C has value '%s'", specifier
,
1730 statement
, allowed_f2003
[i
]);
1738 for (i
= 0; allowed_gnu
&& allowed_gnu
[i
]; i
++)
1739 if (len
== strlen (allowed_gnu
[i
])
1740 && gfc_wide_strncasecmp (value
, allowed_gnu
[i
],
1741 strlen (allowed_gnu
[i
])) == 0)
1743 notification n
= gfc_notification_std (GFC_STD_GNU
);
1745 if (n
== WARNING
|| (warn
&& n
== ERROR
))
1747 gfc_warning ("Extension: %s specifier in %s statement at %C "
1748 "has value '%s'", specifier
, statement
,
1755 gfc_notify_std (GFC_STD_GNU
, "%s specifier in "
1756 "%s statement at %C has value '%s'", specifier
,
1757 statement
, allowed_gnu
[i
]);
1767 char *s
= gfc_widechar_to_char (value
, -1);
1768 gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
1769 specifier
, statement
, s
);
1775 char *s
= gfc_widechar_to_char (value
, -1);
1776 gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
1777 specifier
, statement
, s
);
1784 /* Match an OPEN statement. */
1787 gfc_match_open (void)
1793 m
= gfc_match_char ('(');
1797 open
= XCNEW (gfc_open
);
1799 m
= match_open_element (open
);
1801 if (m
== MATCH_ERROR
)
1805 m
= gfc_match_expr (&open
->unit
);
1806 if (m
== MATCH_ERROR
)
1812 if (gfc_match_char (')') == MATCH_YES
)
1814 if (gfc_match_char (',') != MATCH_YES
)
1817 m
= match_open_element (open
);
1818 if (m
== MATCH_ERROR
)
1824 if (gfc_match_eos () == MATCH_NO
)
1827 if (gfc_pure (NULL
))
1829 gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1833 gfc_unset_implicit_pure (NULL
);
1835 warn
= (open
->err
|| open
->iostat
) ? true : false;
1837 /* Checks on NEWUNIT specifier. */
1842 gfc_error ("UNIT specifier not allowed with NEWUNIT at %C");
1846 if (!(open
->file
|| (open
->status
1847 && gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
1848 "scratch", 7) == 0)))
1850 gfc_error ("NEWUNIT specifier must have FILE= "
1851 "or STATUS='scratch' at %C");
1855 else if (!open
->unit
)
1857 gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified");
1861 /* Checks on the ACCESS specifier. */
1862 if (open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
)
1864 static const char *access_f95
[] = { "SEQUENTIAL", "DIRECT", NULL
};
1865 static const char *access_f2003
[] = { "STREAM", NULL
};
1866 static const char *access_gnu
[] = { "APPEND", NULL
};
1868 if (!compare_to_allowed_values ("ACCESS", access_f95
, access_f2003
,
1870 open
->access
->value
.character
.string
,
1875 /* Checks on the ACTION specifier. */
1876 if (open
->action
&& open
->action
->expr_type
== EXPR_CONSTANT
)
1878 static const char *action
[] = { "READ", "WRITE", "READWRITE", NULL
};
1880 if (!compare_to_allowed_values ("ACTION", action
, NULL
, NULL
,
1881 open
->action
->value
.character
.string
,
1886 /* Checks on the ASYNCHRONOUS specifier. */
1887 if (open
->asynchronous
)
1889 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS= at %C "
1890 "not allowed in Fortran 95"))
1893 if (open
->asynchronous
->expr_type
== EXPR_CONSTANT
)
1895 static const char * asynchronous
[] = { "YES", "NO", NULL
};
1897 if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous
,
1898 NULL
, NULL
, open
->asynchronous
->value
.character
.string
,
1904 /* Checks on the BLANK specifier. */
1907 if (!gfc_notify_std (GFC_STD_F2003
, "BLANK= at %C "
1908 "not allowed in Fortran 95"))
1911 if (open
->blank
->expr_type
== EXPR_CONSTANT
)
1913 static const char *blank
[] = { "ZERO", "NULL", NULL
};
1915 if (!compare_to_allowed_values ("BLANK", blank
, NULL
, NULL
,
1916 open
->blank
->value
.character
.string
,
1922 /* Checks on the DECIMAL specifier. */
1925 if (!gfc_notify_std (GFC_STD_F2003
, "DECIMAL= at %C "
1926 "not allowed in Fortran 95"))
1929 if (open
->decimal
->expr_type
== EXPR_CONSTANT
)
1931 static const char * decimal
[] = { "COMMA", "POINT", NULL
};
1933 if (!compare_to_allowed_values ("DECIMAL", decimal
, NULL
, NULL
,
1934 open
->decimal
->value
.character
.string
,
1940 /* Checks on the DELIM specifier. */
1943 if (open
->delim
->expr_type
== EXPR_CONSTANT
)
1945 static const char *delim
[] = { "APOSTROPHE", "QUOTE", "NONE", NULL
};
1947 if (!compare_to_allowed_values ("DELIM", delim
, NULL
, NULL
,
1948 open
->delim
->value
.character
.string
,
1954 /* Checks on the ENCODING specifier. */
1957 if (!gfc_notify_std (GFC_STD_F2003
, "ENCODING= at %C "
1958 "not allowed in Fortran 95"))
1961 if (open
->encoding
->expr_type
== EXPR_CONSTANT
)
1963 static const char * encoding
[] = { "DEFAULT", "UTF-8", NULL
};
1965 if (!compare_to_allowed_values ("ENCODING", encoding
, NULL
, NULL
,
1966 open
->encoding
->value
.character
.string
,
1972 /* Checks on the FORM specifier. */
1973 if (open
->form
&& open
->form
->expr_type
== EXPR_CONSTANT
)
1975 static const char *form
[] = { "FORMATTED", "UNFORMATTED", NULL
};
1977 if (!compare_to_allowed_values ("FORM", form
, NULL
, NULL
,
1978 open
->form
->value
.character
.string
,
1983 /* Checks on the PAD specifier. */
1984 if (open
->pad
&& open
->pad
->expr_type
== EXPR_CONSTANT
)
1986 static const char *pad
[] = { "YES", "NO", NULL
};
1988 if (!compare_to_allowed_values ("PAD", pad
, NULL
, NULL
,
1989 open
->pad
->value
.character
.string
,
1994 /* Checks on the POSITION specifier. */
1995 if (open
->position
&& open
->position
->expr_type
== EXPR_CONSTANT
)
1997 static const char *position
[] = { "ASIS", "REWIND", "APPEND", NULL
};
1999 if (!compare_to_allowed_values ("POSITION", position
, NULL
, NULL
,
2000 open
->position
->value
.character
.string
,
2005 /* Checks on the ROUND specifier. */
2008 if (!gfc_notify_std (GFC_STD_F2003
, "ROUND= at %C "
2009 "not allowed in Fortran 95"))
2012 if (open
->round
->expr_type
== EXPR_CONSTANT
)
2014 static const char * round
[] = { "UP", "DOWN", "ZERO", "NEAREST",
2015 "COMPATIBLE", "PROCESSOR_DEFINED",
2018 if (!compare_to_allowed_values ("ROUND", round
, NULL
, NULL
,
2019 open
->round
->value
.character
.string
,
2025 /* Checks on the SIGN specifier. */
2028 if (!gfc_notify_std (GFC_STD_F2003
, "SIGN= at %C "
2029 "not allowed in Fortran 95"))
2032 if (open
->sign
->expr_type
== EXPR_CONSTANT
)
2034 static const char * sign
[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
2037 if (!compare_to_allowed_values ("SIGN", sign
, NULL
, NULL
,
2038 open
->sign
->value
.character
.string
,
2044 #define warn_or_error(...) \
2047 gfc_warning (__VA_ARGS__); \
2050 gfc_error (__VA_ARGS__); \
2055 /* Checks on the RECL specifier. */
2056 if (open
->recl
&& open
->recl
->expr_type
== EXPR_CONSTANT
2057 && open
->recl
->ts
.type
== BT_INTEGER
2058 && mpz_sgn (open
->recl
->value
.integer
) != 1)
2060 warn_or_error ("RECL in OPEN statement at %C must be positive");
2063 /* Checks on the STATUS specifier. */
2064 if (open
->status
&& open
->status
->expr_type
== EXPR_CONSTANT
)
2066 static const char *status
[] = { "OLD", "NEW", "SCRATCH",
2067 "REPLACE", "UNKNOWN", NULL
};
2069 if (!compare_to_allowed_values ("STATUS", status
, NULL
, NULL
,
2070 open
->status
->value
.character
.string
,
2074 /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2075 the FILE= specifier shall appear. */
2076 if (open
->file
== NULL
2077 && (gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2079 || gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2082 char *s
= gfc_widechar_to_char (open
->status
->value
.character
.string
,
2084 warn_or_error ("The STATUS specified in OPEN statement at %C is "
2085 "'%s' and no FILE specifier is present", s
);
2089 /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2090 the FILE= specifier shall not appear. */
2091 if (gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2092 "scratch", 7) == 0 && open
->file
)
2094 warn_or_error ("The STATUS specified in OPEN statement at %C "
2095 "cannot have the value SCRATCH if a FILE specifier "
2100 /* Things that are not allowed for unformatted I/O. */
2101 if (open
->form
&& open
->form
->expr_type
== EXPR_CONSTANT
2102 && (open
->delim
|| open
->decimal
|| open
->encoding
|| open
->round
2103 || open
->sign
|| open
->pad
|| open
->blank
)
2104 && gfc_wide_strncasecmp (open
->form
->value
.character
.string
,
2105 "unformatted", 11) == 0)
2107 const char *spec
= (open
->delim
? "DELIM "
2108 : (open
->pad
? "PAD " : open
->blank
2111 warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
2112 "unformatted I/O", spec
);
2115 if (open
->recl
&& open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
2116 && gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2119 warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
2124 && open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
2125 && !(gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2126 "sequential", 10) == 0
2127 || gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2129 || gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2132 warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
2133 "for stream or sequential ACCESS");
2136 #undef warn_or_error
2138 new_st
.op
= EXEC_OPEN
;
2139 new_st
.ext
.open
= open
;
2143 gfc_syntax_error (ST_OPEN
);
2146 gfc_free_open (open
);
2151 /* Free a gfc_close structure an all its expressions. */
2154 gfc_free_close (gfc_close
*close
)
2159 gfc_free_expr (close
->unit
);
2160 gfc_free_expr (close
->iomsg
);
2161 gfc_free_expr (close
->iostat
);
2162 gfc_free_expr (close
->status
);
2167 /* Match elements of a CLOSE statement. */
2170 match_close_element (gfc_close
*close
)
2174 m
= match_etag (&tag_unit
, &close
->unit
);
2177 m
= match_etag (&tag_status
, &close
->status
);
2180 m
= match_out_tag (&tag_iomsg
, &close
->iomsg
);
2183 m
= match_out_tag (&tag_iostat
, &close
->iostat
);
2186 m
= match_ltag (&tag_err
, &close
->err
);
2194 /* Match a CLOSE statement. */
2197 gfc_match_close (void)
2203 m
= gfc_match_char ('(');
2207 close
= XCNEW (gfc_close
);
2209 m
= match_close_element (close
);
2211 if (m
== MATCH_ERROR
)
2215 m
= gfc_match_expr (&close
->unit
);
2218 if (m
== MATCH_ERROR
)
2224 if (gfc_match_char (')') == MATCH_YES
)
2226 if (gfc_match_char (',') != MATCH_YES
)
2229 m
= match_close_element (close
);
2230 if (m
== MATCH_ERROR
)
2236 if (gfc_match_eos () == MATCH_NO
)
2239 if (gfc_pure (NULL
))
2241 gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2245 gfc_unset_implicit_pure (NULL
);
2247 warn
= (close
->iostat
|| close
->err
) ? true : false;
2249 /* Checks on the STATUS specifier. */
2250 if (close
->status
&& close
->status
->expr_type
== EXPR_CONSTANT
)
2252 static const char *status
[] = { "KEEP", "DELETE", NULL
};
2254 if (!compare_to_allowed_values ("STATUS", status
, NULL
, NULL
,
2255 close
->status
->value
.character
.string
,
2260 new_st
.op
= EXEC_CLOSE
;
2261 new_st
.ext
.close
= close
;
2265 gfc_syntax_error (ST_CLOSE
);
2268 gfc_free_close (close
);
2273 /* Resolve everything in a gfc_close structure. */
2276 gfc_resolve_close (gfc_close
*close
)
2278 RESOLVE_TAG (&tag_unit
, close
->unit
);
2279 RESOLVE_TAG (&tag_iomsg
, close
->iomsg
);
2280 RESOLVE_TAG (&tag_iostat
, close
->iostat
);
2281 RESOLVE_TAG (&tag_status
, close
->status
);
2283 if (!gfc_reference_st_label (close
->err
, ST_LABEL_TARGET
))
2286 if (close
->unit
== NULL
)
2288 /* Find a locus from one of the arguments to close, when UNIT is
2290 locus loc
= gfc_current_locus
;
2292 loc
= close
->status
->where
;
2293 else if (close
->iostat
)
2294 loc
= close
->iostat
->where
;
2295 else if (close
->iomsg
)
2296 loc
= close
->iomsg
->where
;
2297 else if (close
->err
)
2298 loc
= close
->err
->where
;
2300 gfc_error ("CLOSE statement at %L requires a UNIT number", &loc
);
2304 if (close
->unit
->expr_type
== EXPR_CONSTANT
2305 && close
->unit
->ts
.type
== BT_INTEGER
2306 && mpz_sgn (close
->unit
->value
.integer
) < 0)
2308 gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2309 &close
->unit
->where
);
2316 /* Free a gfc_filepos structure. */
2319 gfc_free_filepos (gfc_filepos
*fp
)
2321 gfc_free_expr (fp
->unit
);
2322 gfc_free_expr (fp
->iomsg
);
2323 gfc_free_expr (fp
->iostat
);
2328 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
2331 match_file_element (gfc_filepos
*fp
)
2335 m
= match_etag (&tag_unit
, &fp
->unit
);
2338 m
= match_out_tag (&tag_iomsg
, &fp
->iomsg
);
2341 m
= match_out_tag (&tag_iostat
, &fp
->iostat
);
2344 m
= match_ltag (&tag_err
, &fp
->err
);
2352 /* Match the second half of the file-positioning statements, REWIND,
2353 BACKSPACE, ENDFILE, or the FLUSH statement. */
2356 match_filepos (gfc_statement st
, gfc_exec_op op
)
2361 fp
= XCNEW (gfc_filepos
);
2363 if (gfc_match_char ('(') == MATCH_NO
)
2365 m
= gfc_match_expr (&fp
->unit
);
2366 if (m
== MATCH_ERROR
)
2374 m
= match_file_element (fp
);
2375 if (m
== MATCH_ERROR
)
2379 m
= gfc_match_expr (&fp
->unit
);
2380 if (m
== MATCH_ERROR
)
2388 if (gfc_match_char (')') == MATCH_YES
)
2390 if (gfc_match_char (',') != MATCH_YES
)
2393 m
= match_file_element (fp
);
2394 if (m
== MATCH_ERROR
)
2401 if (gfc_match_eos () != MATCH_YES
)
2404 if (gfc_pure (NULL
))
2406 gfc_error ("%s statement not allowed in PURE procedure at %C",
2407 gfc_ascii_statement (st
));
2412 gfc_unset_implicit_pure (NULL
);
2415 new_st
.ext
.filepos
= fp
;
2419 gfc_syntax_error (st
);
2422 gfc_free_filepos (fp
);
2428 gfc_resolve_filepos (gfc_filepos
*fp
)
2430 RESOLVE_TAG (&tag_unit
, fp
->unit
);
2431 RESOLVE_TAG (&tag_iostat
, fp
->iostat
);
2432 RESOLVE_TAG (&tag_iomsg
, fp
->iomsg
);
2433 if (!gfc_reference_st_label (fp
->err
, ST_LABEL_TARGET
))
2436 if (fp
->unit
->expr_type
== EXPR_CONSTANT
2437 && fp
->unit
->ts
.type
== BT_INTEGER
2438 && mpz_sgn (fp
->unit
->value
.integer
) < 0)
2440 gfc_error ("UNIT number in statement at %L must be non-negative",
2448 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2449 and the FLUSH statement. */
2452 gfc_match_endfile (void)
2454 return match_filepos (ST_END_FILE
, EXEC_ENDFILE
);
2458 gfc_match_backspace (void)
2460 return match_filepos (ST_BACKSPACE
, EXEC_BACKSPACE
);
2464 gfc_match_rewind (void)
2466 return match_filepos (ST_REWIND
, EXEC_REWIND
);
2470 gfc_match_flush (void)
2472 if (!gfc_notify_std (GFC_STD_F2003
, "FLUSH statement at %C"))
2475 return match_filepos (ST_FLUSH
, EXEC_FLUSH
);
2478 /******************** Data Transfer Statements *********************/
2480 /* Return a default unit number. */
2483 default_unit (io_kind k
)
2492 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, unit
);
2496 /* Match a unit specification for a data transfer statement. */
2499 match_dt_unit (io_kind k
, gfc_dt
*dt
)
2503 if (gfc_match_char ('*') == MATCH_YES
)
2505 if (dt
->io_unit
!= NULL
)
2508 dt
->io_unit
= default_unit (k
);
2512 if (gfc_match_expr (&e
) == MATCH_YES
)
2514 if (dt
->io_unit
!= NULL
)
2527 gfc_error ("Duplicate UNIT specification at %C");
2532 /* Match a format specification. */
2535 match_dt_format (gfc_dt
*dt
)
2539 gfc_st_label
*label
;
2542 where
= gfc_current_locus
;
2544 if (gfc_match_char ('*') == MATCH_YES
)
2546 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2549 dt
->format_label
= &format_asterisk
;
2553 if ((m
= gfc_match_st_label (&label
)) == MATCH_YES
)
2557 /* Need to check if the format label is actually either an operand
2558 to a user-defined operator or is a kind type parameter. That is,
2559 print 2.ip.8 ! .ip. is a user-defined operator return CHARACTER.
2560 print 1_'(I0)', i ! 1_'(I0)' is a default character string. */
2562 gfc_gobble_whitespace ();
2563 c
= gfc_peek_ascii_char ();
2564 if (c
== '.' || c
== '_')
2565 gfc_current_locus
= where
;
2568 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2570 gfc_free_st_label (label
);
2574 if (!gfc_reference_st_label (label
, ST_LABEL_FORMAT
))
2577 dt
->format_label
= label
;
2581 else if (m
== MATCH_ERROR
)
2582 /* The label was zero or too large. Emit the correct diagnosis. */
2585 if (gfc_match_expr (&e
) == MATCH_YES
)
2587 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2592 dt
->format_expr
= e
;
2596 gfc_current_locus
= where
; /* The only case where we have to restore */
2601 gfc_error ("Duplicate format specification at %C");
2606 /* Traverse a namelist that is part of a READ statement to make sure
2607 that none of the variables in the namelist are INTENT(IN). Returns
2608 nonzero if we find such a variable. */
2611 check_namelist (gfc_symbol
*sym
)
2615 for (p
= sym
->namelist
; p
; p
= p
->next
)
2616 if (p
->sym
->attr
.intent
== INTENT_IN
)
2618 gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
2619 p
->sym
->name
, sym
->name
);
2627 /* Match a single data transfer element. */
2630 match_dt_element (io_kind k
, gfc_dt
*dt
)
2632 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2636 if (gfc_match (" unit =") == MATCH_YES
)
2638 m
= match_dt_unit (k
, dt
);
2643 if (gfc_match (" fmt =") == MATCH_YES
)
2645 m
= match_dt_format (dt
);
2650 if (gfc_match (" nml = %n", name
) == MATCH_YES
)
2652 if (dt
->namelist
!= NULL
)
2654 gfc_error ("Duplicate NML specification at %C");
2658 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
2661 if (sym
== NULL
|| sym
->attr
.flavor
!= FL_NAMELIST
)
2663 gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
2664 sym
!= NULL
? sym
->name
: name
);
2669 if (k
== M_READ
&& check_namelist (sym
))
2675 m
= match_etag (&tag_e_async
, &dt
->asynchronous
);
2678 m
= match_etag (&tag_e_blank
, &dt
->blank
);
2681 m
= match_etag (&tag_e_delim
, &dt
->delim
);
2684 m
= match_etag (&tag_e_pad
, &dt
->pad
);
2687 m
= match_etag (&tag_e_sign
, &dt
->sign
);
2690 m
= match_etag (&tag_e_round
, &dt
->round
);
2693 m
= match_out_tag (&tag_id
, &dt
->id
);
2696 m
= match_etag (&tag_e_decimal
, &dt
->decimal
);
2699 m
= match_etag (&tag_rec
, &dt
->rec
);
2702 m
= match_etag (&tag_spos
, &dt
->pos
);
2705 m
= match_out_tag (&tag_iomsg
, &dt
->iomsg
);
2708 m
= match_out_tag (&tag_iostat
, &dt
->iostat
);
2711 m
= match_ltag (&tag_err
, &dt
->err
);
2713 dt
->err_where
= gfc_current_locus
;
2716 m
= match_etag (&tag_advance
, &dt
->advance
);
2719 m
= match_out_tag (&tag_size
, &dt
->size
);
2723 m
= match_ltag (&tag_end
, &dt
->end
);
2728 gfc_error ("END tag at %C not allowed in output statement");
2731 dt
->end_where
= gfc_current_locus
;
2736 m
= match_ltag (&tag_eor
, &dt
->eor
);
2738 dt
->eor_where
= gfc_current_locus
;
2746 /* Free a data transfer structure and everything below it. */
2749 gfc_free_dt (gfc_dt
*dt
)
2754 gfc_free_expr (dt
->io_unit
);
2755 gfc_free_expr (dt
->format_expr
);
2756 gfc_free_expr (dt
->rec
);
2757 gfc_free_expr (dt
->advance
);
2758 gfc_free_expr (dt
->iomsg
);
2759 gfc_free_expr (dt
->iostat
);
2760 gfc_free_expr (dt
->size
);
2761 gfc_free_expr (dt
->pad
);
2762 gfc_free_expr (dt
->delim
);
2763 gfc_free_expr (dt
->sign
);
2764 gfc_free_expr (dt
->round
);
2765 gfc_free_expr (dt
->blank
);
2766 gfc_free_expr (dt
->decimal
);
2767 gfc_free_expr (dt
->pos
);
2768 gfc_free_expr (dt
->dt_io_kind
);
2769 /* dt->extra_comma is a link to dt_io_kind if it is set. */
2774 /* Resolve everything in a gfc_dt structure. */
2777 gfc_resolve_dt (gfc_dt
*dt
, locus
*loc
)
2782 /* This is set in any case. */
2783 gcc_assert (dt
->dt_io_kind
);
2784 k
= dt
->dt_io_kind
->value
.iokind
;
2786 RESOLVE_TAG (&tag_format
, dt
->format_expr
);
2787 RESOLVE_TAG (&tag_rec
, dt
->rec
);
2788 RESOLVE_TAG (&tag_spos
, dt
->pos
);
2789 RESOLVE_TAG (&tag_advance
, dt
->advance
);
2790 RESOLVE_TAG (&tag_id
, dt
->id
);
2791 RESOLVE_TAG (&tag_iomsg
, dt
->iomsg
);
2792 RESOLVE_TAG (&tag_iostat
, dt
->iostat
);
2793 RESOLVE_TAG (&tag_size
, dt
->size
);
2794 RESOLVE_TAG (&tag_e_pad
, dt
->pad
);
2795 RESOLVE_TAG (&tag_e_delim
, dt
->delim
);
2796 RESOLVE_TAG (&tag_e_sign
, dt
->sign
);
2797 RESOLVE_TAG (&tag_e_round
, dt
->round
);
2798 RESOLVE_TAG (&tag_e_blank
, dt
->blank
);
2799 RESOLVE_TAG (&tag_e_decimal
, dt
->decimal
);
2800 RESOLVE_TAG (&tag_e_async
, dt
->asynchronous
);
2805 gfc_error ("UNIT not specified at %L", loc
);
2809 if (gfc_resolve_expr (e
)
2810 && (e
->ts
.type
!= BT_INTEGER
2811 && (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_VARIABLE
)))
2813 /* If there is no extra comma signifying the "format" form of the IO
2814 statement, then this must be an error. */
2815 if (!dt
->extra_comma
)
2817 gfc_error ("UNIT specification at %L must be an INTEGER expression "
2818 "or a CHARACTER variable", &e
->where
);
2823 /* At this point, we have an extra comma. If io_unit has arrived as
2824 type character, we assume its really the "format" form of the I/O
2825 statement. We set the io_unit to the default unit and format to
2826 the character expression. See F95 Standard section 9.4. */
2827 if (e
->ts
.type
== BT_CHARACTER
&& (k
== M_READ
|| k
== M_PRINT
))
2829 dt
->format_expr
= dt
->io_unit
;
2830 dt
->io_unit
= default_unit (k
);
2832 /* Nullify this pointer now so that a warning/error is not
2833 triggered below for the "Extension". */
2834 dt
->extra_comma
= NULL
;
2839 gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
2840 &dt
->extra_comma
->where
);
2846 if (e
->ts
.type
== BT_CHARACTER
)
2848 if (gfc_has_vector_index (e
))
2850 gfc_error ("Internal unit with vector subscript at %L", &e
->where
);
2854 /* If we are writing, make sure the internal unit can be changed. */
2855 gcc_assert (k
!= M_PRINT
);
2857 && !gfc_check_vardef_context (e
, false, false, false,
2858 _("internal unit in WRITE")))
2862 if (e
->rank
&& e
->ts
.type
!= BT_CHARACTER
)
2864 gfc_error ("External IO UNIT cannot be an array at %L", &e
->where
);
2868 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_INTEGER
2869 && mpz_sgn (e
->value
.integer
) < 0)
2871 gfc_error ("UNIT number in statement at %L must be non-negative",
2876 /* If we are reading and have a namelist, check that all namelist symbols
2877 can appear in a variable definition context. */
2878 if (k
== M_READ
&& dt
->namelist
)
2881 for (n
= dt
->namelist
->namelist
; n
; n
= n
->next
)
2886 e
= gfc_get_variable_expr (gfc_find_sym_in_symtree (n
->sym
));
2887 t
= gfc_check_vardef_context (e
, false, false, false, NULL
);
2892 gfc_error ("NAMELIST '%s' in READ statement at %L contains"
2893 " the symbol '%s' which may not appear in a"
2894 " variable definition context",
2895 dt
->namelist
->name
, loc
, n
->sym
->name
);
2902 && !gfc_notify_std (GFC_STD_GNU
, "Comma before i/o item list at %L",
2903 &dt
->extra_comma
->where
))
2908 if (!gfc_reference_st_label (dt
->err
, ST_LABEL_TARGET
))
2910 if (dt
->err
->defined
== ST_LABEL_UNKNOWN
)
2912 gfc_error ("ERR tag label %d at %L not defined",
2913 dt
->err
->value
, &dt
->err_where
);
2920 if (!gfc_reference_st_label (dt
->end
, ST_LABEL_TARGET
))
2922 if (dt
->end
->defined
== ST_LABEL_UNKNOWN
)
2924 gfc_error ("END tag label %d at %L not defined",
2925 dt
->end
->value
, &dt
->end_where
);
2932 if (!gfc_reference_st_label (dt
->eor
, ST_LABEL_TARGET
))
2934 if (dt
->eor
->defined
== ST_LABEL_UNKNOWN
)
2936 gfc_error ("EOR tag label %d at %L not defined",
2937 dt
->eor
->value
, &dt
->eor_where
);
2942 /* Check the format label actually exists. */
2943 if (dt
->format_label
&& dt
->format_label
!= &format_asterisk
2944 && dt
->format_label
->defined
== ST_LABEL_UNKNOWN
)
2946 gfc_error ("FORMAT label %d at %L not defined", dt
->format_label
->value
,
2947 &dt
->format_label
->where
);
2955 /* Given an io_kind, return its name. */
2958 io_kind_name (io_kind k
)
2977 gfc_internal_error ("io_kind_name(): bad I/O-kind");
2984 /* Match an IO iteration statement of the form:
2986 ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
2988 which is equivalent to a single IO element. This function is
2989 mutually recursive with match_io_element(). */
2991 static match
match_io_element (io_kind
, gfc_code
**);
2994 match_io_iterator (io_kind k
, gfc_code
**result
)
2996 gfc_code
*head
, *tail
, *new_code
;
3004 old_loc
= gfc_current_locus
;
3006 if (gfc_match_char ('(') != MATCH_YES
)
3009 m
= match_io_element (k
, &head
);
3012 if (m
!= MATCH_YES
|| gfc_match_char (',') != MATCH_YES
)
3018 /* Can't be anything but an IO iterator. Build a list. */
3019 iter
= gfc_get_iterator ();
3023 m
= gfc_match_iterator (iter
, 0);
3024 if (m
== MATCH_ERROR
)
3028 gfc_check_do_variable (iter
->var
->symtree
);
3032 m
= match_io_element (k
, &new_code
);
3033 if (m
== MATCH_ERROR
)
3042 tail
= gfc_append_code (tail
, new_code
);
3044 if (gfc_match_char (',') != MATCH_YES
)
3053 if (gfc_match_char (')') != MATCH_YES
)
3056 new_code
= gfc_get_code (EXEC_DO
);
3057 new_code
->ext
.iterator
= iter
;
3059 new_code
->block
= gfc_get_code (EXEC_DO
);
3060 new_code
->block
->next
= head
;
3066 gfc_error ("Syntax error in I/O iterator at %C");
3070 gfc_free_iterator (iter
, 1);
3071 gfc_free_statements (head
);
3072 gfc_current_locus
= old_loc
;
3077 /* Match a single element of an IO list, which is either a single
3078 expression or an IO Iterator. */
3081 match_io_element (io_kind k
, gfc_code
**cpp
)
3089 m
= match_io_iterator (k
, cpp
);
3095 m
= gfc_match_variable (&expr
, 0);
3097 gfc_error ("Expected variable in READ statement at %C");
3101 m
= gfc_match_expr (&expr
);
3103 gfc_error ("Expected expression in %s statement at %C",
3107 if (m
== MATCH_YES
&& k
== M_READ
&& gfc_check_do_variable (expr
->symtree
))
3112 gfc_free_expr (expr
);
3116 cp
= gfc_get_code (EXEC_TRANSFER
);
3119 cp
->ext
.dt
= current_dt
;
3126 /* Match an I/O list, building gfc_code structures as we go. */
3129 match_io_list (io_kind k
, gfc_code
**head_p
)
3131 gfc_code
*head
, *tail
, *new_code
;
3134 *head_p
= head
= tail
= NULL
;
3135 if (gfc_match_eos () == MATCH_YES
)
3140 m
= match_io_element (k
, &new_code
);
3141 if (m
== MATCH_ERROR
)
3146 tail
= gfc_append_code (tail
, new_code
);
3150 if (gfc_match_eos () == MATCH_YES
)
3152 if (gfc_match_char (',') != MATCH_YES
)
3160 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
3163 gfc_free_statements (head
);
3168 /* Attach the data transfer end node. */
3171 terminate_io (gfc_code
*io_code
)
3175 if (io_code
== NULL
)
3176 io_code
= new_st
.block
;
3178 c
= gfc_get_code (EXEC_DT_END
);
3180 /* Point to structure that is already there */
3181 c
->ext
.dt
= new_st
.ext
.dt
;
3182 gfc_append_code (io_code
, c
);
3186 /* Check the constraints for a data transfer statement. The majority of the
3187 constraints appearing in 9.4 of the standard appear here. Some are handled
3188 in resolve_tag and others in gfc_resolve_dt. */
3191 check_io_constraints (io_kind k
, gfc_dt
*dt
, gfc_code
*io_code
,
3194 #define io_constraint(condition,msg,arg)\
3197 gfc_error(msg,arg);\
3203 gfc_symbol
*sym
= NULL
;
3204 bool warn
, unformatted
;
3206 warn
= (dt
->err
|| dt
->iostat
) ? true : false;
3207 unformatted
= dt
->format_expr
== NULL
&& dt
->format_label
== NULL
3208 && dt
->namelist
== NULL
;
3213 if (expr
&& expr
->expr_type
== EXPR_VARIABLE
3214 && expr
->ts
.type
== BT_CHARACTER
)
3216 sym
= expr
->symtree
->n
.sym
;
3218 io_constraint (k
== M_WRITE
&& sym
->attr
.intent
== INTENT_IN
,
3219 "Internal file at %L must not be INTENT(IN)",
3222 io_constraint (gfc_has_vector_index (dt
->io_unit
),
3223 "Internal file incompatible with vector subscript at %L",
3226 io_constraint (dt
->rec
!= NULL
,
3227 "REC tag at %L is incompatible with internal file",
3230 io_constraint (dt
->pos
!= NULL
,
3231 "POS tag at %L is incompatible with internal file",
3234 io_constraint (unformatted
,
3235 "Unformatted I/O not allowed with internal unit at %L",
3236 &dt
->io_unit
->where
);
3238 io_constraint (dt
->asynchronous
!= NULL
,
3239 "ASYNCHRONOUS tag at %L not allowed with internal file",
3240 &dt
->asynchronous
->where
);
3242 if (dt
->namelist
!= NULL
)
3244 if (!gfc_notify_std (GFC_STD_F2003
, "Internal file at %L with "
3245 "namelist", &expr
->where
))
3249 io_constraint (dt
->advance
!= NULL
,
3250 "ADVANCE tag at %L is incompatible with internal file",
3251 &dt
->advance
->where
);
3254 if (expr
&& expr
->ts
.type
!= BT_CHARACTER
)
3257 io_constraint (gfc_pure (NULL
) && (k
== M_READ
|| k
== M_WRITE
),
3258 "IO UNIT in %s statement at %C must be "
3259 "an internal file in a PURE procedure",
3262 if (k
== M_READ
|| k
== M_WRITE
)
3263 gfc_unset_implicit_pure (NULL
);
3268 io_constraint (dt
->end
, "END tag not allowed with output at %L",
3271 io_constraint (dt
->eor
, "EOR tag not allowed with output at %L",
3274 io_constraint (dt
->blank
, "BLANK= specifier not allowed with output at %L",
3277 io_constraint (dt
->pad
, "PAD= specifier not allowed with output at %L",
3280 io_constraint (dt
->size
, "SIZE= specifier not allowed with output at %L",
3285 io_constraint (dt
->size
&& dt
->advance
== NULL
,
3286 "SIZE tag at %L requires an ADVANCE tag",
3289 io_constraint (dt
->eor
&& dt
->advance
== NULL
,
3290 "EOR tag at %L requires an ADVANCE tag",
3294 if (dt
->asynchronous
)
3296 static const char * asynchronous
[] = { "YES", "NO", NULL
};
3298 if (!gfc_reduce_init_expr (dt
->asynchronous
))
3300 gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3301 "expression", &dt
->asynchronous
->where
);
3305 if (!compare_to_allowed_values
3306 ("ASYNCHRONOUS", asynchronous
, NULL
, NULL
,
3307 dt
->asynchronous
->value
.character
.string
,
3308 io_kind_name (k
), warn
))
3316 || gfc_wide_strlen (dt
->asynchronous
->value
.character
.string
) != 3
3317 || gfc_wide_strncasecmp (dt
->asynchronous
->value
.character
.string
,
3319 io_constraint (not_yes
,
3320 "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3321 "specifier", &dt
->id
->where
);
3326 if (!gfc_notify_std (GFC_STD_F2003
, "DECIMAL= at %C "
3327 "not allowed in Fortran 95"))
3330 if (dt
->decimal
->expr_type
== EXPR_CONSTANT
)
3332 static const char * decimal
[] = { "COMMA", "POINT", NULL
};
3334 if (!compare_to_allowed_values ("DECIMAL", decimal
, NULL
, NULL
,
3335 dt
->decimal
->value
.character
.string
,
3336 io_kind_name (k
), warn
))
3339 io_constraint (unformatted
,
3340 "the DECIMAL= specifier at %L must be with an "
3341 "explicit format expression", &dt
->decimal
->where
);
3347 if (!gfc_notify_std (GFC_STD_F2003
, "BLANK= at %C "
3348 "not allowed in Fortran 95"))
3351 if (dt
->blank
->expr_type
== EXPR_CONSTANT
)
3353 static const char * blank
[] = { "NULL", "ZERO", NULL
};
3355 if (!compare_to_allowed_values ("BLANK", blank
, NULL
, NULL
,
3356 dt
->blank
->value
.character
.string
,
3357 io_kind_name (k
), warn
))
3360 io_constraint (unformatted
,
3361 "the BLANK= specifier at %L must be with an "
3362 "explicit format expression", &dt
->blank
->where
);
3368 if (!gfc_notify_std (GFC_STD_F2003
, "PAD= at %C "
3369 "not allowed in Fortran 95"))
3372 if (dt
->pad
->expr_type
== EXPR_CONSTANT
)
3374 static const char * pad
[] = { "YES", "NO", NULL
};
3376 if (!compare_to_allowed_values ("PAD", pad
, NULL
, NULL
,
3377 dt
->pad
->value
.character
.string
,
3378 io_kind_name (k
), warn
))
3381 io_constraint (unformatted
,
3382 "the PAD= specifier at %L must be with an "
3383 "explicit format expression", &dt
->pad
->where
);
3389 if (!gfc_notify_std (GFC_STD_F2003
, "ROUND= at %C "
3390 "not allowed in Fortran 95"))
3393 if (dt
->round
->expr_type
== EXPR_CONSTANT
)
3395 static const char * round
[] = { "UP", "DOWN", "ZERO", "NEAREST",
3396 "COMPATIBLE", "PROCESSOR_DEFINED",
3399 if (!compare_to_allowed_values ("ROUND", round
, NULL
, NULL
,
3400 dt
->round
->value
.character
.string
,
3401 io_kind_name (k
), warn
))
3408 /* When implemented, change the following to use gfc_notify_std F2003.
3409 if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C "
3410 "not allowed in Fortran 95") == false)
3411 return MATCH_ERROR; */
3412 if (dt
->sign
->expr_type
== EXPR_CONSTANT
)
3414 static const char * sign
[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3417 if (!compare_to_allowed_values ("SIGN", sign
, NULL
, NULL
,
3418 dt
->sign
->value
.character
.string
,
3419 io_kind_name (k
), warn
))
3422 io_constraint (unformatted
,
3423 "SIGN= specifier at %L must be with an "
3424 "explicit format expression", &dt
->sign
->where
);
3426 io_constraint (k
== M_READ
,
3427 "SIGN= specifier at %L not allowed in a "
3428 "READ statement", &dt
->sign
->where
);
3434 if (!gfc_notify_std (GFC_STD_F2003
, "DELIM= at %C "
3435 "not allowed in Fortran 95"))
3438 if (dt
->delim
->expr_type
== EXPR_CONSTANT
)
3440 static const char *delim
[] = { "APOSTROPHE", "QUOTE", "NONE", NULL
};
3442 if (!compare_to_allowed_values ("DELIM", delim
, NULL
, NULL
,
3443 dt
->delim
->value
.character
.string
,
3444 io_kind_name (k
), warn
))
3447 io_constraint (k
== M_READ
,
3448 "DELIM= specifier at %L not allowed in a "
3449 "READ statement", &dt
->delim
->where
);
3451 io_constraint (dt
->format_label
!= &format_asterisk
3452 && dt
->namelist
== NULL
,
3453 "DELIM= specifier at %L must have FMT=*",
3456 io_constraint (unformatted
&& dt
->namelist
== NULL
,
3457 "DELIM= specifier at %L must be with FMT=* or "
3458 "NML= specifier ", &dt
->delim
->where
);
3464 io_constraint (io_code
&& dt
->namelist
,
3465 "NAMELIST cannot be followed by IO-list at %L",
3468 io_constraint (dt
->format_expr
,
3469 "IO spec-list cannot contain both NAMELIST group name "
3470 "and format specification at %L",
3471 &dt
->format_expr
->where
);
3473 io_constraint (dt
->format_label
,
3474 "IO spec-list cannot contain both NAMELIST group name "
3475 "and format label at %L", spec_end
);
3477 io_constraint (dt
->rec
,
3478 "NAMELIST IO is not allowed with a REC= specifier "
3479 "at %L", &dt
->rec
->where
);
3481 io_constraint (dt
->advance
,
3482 "NAMELIST IO is not allowed with a ADVANCE= specifier "
3483 "at %L", &dt
->advance
->where
);
3488 io_constraint (dt
->end
,
3489 "An END tag is not allowed with a "
3490 "REC= specifier at %L", &dt
->end_where
);
3492 io_constraint (dt
->format_label
== &format_asterisk
,
3493 "FMT=* is not allowed with a REC= specifier "
3496 io_constraint (dt
->pos
,
3497 "POS= is not allowed with REC= specifier "
3498 "at %L", &dt
->pos
->where
);
3503 int not_yes
, not_no
;
3506 io_constraint (dt
->format_label
== &format_asterisk
,
3507 "List directed format(*) is not allowed with a "
3508 "ADVANCE= specifier at %L.", &expr
->where
);
3510 io_constraint (unformatted
,
3511 "the ADVANCE= specifier at %L must appear with an "
3512 "explicit format expression", &expr
->where
);
3514 if (expr
->expr_type
== EXPR_CONSTANT
&& expr
->ts
.type
== BT_CHARACTER
)
3516 const gfc_char_t
*advance
= expr
->value
.character
.string
;
3517 not_no
= gfc_wide_strlen (advance
) != 2
3518 || gfc_wide_strncasecmp (advance
, "no", 2) != 0;
3519 not_yes
= gfc_wide_strlen (advance
) != 3
3520 || gfc_wide_strncasecmp (advance
, "yes", 3) != 0;
3528 io_constraint (not_no
&& not_yes
,
3529 "ADVANCE= specifier at %L must have value = "
3530 "YES or NO.", &expr
->where
);
3532 io_constraint (dt
->size
&& not_no
&& k
== M_READ
,
3533 "SIZE tag at %L requires an ADVANCE = 'NO'",
3536 io_constraint (dt
->eor
&& not_no
&& k
== M_READ
,
3537 "EOR tag at %L requires an ADVANCE = 'NO'",
3541 expr
= dt
->format_expr
;
3542 if (!gfc_simplify_expr (expr
, 0)
3543 || !check_format_string (expr
, k
== M_READ
))
3548 #undef io_constraint
3551 /* Match a READ, WRITE or PRINT statement. */
3554 match_io (io_kind k
)
3556 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3565 where
= gfc_current_locus
;
3567 current_dt
= dt
= XCNEW (gfc_dt
);
3568 m
= gfc_match_char ('(');
3571 where
= gfc_current_locus
;
3574 else if (k
== M_PRINT
)
3576 /* Treat the non-standard case of PRINT namelist. */
3577 if ((gfc_current_form
== FORM_FIXED
|| gfc_peek_ascii_char () == ' ')
3578 && gfc_match_name (name
) == MATCH_YES
)
3580 gfc_find_symbol (name
, NULL
, 1, &sym
);
3581 if (sym
&& sym
->attr
.flavor
== FL_NAMELIST
)
3583 if (!gfc_notify_std (GFC_STD_GNU
, "PRINT namelist at "
3584 "%C is an extension"))
3590 dt
->io_unit
= default_unit (k
);
3595 gfc_current_locus
= where
;
3599 if (gfc_current_form
== FORM_FREE
)
3601 char c
= gfc_peek_ascii_char ();
3602 if (c
!= ' ' && c
!= '*' && c
!= '\'' && c
!= '"')
3609 m
= match_dt_format (dt
);
3610 if (m
== MATCH_ERROR
)
3616 dt
->io_unit
= default_unit (k
);
3621 /* Before issuing an error for a malformed 'print (1,*)' type of
3622 error, check for a default-char-expr of the form ('(I0)'). */
3623 if (k
== M_PRINT
&& m
== MATCH_YES
)
3625 /* Reset current locus to get the initial '(' in an expression. */
3626 gfc_current_locus
= where
;
3627 dt
->format_expr
= NULL
;
3628 m
= match_dt_format (dt
);
3630 if (m
== MATCH_ERROR
)
3632 if (m
== MATCH_NO
|| dt
->format_expr
== NULL
)
3636 dt
->io_unit
= default_unit (k
);
3641 /* Match a control list */
3642 if (match_dt_element (k
, dt
) == MATCH_YES
)
3644 if (match_dt_unit (k
, dt
) != MATCH_YES
)
3647 if (gfc_match_char (')') == MATCH_YES
)
3649 if (gfc_match_char (',') != MATCH_YES
)
3652 m
= match_dt_element (k
, dt
);
3655 if (m
== MATCH_ERROR
)
3658 m
= match_dt_format (dt
);
3661 if (m
== MATCH_ERROR
)
3664 where
= gfc_current_locus
;
3666 m
= gfc_match_name (name
);
3669 gfc_find_symbol (name
, NULL
, 1, &sym
);
3670 if (sym
&& sym
->attr
.flavor
== FL_NAMELIST
)
3673 if (k
== M_READ
&& check_namelist (sym
))
3682 gfc_current_locus
= where
;
3684 goto loop
; /* No matches, try regular elements */
3687 if (gfc_match_char (')') == MATCH_YES
)
3689 if (gfc_match_char (',') != MATCH_YES
)
3695 m
= match_dt_element (k
, dt
);
3698 if (m
== MATCH_ERROR
)
3701 if (gfc_match_char (')') == MATCH_YES
)
3703 if (gfc_match_char (',') != MATCH_YES
)
3709 /* Used in check_io_constraints, where no locus is available. */
3710 spec_end
= gfc_current_locus
;
3712 /* Save the IO kind for later use. */
3713 dt
->dt_io_kind
= gfc_get_iokind_expr (&gfc_current_locus
, k
);
3715 /* Optional leading comma (non-standard). We use a gfc_expr structure here
3716 to save the locus. This is used later when resolving transfer statements
3717 that might have a format expression without unit number. */
3718 if (!comma_flag
&& gfc_match_char (',') == MATCH_YES
)
3719 dt
->extra_comma
= dt
->dt_io_kind
;
3722 if (gfc_match_eos () != MATCH_YES
)
3724 if (comma_flag
&& gfc_match_char (',') != MATCH_YES
)
3726 gfc_error ("Expected comma in I/O list at %C");
3731 m
= match_io_list (k
, &io_code
);
3732 if (m
== MATCH_ERROR
)
3738 /* A full IO statement has been matched. Check the constraints. spec_end is
3739 supplied for cases where no locus is supplied. */
3740 m
= check_io_constraints (k
, dt
, io_code
, &spec_end
);
3742 if (m
== MATCH_ERROR
)
3745 new_st
.op
= (k
== M_READ
) ? EXEC_READ
: EXEC_WRITE
;
3747 new_st
.block
= gfc_get_code (new_st
.op
);
3748 new_st
.block
->next
= io_code
;
3750 terminate_io (io_code
);
3755 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
3765 gfc_match_read (void)
3767 return match_io (M_READ
);
3772 gfc_match_write (void)
3774 return match_io (M_WRITE
);
3779 gfc_match_print (void)
3783 m
= match_io (M_PRINT
);
3787 if (gfc_pure (NULL
))
3789 gfc_error ("PRINT statement at %C not allowed within PURE procedure");
3793 gfc_unset_implicit_pure (NULL
);
3799 /* Free a gfc_inquire structure. */
3802 gfc_free_inquire (gfc_inquire
*inquire
)
3805 if (inquire
== NULL
)
3808 gfc_free_expr (inquire
->unit
);
3809 gfc_free_expr (inquire
->file
);
3810 gfc_free_expr (inquire
->iomsg
);
3811 gfc_free_expr (inquire
->iostat
);
3812 gfc_free_expr (inquire
->exist
);
3813 gfc_free_expr (inquire
->opened
);
3814 gfc_free_expr (inquire
->number
);
3815 gfc_free_expr (inquire
->named
);
3816 gfc_free_expr (inquire
->name
);
3817 gfc_free_expr (inquire
->access
);
3818 gfc_free_expr (inquire
->sequential
);
3819 gfc_free_expr (inquire
->direct
);
3820 gfc_free_expr (inquire
->form
);
3821 gfc_free_expr (inquire
->formatted
);
3822 gfc_free_expr (inquire
->unformatted
);
3823 gfc_free_expr (inquire
->recl
);
3824 gfc_free_expr (inquire
->nextrec
);
3825 gfc_free_expr (inquire
->blank
);
3826 gfc_free_expr (inquire
->position
);
3827 gfc_free_expr (inquire
->action
);
3828 gfc_free_expr (inquire
->read
);
3829 gfc_free_expr (inquire
->write
);
3830 gfc_free_expr (inquire
->readwrite
);
3831 gfc_free_expr (inquire
->delim
);
3832 gfc_free_expr (inquire
->encoding
);
3833 gfc_free_expr (inquire
->pad
);
3834 gfc_free_expr (inquire
->iolength
);
3835 gfc_free_expr (inquire
->convert
);
3836 gfc_free_expr (inquire
->strm_pos
);
3837 gfc_free_expr (inquire
->asynchronous
);
3838 gfc_free_expr (inquire
->decimal
);
3839 gfc_free_expr (inquire
->pending
);
3840 gfc_free_expr (inquire
->id
);
3841 gfc_free_expr (inquire
->sign
);
3842 gfc_free_expr (inquire
->size
);
3843 gfc_free_expr (inquire
->round
);
3848 /* Match an element of an INQUIRE statement. */
3850 #define RETM if (m != MATCH_NO) return m;
3853 match_inquire_element (gfc_inquire
*inquire
)
3857 m
= match_etag (&tag_unit
, &inquire
->unit
);
3858 RETM m
= match_etag (&tag_file
, &inquire
->file
);
3859 RETM m
= match_ltag (&tag_err
, &inquire
->err
);
3860 RETM m
= match_out_tag (&tag_iomsg
, &inquire
->iomsg
);
3861 RETM m
= match_out_tag (&tag_iostat
, &inquire
->iostat
);
3862 RETM m
= match_vtag (&tag_exist
, &inquire
->exist
);
3863 RETM m
= match_vtag (&tag_opened
, &inquire
->opened
);
3864 RETM m
= match_vtag (&tag_named
, &inquire
->named
);
3865 RETM m
= match_vtag (&tag_name
, &inquire
->name
);
3866 RETM m
= match_out_tag (&tag_number
, &inquire
->number
);
3867 RETM m
= match_vtag (&tag_s_access
, &inquire
->access
);
3868 RETM m
= match_vtag (&tag_sequential
, &inquire
->sequential
);
3869 RETM m
= match_vtag (&tag_direct
, &inquire
->direct
);
3870 RETM m
= match_vtag (&tag_s_form
, &inquire
->form
);
3871 RETM m
= match_vtag (&tag_formatted
, &inquire
->formatted
);
3872 RETM m
= match_vtag (&tag_unformatted
, &inquire
->unformatted
);
3873 RETM m
= match_out_tag (&tag_s_recl
, &inquire
->recl
);
3874 RETM m
= match_out_tag (&tag_nextrec
, &inquire
->nextrec
);
3875 RETM m
= match_vtag (&tag_s_blank
, &inquire
->blank
);
3876 RETM m
= match_vtag (&tag_s_position
, &inquire
->position
);
3877 RETM m
= match_vtag (&tag_s_action
, &inquire
->action
);
3878 RETM m
= match_vtag (&tag_read
, &inquire
->read
);
3879 RETM m
= match_vtag (&tag_write
, &inquire
->write
);
3880 RETM m
= match_vtag (&tag_readwrite
, &inquire
->readwrite
);
3881 RETM m
= match_vtag (&tag_s_async
, &inquire
->asynchronous
);
3882 RETM m
= match_vtag (&tag_s_delim
, &inquire
->delim
);
3883 RETM m
= match_vtag (&tag_s_decimal
, &inquire
->decimal
);
3884 RETM m
= match_out_tag (&tag_size
, &inquire
->size
);
3885 RETM m
= match_vtag (&tag_s_encoding
, &inquire
->encoding
);
3886 RETM m
= match_vtag (&tag_s_round
, &inquire
->round
);
3887 RETM m
= match_vtag (&tag_s_sign
, &inquire
->sign
);
3888 RETM m
= match_vtag (&tag_s_pad
, &inquire
->pad
);
3889 RETM m
= match_out_tag (&tag_iolength
, &inquire
->iolength
);
3890 RETM m
= match_vtag (&tag_convert
, &inquire
->convert
);
3891 RETM m
= match_out_tag (&tag_strm_out
, &inquire
->strm_pos
);
3892 RETM m
= match_vtag (&tag_pending
, &inquire
->pending
);
3893 RETM m
= match_vtag (&tag_id
, &inquire
->id
);
3894 RETM m
= match_vtag (&tag_s_iqstream
, &inquire
->iqstream
);
3895 RETM
return MATCH_NO
;
3902 gfc_match_inquire (void)
3904 gfc_inquire
*inquire
;
3909 m
= gfc_match_char ('(');
3913 inquire
= XCNEW (gfc_inquire
);
3915 loc
= gfc_current_locus
;
3917 m
= match_inquire_element (inquire
);
3918 if (m
== MATCH_ERROR
)
3922 m
= gfc_match_expr (&inquire
->unit
);
3923 if (m
== MATCH_ERROR
)
3929 /* See if we have the IOLENGTH form of the inquire statement. */
3930 if (inquire
->iolength
!= NULL
)
3932 if (gfc_match_char (')') != MATCH_YES
)
3935 m
= match_io_list (M_INQUIRE
, &code
);
3936 if (m
== MATCH_ERROR
)
3941 new_st
.op
= EXEC_IOLENGTH
;
3942 new_st
.expr1
= inquire
->iolength
;
3943 new_st
.ext
.inquire
= inquire
;
3945 if (gfc_pure (NULL
))
3947 gfc_free_statements (code
);
3948 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3952 gfc_unset_implicit_pure (NULL
);
3954 new_st
.block
= gfc_get_code (EXEC_IOLENGTH
);
3955 terminate_io (code
);
3956 new_st
.block
->next
= code
;
3960 /* At this point, we have the non-IOLENGTH inquire statement. */
3963 if (gfc_match_char (')') == MATCH_YES
)
3965 if (gfc_match_char (',') != MATCH_YES
)
3968 m
= match_inquire_element (inquire
);
3969 if (m
== MATCH_ERROR
)
3974 if (inquire
->iolength
!= NULL
)
3976 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
3981 if (gfc_match_eos () != MATCH_YES
)
3984 if (inquire
->unit
!= NULL
&& inquire
->file
!= NULL
)
3986 gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
3987 "UNIT specifiers", &loc
);
3991 if (inquire
->unit
== NULL
&& inquire
->file
== NULL
)
3993 gfc_error ("INQUIRE statement at %L requires either FILE or "
3994 "UNIT specifier", &loc
);
3998 if (gfc_pure (NULL
))
4000 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4004 gfc_unset_implicit_pure (NULL
);
4006 if (inquire
->id
!= NULL
&& inquire
->pending
== NULL
)
4008 gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
4009 "the ID= specifier", &loc
);
4013 new_st
.op
= EXEC_INQUIRE
;
4014 new_st
.ext
.inquire
= inquire
;
4018 gfc_syntax_error (ST_INQUIRE
);
4021 gfc_free_inquire (inquire
);
4026 /* Resolve everything in a gfc_inquire structure. */
4029 gfc_resolve_inquire (gfc_inquire
*inquire
)
4031 RESOLVE_TAG (&tag_unit
, inquire
->unit
);
4032 RESOLVE_TAG (&tag_file
, inquire
->file
);
4033 RESOLVE_TAG (&tag_id
, inquire
->id
);
4035 /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4036 contexts. Thus, use an extended RESOLVE_TAG macro for that. */
4037 #define INQUIRE_RESOLVE_TAG(tag, expr) \
4038 RESOLVE_TAG (tag, expr); \
4042 sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
4043 if (gfc_check_vardef_context ((expr), false, false, false, \
4044 context) == false) \
4047 INQUIRE_RESOLVE_TAG (&tag_iomsg
, inquire
->iomsg
);
4048 INQUIRE_RESOLVE_TAG (&tag_iostat
, inquire
->iostat
);
4049 INQUIRE_RESOLVE_TAG (&tag_exist
, inquire
->exist
);
4050 INQUIRE_RESOLVE_TAG (&tag_opened
, inquire
->opened
);
4051 INQUIRE_RESOLVE_TAG (&tag_number
, inquire
->number
);
4052 INQUIRE_RESOLVE_TAG (&tag_named
, inquire
->named
);
4053 INQUIRE_RESOLVE_TAG (&tag_name
, inquire
->name
);
4054 INQUIRE_RESOLVE_TAG (&tag_s_access
, inquire
->access
);
4055 INQUIRE_RESOLVE_TAG (&tag_sequential
, inquire
->sequential
);
4056 INQUIRE_RESOLVE_TAG (&tag_direct
, inquire
->direct
);
4057 INQUIRE_RESOLVE_TAG (&tag_s_form
, inquire
->form
);
4058 INQUIRE_RESOLVE_TAG (&tag_formatted
, inquire
->formatted
);
4059 INQUIRE_RESOLVE_TAG (&tag_unformatted
, inquire
->unformatted
);
4060 INQUIRE_RESOLVE_TAG (&tag_s_recl
, inquire
->recl
);
4061 INQUIRE_RESOLVE_TAG (&tag_nextrec
, inquire
->nextrec
);
4062 INQUIRE_RESOLVE_TAG (&tag_s_blank
, inquire
->blank
);
4063 INQUIRE_RESOLVE_TAG (&tag_s_position
, inquire
->position
);
4064 INQUIRE_RESOLVE_TAG (&tag_s_action
, inquire
->action
);
4065 INQUIRE_RESOLVE_TAG (&tag_read
, inquire
->read
);
4066 INQUIRE_RESOLVE_TAG (&tag_write
, inquire
->write
);
4067 INQUIRE_RESOLVE_TAG (&tag_readwrite
, inquire
->readwrite
);
4068 INQUIRE_RESOLVE_TAG (&tag_s_delim
, inquire
->delim
);
4069 INQUIRE_RESOLVE_TAG (&tag_s_pad
, inquire
->pad
);
4070 INQUIRE_RESOLVE_TAG (&tag_s_encoding
, inquire
->encoding
);
4071 INQUIRE_RESOLVE_TAG (&tag_s_round
, inquire
->round
);
4072 INQUIRE_RESOLVE_TAG (&tag_iolength
, inquire
->iolength
);
4073 INQUIRE_RESOLVE_TAG (&tag_convert
, inquire
->convert
);
4074 INQUIRE_RESOLVE_TAG (&tag_strm_out
, inquire
->strm_pos
);
4075 INQUIRE_RESOLVE_TAG (&tag_s_async
, inquire
->asynchronous
);
4076 INQUIRE_RESOLVE_TAG (&tag_s_sign
, inquire
->sign
);
4077 INQUIRE_RESOLVE_TAG (&tag_s_round
, inquire
->round
);
4078 INQUIRE_RESOLVE_TAG (&tag_pending
, inquire
->pending
);
4079 INQUIRE_RESOLVE_TAG (&tag_size
, inquire
->size
);
4080 INQUIRE_RESOLVE_TAG (&tag_s_decimal
, inquire
->decimal
);
4081 INQUIRE_RESOLVE_TAG (&tag_s_iqstream
, inquire
->iqstream
);
4082 #undef INQUIRE_RESOLVE_TAG
4084 if (!gfc_reference_st_label (inquire
->err
, ST_LABEL_TARGET
))
4092 gfc_free_wait (gfc_wait
*wait
)
4097 gfc_free_expr (wait
->unit
);
4098 gfc_free_expr (wait
->iostat
);
4099 gfc_free_expr (wait
->iomsg
);
4100 gfc_free_expr (wait
->id
);
4106 gfc_resolve_wait (gfc_wait
*wait
)
4108 RESOLVE_TAG (&tag_unit
, wait
->unit
);
4109 RESOLVE_TAG (&tag_iomsg
, wait
->iomsg
);
4110 RESOLVE_TAG (&tag_iostat
, wait
->iostat
);
4111 RESOLVE_TAG (&tag_id
, wait
->id
);
4113 if (!gfc_reference_st_label (wait
->err
, ST_LABEL_TARGET
))
4116 if (!gfc_reference_st_label (wait
->end
, ST_LABEL_TARGET
))
4122 /* Match an element of a WAIT statement. */
4124 #define RETM if (m != MATCH_NO) return m;
4127 match_wait_element (gfc_wait
*wait
)
4131 m
= match_etag (&tag_unit
, &wait
->unit
);
4132 RETM m
= match_ltag (&tag_err
, &wait
->err
);
4133 RETM m
= match_ltag (&tag_end
, &wait
->eor
);
4134 RETM m
= match_ltag (&tag_eor
, &wait
->end
);
4135 RETM m
= match_out_tag (&tag_iomsg
, &wait
->iomsg
);
4136 RETM m
= match_out_tag (&tag_iostat
, &wait
->iostat
);
4137 RETM m
= match_etag (&tag_id
, &wait
->id
);
4138 RETM
return MATCH_NO
;
4145 gfc_match_wait (void)
4150 m
= gfc_match_char ('(');
4154 wait
= XCNEW (gfc_wait
);
4156 m
= match_wait_element (wait
);
4157 if (m
== MATCH_ERROR
)
4161 m
= gfc_match_expr (&wait
->unit
);
4162 if (m
== MATCH_ERROR
)
4170 if (gfc_match_char (')') == MATCH_YES
)
4172 if (gfc_match_char (',') != MATCH_YES
)
4175 m
= match_wait_element (wait
);
4176 if (m
== MATCH_ERROR
)
4182 if (!gfc_notify_std (GFC_STD_F2003
, "WAIT at %C "
4183 "not allowed in Fortran 95"))
4186 if (gfc_pure (NULL
))
4188 gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4192 gfc_unset_implicit_pure (NULL
);
4194 new_st
.op
= EXEC_WAIT
;
4195 new_st
.ext
.wait
= wait
;
4200 gfc_syntax_error (ST_WAIT
);
4203 gfc_free_wait (wait
);