1 /* Deal with I/O statements & related stuff.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
31 format_asterisk
= {0, NULL
, NULL
, -1, ST_LABEL_FORMAT
, ST_LABEL_FORMAT
, NULL
,
36 const char *name
, *spec
, *value
;
42 tag_file
= {"FILE", " file =", " %e", BT_CHARACTER
},
43 tag_status
= {"STATUS", " status =", " %e", BT_CHARACTER
},
44 tag_e_access
= {"ACCESS", " access =", " %e", BT_CHARACTER
},
45 tag_e_form
= {"FORM", " form =", " %e", BT_CHARACTER
},
46 tag_e_recl
= {"RECL", " recl =", " %e", BT_INTEGER
},
47 tag_e_blank
= {"BLANK", " blank =", " %e", BT_CHARACTER
},
48 tag_e_position
= {"POSITION", " position =", " %e", BT_CHARACTER
},
49 tag_e_action
= {"ACTION", " action =", " %e", BT_CHARACTER
},
50 tag_e_delim
= {"DELIM", " delim =", " %e", BT_CHARACTER
},
51 tag_e_pad
= {"PAD", " pad =", " %e", BT_CHARACTER
},
52 tag_e_decimal
= {"DECIMAL", " decimal =", " %e", BT_CHARACTER
},
53 tag_e_encoding
= {"ENCODING", " encoding =", " %e", BT_CHARACTER
},
54 tag_e_async
= {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER
},
55 tag_e_round
= {"ROUND", " round =", " %e", BT_CHARACTER
},
56 tag_e_sign
= {"SIGN", " sign =", " %e", BT_CHARACTER
},
57 tag_unit
= {"UNIT", " unit =", " %e", BT_INTEGER
},
58 tag_advance
= {"ADVANCE", " advance =", " %e", BT_CHARACTER
},
59 tag_rec
= {"REC", " rec =", " %e", BT_INTEGER
},
60 tag_spos
= {"POSITION", " pos =", " %e", BT_INTEGER
},
61 tag_format
= {"FORMAT", NULL
, NULL
, BT_CHARACTER
},
62 tag_iomsg
= {"IOMSG", " iomsg =", " %e", BT_CHARACTER
},
63 tag_iostat
= {"IOSTAT", " iostat =", " %v", BT_INTEGER
},
64 tag_size
= {"SIZE", " size =", " %v", BT_INTEGER
},
65 tag_exist
= {"EXIST", " exist =", " %v", BT_LOGICAL
},
66 tag_opened
= {"OPENED", " opened =", " %v", BT_LOGICAL
},
67 tag_named
= {"NAMED", " named =", " %v", BT_LOGICAL
},
68 tag_name
= {"NAME", " name =", " %v", BT_CHARACTER
},
69 tag_number
= {"NUMBER", " number =", " %v", BT_INTEGER
},
70 tag_s_access
= {"ACCESS", " access =", " %v", BT_CHARACTER
},
71 tag_sequential
= {"SEQUENTIAL", " sequential =", " %v", BT_CHARACTER
},
72 tag_direct
= {"DIRECT", " direct =", " %v", BT_CHARACTER
},
73 tag_s_form
= {"FORM", " form =", " %v", BT_CHARACTER
},
74 tag_formatted
= {"FORMATTED", " formatted =", " %v", BT_CHARACTER
},
75 tag_unformatted
= {"UNFORMATTED", " unformatted =", " %v", BT_CHARACTER
},
76 tag_s_recl
= {"RECL", " recl =", " %v", BT_INTEGER
},
77 tag_nextrec
= {"NEXTREC", " nextrec =", " %v", BT_INTEGER
},
78 tag_s_blank
= {"BLANK", " blank =", " %v", BT_CHARACTER
},
79 tag_s_position
= {"POSITION", " position =", " %v", BT_CHARACTER
},
80 tag_s_action
= {"ACTION", " action =", " %v", BT_CHARACTER
},
81 tag_read
= {"READ", " read =", " %v", BT_CHARACTER
},
82 tag_write
= {"WRITE", " write =", " %v", BT_CHARACTER
},
83 tag_readwrite
= {"READWRITE", " readwrite =", " %v", BT_CHARACTER
},
84 tag_s_delim
= {"DELIM", " delim =", " %v", BT_CHARACTER
},
85 tag_s_pad
= {"PAD", " pad =", " %v", BT_CHARACTER
},
86 tag_s_decimal
= {"DECIMAL", " decimal =", " %v", BT_CHARACTER
},
87 tag_s_encoding
= {"ENCODING", " encoding =", " %v", BT_CHARACTER
},
88 tag_s_async
= {"ASYNCHRONOUS", " asynchronous =", " %v", BT_CHARACTER
},
89 tag_s_round
= {"ROUND", " round =", " %v", BT_CHARACTER
},
90 tag_s_sign
= {"SIGN", " sign =", " %v", BT_CHARACTER
},
91 tag_iolength
= {"IOLENGTH", " iolength =", " %v", BT_INTEGER
},
92 tag_convert
= {"CONVERT", " convert =", " %e", BT_CHARACTER
},
93 tag_strm_out
= {"POS", " pos =", " %v", BT_INTEGER
},
94 tag_err
= {"ERR", " err =", " %l", BT_UNKNOWN
},
95 tag_end
= {"END", " end =", " %l", BT_UNKNOWN
},
96 tag_eor
= {"EOR", " eor =", " %l", BT_UNKNOWN
},
97 tag_id
= {"ID", " id =", " %v", BT_INTEGER
},
98 tag_pending
= {"PENDING", " pending =", " %v", BT_LOGICAL
},
99 tag_newunit
= {"NEWUNIT", " newunit =", " %v", BT_INTEGER
};
101 static gfc_dt
*current_dt
;
103 #define RESOLVE_TAG(x, y) if (resolve_tag(x, y) == FAILURE) return FAILURE;
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
);
246 c
= next_char_not_space (&error
);
257 c
= next_char_not_space (&error
);
259 value
= 10 * value
+ c
- '0';
268 token
= FMT_SIGNED_INT
;
287 c
= next_char_not_space (&error
);
290 value
= 10 * value
+ c
- '0';
298 token
= zflag
? FMT_ZERO
: FMT_POSINT
;
322 c
= next_char_not_space (&error
);
350 c
= next_char_not_space (&error
);
351 if (c
!= 'P' && c
!= 'S')
358 c
= next_char_not_space (&error
);
359 if (c
== 'N' || c
== 'Z')
377 c
= next_char (INSTRING_WARN
);
386 c
= next_char (INSTRING_NOWARN
);
420 c
= next_char_not_space (&error
);
450 c
= next_char_not_space (&error
);
453 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: DP format "
454 "specifier not allowed at %C") == FAILURE
)
460 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: DC format "
461 "specifier not allowed at %C") == FAILURE
)
473 c
= next_char_not_space (&error
);
522 token_to_string (format_token t
)
541 /* Check a format statement. The format string, either from a FORMAT
542 statement or a constant in an I/O statement has already been parsed
543 by itself, and we are checking it for validity. The dual origin
544 means that the warning message is a little less than great. */
547 check_format (bool is_input
)
549 const char *posint_required
= _("Positive width required");
550 const char *nonneg_required
= _("Nonnegative width required");
551 const char *unexpected_element
= _("Unexpected element '%c' in format string"
553 const char *unexpected_end
= _("Unexpected end of format string");
554 const char *zero_width
= _("Zero width in format descriptor");
563 saved_token
= FMT_NONE
;
567 format_string_pos
= 0;
574 error
= _("Missing leading left parenthesis");
582 goto finished
; /* Empty format is legal */
586 /* In this state, the next thing has to be a format item. */
603 error
= _("Left parenthesis required after '*'");
628 /* Signed integer can only precede a P format. */
634 error
= _("Expected P edit descriptor");
641 /* P requires a prior number. */
642 error
= _("P descriptor requires leading scale factor");
646 /* X requires a prior number if we're being pedantic. */
647 if (mode
!= MODE_FORMAT
)
648 format_locus
.nextc
+= format_string_pos
;
649 if (gfc_notify_std (GFC_STD_GNU
, "Extension: X descriptor "
650 "requires leading space count at %L", &format_locus
)
668 goto extension_optional_comma
;
679 if (gfc_notify_std (GFC_STD_GNU
, "Extension: $ descriptor at %L",
680 &format_locus
) == FAILURE
)
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
, "Fortran 2008: 'G0' in "
827 "format at %L", &format_locus
) == FAILURE
)
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
, "Extension: Missing comma at %L",
1060 &format_locus
) == FAILURE
)
1062 /* If we do not actually return a failure, we need to unwind this
1063 before the next round. */
1064 if (mode
!= MODE_FORMAT
)
1065 format_locus
.nextc
-= format_string_pos
;
1070 /* Optional comma is a weird between state where we've just finished
1071 reading a colon, slash, dollar or P descriptor. */
1088 /* Assume that we have another format item. */
1095 extension_optional_comma
:
1096 /* As a GNU extension, permit a missing comma after a string literal. */
1113 goto optional_comma
;
1116 error
= unexpected_end
;
1120 if (mode
!= MODE_FORMAT
)
1121 format_locus
.nextc
+= format_string_pos
;
1122 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Missing comma at %L",
1123 &format_locus
) == FAILURE
)
1125 /* If we do not actually return a failure, we need to unwind this
1126 before the next round. */
1127 if (mode
!= MODE_FORMAT
)
1128 format_locus
.nextc
-= format_string_pos
;
1136 if (mode
!= MODE_FORMAT
)
1137 format_locus
.nextc
+= format_string_pos
;
1138 if (error
== unexpected_element
)
1139 gfc_error (error
, error_element
, &format_locus
);
1141 gfc_error ("%s in format string at %L", error
, &format_locus
);
1150 /* Given an expression node that is a constant string, see if it looks
1151 like a format string. */
1154 check_format_string (gfc_expr
*e
, bool is_input
)
1158 if (!e
|| e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1162 format_string
= e
->value
.character
.string
;
1164 /* More elaborate measures are needed to show where a problem is within a
1165 format string that has been calculated, but that's probably not worth the
1167 format_locus
= e
->where
;
1168 rv
= check_format (is_input
);
1169 /* check for extraneous characters at the end of an otherwise valid format
1170 string, like '(A10,I3)F5'
1171 start at the end and move back to the last character processed,
1173 if (rv
== SUCCESS
&& e
->value
.character
.length
> format_string_pos
)
1174 for (i
=e
->value
.character
.length
-1;i
>format_string_pos
-1;i
--)
1175 if (e
->value
.character
.string
[i
] != ' ')
1177 format_locus
.nextc
+= format_length
+ 1;
1178 gfc_warning ("Extraneous characters in format at %L", &format_locus
);
1185 /************ Fortran 95 I/O statement matchers *************/
1187 /* Match a FORMAT statement. This amounts to actually parsing the
1188 format descriptors in order to correctly locate the end of the
1192 gfc_match_format (void)
1197 if (gfc_current_ns
->proc_name
1198 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1200 gfc_error ("Format statement in module main block at %C");
1204 if (gfc_statement_label
== NULL
)
1206 gfc_error ("Missing format label at %C");
1209 gfc_gobble_whitespace ();
1214 start
= gfc_current_locus
;
1216 if (check_format (false) == FAILURE
)
1219 if (gfc_match_eos () != MATCH_YES
)
1221 gfc_syntax_error (ST_FORMAT
);
1225 /* The label doesn't get created until after the statement is done
1226 being matched, so we have to leave the string for later. */
1228 gfc_current_locus
= start
; /* Back to the beginning */
1231 new_st
.op
= EXEC_NOP
;
1233 e
= gfc_get_character_expr (gfc_default_character_kind
, &start
,
1234 NULL
, format_length
);
1235 format_string
= e
->value
.character
.string
;
1236 gfc_statement_label
->format
= e
;
1239 check_format (false); /* Guaranteed to succeed */
1240 gfc_match_eos (); /* Guaranteed to succeed */
1246 /* Match an expression I/O tag of some sort. */
1249 match_etag (const io_tag
*tag
, gfc_expr
**v
)
1254 m
= gfc_match (tag
->spec
);
1258 m
= gfc_match (tag
->value
, &result
);
1261 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1267 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1268 gfc_free_expr (result
);
1277 /* Match a variable I/O tag of some sort. */
1280 match_vtag (const io_tag
*tag
, gfc_expr
**v
)
1285 m
= gfc_match (tag
->spec
);
1289 m
= gfc_match (tag
->value
, &result
);
1292 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1298 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1299 gfc_free_expr (result
);
1303 if (result
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1305 gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag
->name
);
1306 gfc_free_expr (result
);
1310 if (gfc_pure (NULL
) && gfc_impure_variable (result
->symtree
->n
.sym
))
1312 gfc_error ("Variable %s cannot be assigned in PURE procedure at %C",
1314 gfc_free_expr (result
);
1318 if (gfc_implicit_pure (NULL
) && gfc_impure_variable (result
->symtree
->n
.sym
))
1319 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1326 /* Match I/O tags that cause variables to become redefined. */
1329 match_out_tag (const io_tag
*tag
, gfc_expr
**result
)
1333 m
= match_vtag (tag
, result
);
1335 gfc_check_do_variable ((*result
)->symtree
);
1341 /* Match a label I/O tag. */
1344 match_ltag (const io_tag
*tag
, gfc_st_label
** label
)
1350 m
= gfc_match (tag
->spec
);
1354 m
= gfc_match (tag
->value
, label
);
1357 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1363 gfc_error ("Duplicate %s label specification at %C", tag
->name
);
1367 if (gfc_reference_st_label (*label
, ST_LABEL_TARGET
) == FAILURE
)
1374 /* Resolution of the FORMAT tag, to be called from resolve_tag. */
1377 resolve_tag_format (const gfc_expr
*e
)
1379 if (e
->expr_type
== EXPR_CONSTANT
1380 && (e
->ts
.type
!= BT_CHARACTER
1381 || e
->ts
.kind
!= gfc_default_character_kind
))
1383 gfc_error ("Constant expression in FORMAT tag at %L must be "
1384 "of type default CHARACTER", &e
->where
);
1388 /* If e's rank is zero and e is not an element of an array, it should be
1389 of integer or character type. The integer variable should be
1392 && (e
->expr_type
!= EXPR_VARIABLE
1393 || e
->symtree
== NULL
1394 || e
->symtree
->n
.sym
->as
== NULL
1395 || e
->symtree
->n
.sym
->as
->rank
== 0))
1397 if (e
->ts
.type
!= BT_CHARACTER
&& e
->ts
.type
!= BT_INTEGER
)
1399 gfc_error ("FORMAT tag at %L must be of type CHARACTER or INTEGER",
1403 else if (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_VARIABLE
)
1405 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: ASSIGNED "
1406 "variable in 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
, "Extension: Non-character "
1431 "in FORMAT tag at %L", &e
->where
) == FAILURE
)
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
) == FAILURE
)
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
));
1483 gfc_error ("%s tag at %L must be scalar", tag
->name
, &e
->where
);
1487 if (tag
== &tag_iomsg
)
1489 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: IOMSG tag at %L",
1490 &e
->where
) == FAILURE
)
1494 if ((tag
== &tag_iostat
|| tag
== &tag_size
|| tag
== &tag_iolength
)
1495 && e
->ts
.kind
!= gfc_default_integer_kind
)
1497 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 95 requires default "
1498 "INTEGER in %s tag at %L", tag
->name
, &e
->where
)
1503 if (tag
== &tag_exist
&& e
->ts
.kind
!= gfc_default_logical_kind
)
1505 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Nondefault LOGICAL "
1506 "in %s tag at %L", tag
->name
, &e
->where
)
1511 if (tag
== &tag_newunit
)
1513 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: NEWUNIT specifier"
1514 " at %L", &e
->where
) == FAILURE
)
1518 /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */
1519 if (tag
== &tag_newunit
|| tag
== &tag_iostat
1520 || tag
== &tag_size
|| tag
== &tag_iomsg
)
1524 sprintf (context
, _("%s tag"), tag
->name
);
1525 if (gfc_check_vardef_context (e
, false, context
) == FAILURE
)
1529 if (tag
== &tag_convert
)
1531 if (gfc_notify_std (GFC_STD_GNU
, "Extension: CONVERT tag at %L",
1532 &e
->where
) == FAILURE
)
1540 /* Match a single tag of an OPEN statement. */
1543 match_open_element (gfc_open
*open
)
1547 m
= match_etag (&tag_e_async
, &open
->asynchronous
);
1550 m
= match_etag (&tag_unit
, &open
->unit
);
1553 m
= match_out_tag (&tag_iomsg
, &open
->iomsg
);
1556 m
= match_out_tag (&tag_iostat
, &open
->iostat
);
1559 m
= match_etag (&tag_file
, &open
->file
);
1562 m
= match_etag (&tag_status
, &open
->status
);
1565 m
= match_etag (&tag_e_access
, &open
->access
);
1568 m
= match_etag (&tag_e_form
, &open
->form
);
1571 m
= match_etag (&tag_e_recl
, &open
->recl
);
1574 m
= match_etag (&tag_e_blank
, &open
->blank
);
1577 m
= match_etag (&tag_e_position
, &open
->position
);
1580 m
= match_etag (&tag_e_action
, &open
->action
);
1583 m
= match_etag (&tag_e_delim
, &open
->delim
);
1586 m
= match_etag (&tag_e_pad
, &open
->pad
);
1589 m
= match_etag (&tag_e_decimal
, &open
->decimal
);
1592 m
= match_etag (&tag_e_encoding
, &open
->encoding
);
1595 m
= match_etag (&tag_e_round
, &open
->round
);
1598 m
= match_etag (&tag_e_sign
, &open
->sign
);
1601 m
= match_ltag (&tag_err
, &open
->err
);
1604 m
= match_etag (&tag_convert
, &open
->convert
);
1607 m
= match_out_tag (&tag_newunit
, &open
->newunit
);
1615 /* Free the gfc_open structure and all the expressions it contains. */
1618 gfc_free_open (gfc_open
*open
)
1623 gfc_free_expr (open
->unit
);
1624 gfc_free_expr (open
->iomsg
);
1625 gfc_free_expr (open
->iostat
);
1626 gfc_free_expr (open
->file
);
1627 gfc_free_expr (open
->status
);
1628 gfc_free_expr (open
->access
);
1629 gfc_free_expr (open
->form
);
1630 gfc_free_expr (open
->recl
);
1631 gfc_free_expr (open
->blank
);
1632 gfc_free_expr (open
->position
);
1633 gfc_free_expr (open
->action
);
1634 gfc_free_expr (open
->delim
);
1635 gfc_free_expr (open
->pad
);
1636 gfc_free_expr (open
->decimal
);
1637 gfc_free_expr (open
->encoding
);
1638 gfc_free_expr (open
->round
);
1639 gfc_free_expr (open
->sign
);
1640 gfc_free_expr (open
->convert
);
1641 gfc_free_expr (open
->asynchronous
);
1642 gfc_free_expr (open
->newunit
);
1647 /* Resolve everything in a gfc_open structure. */
1650 gfc_resolve_open (gfc_open
*open
)
1653 RESOLVE_TAG (&tag_unit
, open
->unit
);
1654 RESOLVE_TAG (&tag_iomsg
, open
->iomsg
);
1655 RESOLVE_TAG (&tag_iostat
, open
->iostat
);
1656 RESOLVE_TAG (&tag_file
, open
->file
);
1657 RESOLVE_TAG (&tag_status
, open
->status
);
1658 RESOLVE_TAG (&tag_e_access
, open
->access
);
1659 RESOLVE_TAG (&tag_e_form
, open
->form
);
1660 RESOLVE_TAG (&tag_e_recl
, open
->recl
);
1661 RESOLVE_TAG (&tag_e_blank
, open
->blank
);
1662 RESOLVE_TAG (&tag_e_position
, open
->position
);
1663 RESOLVE_TAG (&tag_e_action
, open
->action
);
1664 RESOLVE_TAG (&tag_e_delim
, open
->delim
);
1665 RESOLVE_TAG (&tag_e_pad
, open
->pad
);
1666 RESOLVE_TAG (&tag_e_decimal
, open
->decimal
);
1667 RESOLVE_TAG (&tag_e_encoding
, open
->encoding
);
1668 RESOLVE_TAG (&tag_e_async
, open
->asynchronous
);
1669 RESOLVE_TAG (&tag_e_round
, open
->round
);
1670 RESOLVE_TAG (&tag_e_sign
, open
->sign
);
1671 RESOLVE_TAG (&tag_convert
, open
->convert
);
1672 RESOLVE_TAG (&tag_newunit
, open
->newunit
);
1674 if (gfc_reference_st_label (open
->err
, ST_LABEL_TARGET
) == FAILURE
)
1681 /* Check if a given value for a SPECIFIER is either in the list of values
1682 allowed in F95 or F2003, issuing an error message and returning a zero
1683 value if it is not allowed. */
1686 compare_to_allowed_values (const char *specifier
, const char *allowed
[],
1687 const char *allowed_f2003
[],
1688 const char *allowed_gnu
[], gfc_char_t
*value
,
1689 const char *statement
, bool warn
)
1694 len
= gfc_wide_strlen (value
);
1697 for (len
--; len
> 0; len
--)
1698 if (value
[len
] != ' ')
1703 for (i
= 0; allowed
[i
]; i
++)
1704 if (len
== strlen (allowed
[i
])
1705 && gfc_wide_strncasecmp (value
, allowed
[i
], strlen (allowed
[i
])) == 0)
1708 for (i
= 0; allowed_f2003
&& allowed_f2003
[i
]; i
++)
1709 if (len
== strlen (allowed_f2003
[i
])
1710 && gfc_wide_strncasecmp (value
, allowed_f2003
[i
],
1711 strlen (allowed_f2003
[i
])) == 0)
1713 notification n
= gfc_notification_std (GFC_STD_F2003
);
1715 if (n
== WARNING
|| (warn
&& n
== ERROR
))
1717 gfc_warning ("Fortran 2003: %s specifier in %s statement at %C "
1718 "has value '%s'", specifier
, statement
,
1725 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: %s specifier in "
1726 "%s statement at %C has value '%s'", specifier
,
1727 statement
, allowed_f2003
[i
]);
1735 for (i
= 0; allowed_gnu
&& allowed_gnu
[i
]; i
++)
1736 if (len
== strlen (allowed_gnu
[i
])
1737 && gfc_wide_strncasecmp (value
, allowed_gnu
[i
],
1738 strlen (allowed_gnu
[i
])) == 0)
1740 notification n
= gfc_notification_std (GFC_STD_GNU
);
1742 if (n
== WARNING
|| (warn
&& n
== ERROR
))
1744 gfc_warning ("Extension: %s specifier in %s statement at %C "
1745 "has value '%s'", specifier
, statement
,
1752 gfc_notify_std (GFC_STD_GNU
, "Extension: %s specifier in "
1753 "%s statement at %C has value '%s'", specifier
,
1754 statement
, allowed_gnu
[i
]);
1764 char *s
= gfc_widechar_to_char (value
, -1);
1765 gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
1766 specifier
, statement
, s
);
1772 char *s
= gfc_widechar_to_char (value
, -1);
1773 gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
1774 specifier
, statement
, s
);
1781 /* Match an OPEN statement. */
1784 gfc_match_open (void)
1790 m
= gfc_match_char ('(');
1794 open
= XCNEW (gfc_open
);
1796 m
= match_open_element (open
);
1798 if (m
== MATCH_ERROR
)
1802 m
= gfc_match_expr (&open
->unit
);
1803 if (m
== MATCH_ERROR
)
1809 if (gfc_match_char (')') == MATCH_YES
)
1811 if (gfc_match_char (',') != MATCH_YES
)
1814 m
= match_open_element (open
);
1815 if (m
== MATCH_ERROR
)
1821 if (gfc_match_eos () == MATCH_NO
)
1824 if (gfc_pure (NULL
))
1826 gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1830 if (gfc_implicit_pure (NULL
))
1831 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1833 warn
= (open
->err
|| open
->iostat
) ? true : false;
1835 /* Checks on NEWUNIT specifier. */
1840 gfc_error ("UNIT specifier not allowed with NEWUNIT at %C");
1844 if (!(open
->file
|| (open
->status
1845 && gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
1846 "scratch", 7) == 0)))
1848 gfc_error ("NEWUNIT specifier must have FILE= "
1849 "or STATUS='scratch' at %C");
1853 else if (!open
->unit
)
1855 gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified");
1859 /* Checks on the ACCESS specifier. */
1860 if (open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
)
1862 static const char *access_f95
[] = { "SEQUENTIAL", "DIRECT", NULL
};
1863 static const char *access_f2003
[] = { "STREAM", NULL
};
1864 static const char *access_gnu
[] = { "APPEND", NULL
};
1866 if (!compare_to_allowed_values ("ACCESS", access_f95
, access_f2003
,
1868 open
->access
->value
.character
.string
,
1873 /* Checks on the ACTION specifier. */
1874 if (open
->action
&& open
->action
->expr_type
== EXPR_CONSTANT
)
1876 static const char *action
[] = { "READ", "WRITE", "READWRITE", NULL
};
1878 if (!compare_to_allowed_values ("ACTION", action
, NULL
, NULL
,
1879 open
->action
->value
.character
.string
,
1884 /* Checks on the ASYNCHRONOUS specifier. */
1885 if (open
->asynchronous
)
1887 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ASYNCHRONOUS= at %C "
1888 "not allowed in Fortran 95") == FAILURE
)
1891 if (open
->asynchronous
->expr_type
== EXPR_CONSTANT
)
1893 static const char * asynchronous
[] = { "YES", "NO", NULL
};
1895 if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous
,
1896 NULL
, NULL
, open
->asynchronous
->value
.character
.string
,
1902 /* Checks on the BLANK specifier. */
1905 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BLANK= at %C "
1906 "not allowed in Fortran 95") == FAILURE
)
1909 if (open
->blank
->expr_type
== EXPR_CONSTANT
)
1911 static const char *blank
[] = { "ZERO", "NULL", NULL
};
1913 if (!compare_to_allowed_values ("BLANK", blank
, NULL
, NULL
,
1914 open
->blank
->value
.character
.string
,
1920 /* Checks on the DECIMAL specifier. */
1923 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: DECIMAL= at %C "
1924 "not allowed in Fortran 95") == FAILURE
)
1927 if (open
->decimal
->expr_type
== EXPR_CONSTANT
)
1929 static const char * decimal
[] = { "COMMA", "POINT", NULL
};
1931 if (!compare_to_allowed_values ("DECIMAL", decimal
, NULL
, NULL
,
1932 open
->decimal
->value
.character
.string
,
1938 /* Checks on the DELIM specifier. */
1941 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: DELIM= at %C "
1942 "not allowed in Fortran 95") == FAILURE
)
1945 if (open
->delim
->expr_type
== EXPR_CONSTANT
)
1947 static const char *delim
[] = { "APOSTROPHE", "QUOTE", "NONE", NULL
};
1949 if (!compare_to_allowed_values ("DELIM", delim
, NULL
, NULL
,
1950 open
->delim
->value
.character
.string
,
1956 /* Checks on the ENCODING specifier. */
1959 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ENCODING= at %C "
1960 "not allowed in Fortran 95") == FAILURE
)
1963 if (open
->encoding
->expr_type
== EXPR_CONSTANT
)
1965 static const char * encoding
[] = { "DEFAULT", "UTF-8", NULL
};
1967 if (!compare_to_allowed_values ("ENCODING", encoding
, NULL
, NULL
,
1968 open
->encoding
->value
.character
.string
,
1974 /* Checks on the FORM specifier. */
1975 if (open
->form
&& open
->form
->expr_type
== EXPR_CONSTANT
)
1977 static const char *form
[] = { "FORMATTED", "UNFORMATTED", NULL
};
1979 if (!compare_to_allowed_values ("FORM", form
, NULL
, NULL
,
1980 open
->form
->value
.character
.string
,
1985 /* Checks on the PAD specifier. */
1986 if (open
->pad
&& open
->pad
->expr_type
== EXPR_CONSTANT
)
1988 static const char *pad
[] = { "YES", "NO", NULL
};
1990 if (!compare_to_allowed_values ("PAD", pad
, NULL
, NULL
,
1991 open
->pad
->value
.character
.string
,
1996 /* Checks on the POSITION specifier. */
1997 if (open
->position
&& open
->position
->expr_type
== EXPR_CONSTANT
)
1999 static const char *position
[] = { "ASIS", "REWIND", "APPEND", NULL
};
2001 if (!compare_to_allowed_values ("POSITION", position
, NULL
, NULL
,
2002 open
->position
->value
.character
.string
,
2007 /* Checks on the ROUND specifier. */
2010 if (gfc_notify_std (GFC_STD_F2003
, "Fortran F2003: ROUND= at %C "
2011 "not allowed in Fortran 95") == FAILURE
)
2014 if (open
->round
->expr_type
== EXPR_CONSTANT
)
2016 static const char * round
[] = { "UP", "DOWN", "ZERO", "NEAREST",
2017 "COMPATIBLE", "PROCESSOR_DEFINED",
2020 if (!compare_to_allowed_values ("ROUND", round
, NULL
, NULL
,
2021 open
->round
->value
.character
.string
,
2027 /* Checks on the SIGN specifier. */
2030 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: SIGN= at %C "
2031 "not allowed in Fortran 95") == FAILURE
)
2034 if (open
->sign
->expr_type
== EXPR_CONSTANT
)
2036 static const char * sign
[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
2039 if (!compare_to_allowed_values ("SIGN", sign
, NULL
, NULL
,
2040 open
->sign
->value
.character
.string
,
2046 #define warn_or_error(...) \
2049 gfc_warning (__VA_ARGS__); \
2052 gfc_error (__VA_ARGS__); \
2057 /* Checks on the RECL specifier. */
2058 if (open
->recl
&& open
->recl
->expr_type
== EXPR_CONSTANT
2059 && open
->recl
->ts
.type
== BT_INTEGER
2060 && mpz_sgn (open
->recl
->value
.integer
) != 1)
2062 warn_or_error ("RECL in OPEN statement at %C must be positive");
2065 /* Checks on the STATUS specifier. */
2066 if (open
->status
&& open
->status
->expr_type
== EXPR_CONSTANT
)
2068 static const char *status
[] = { "OLD", "NEW", "SCRATCH",
2069 "REPLACE", "UNKNOWN", NULL
};
2071 if (!compare_to_allowed_values ("STATUS", status
, NULL
, NULL
,
2072 open
->status
->value
.character
.string
,
2076 /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2077 the FILE= specifier shall appear. */
2078 if (open
->file
== NULL
2079 && (gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2081 || gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2084 char *s
= gfc_widechar_to_char (open
->status
->value
.character
.string
,
2086 warn_or_error ("The STATUS specified in OPEN statement at %C is "
2087 "'%s' and no FILE specifier is present", s
);
2091 /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2092 the FILE= specifier shall not appear. */
2093 if (gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2094 "scratch", 7) == 0 && open
->file
)
2096 warn_or_error ("The STATUS specified in OPEN statement at %C "
2097 "cannot have the value SCRATCH if a FILE specifier "
2102 /* Things that are not allowed for unformatted I/O. */
2103 if (open
->form
&& open
->form
->expr_type
== EXPR_CONSTANT
2104 && (open
->delim
|| open
->decimal
|| open
->encoding
|| open
->round
2105 || open
->sign
|| open
->pad
|| open
->blank
)
2106 && gfc_wide_strncasecmp (open
->form
->value
.character
.string
,
2107 "unformatted", 11) == 0)
2109 const char *spec
= (open
->delim
? "DELIM "
2110 : (open
->pad
? "PAD " : open
->blank
2113 warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
2114 "unformatted I/O", spec
);
2117 if (open
->recl
&& open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
2118 && gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2121 warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
2126 && open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
2127 && !(gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2128 "sequential", 10) == 0
2129 || gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2131 || gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2134 warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
2135 "for stream or sequential ACCESS");
2138 #undef warn_or_error
2140 new_st
.op
= EXEC_OPEN
;
2141 new_st
.ext
.open
= open
;
2145 gfc_syntax_error (ST_OPEN
);
2148 gfc_free_open (open
);
2153 /* Free a gfc_close structure an all its expressions. */
2156 gfc_free_close (gfc_close
*close
)
2161 gfc_free_expr (close
->unit
);
2162 gfc_free_expr (close
->iomsg
);
2163 gfc_free_expr (close
->iostat
);
2164 gfc_free_expr (close
->status
);
2169 /* Match elements of a CLOSE statement. */
2172 match_close_element (gfc_close
*close
)
2176 m
= match_etag (&tag_unit
, &close
->unit
);
2179 m
= match_etag (&tag_status
, &close
->status
);
2182 m
= match_out_tag (&tag_iomsg
, &close
->iomsg
);
2185 m
= match_out_tag (&tag_iostat
, &close
->iostat
);
2188 m
= match_ltag (&tag_err
, &close
->err
);
2196 /* Match a CLOSE statement. */
2199 gfc_match_close (void)
2205 m
= gfc_match_char ('(');
2209 close
= XCNEW (gfc_close
);
2211 m
= match_close_element (close
);
2213 if (m
== MATCH_ERROR
)
2217 m
= gfc_match_expr (&close
->unit
);
2220 if (m
== MATCH_ERROR
)
2226 if (gfc_match_char (')') == MATCH_YES
)
2228 if (gfc_match_char (',') != MATCH_YES
)
2231 m
= match_close_element (close
);
2232 if (m
== MATCH_ERROR
)
2238 if (gfc_match_eos () == MATCH_NO
)
2241 if (gfc_pure (NULL
))
2243 gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2247 if (gfc_implicit_pure (NULL
))
2248 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
2250 warn
= (close
->iostat
|| close
->err
) ? true : false;
2252 /* Checks on the STATUS specifier. */
2253 if (close
->status
&& close
->status
->expr_type
== EXPR_CONSTANT
)
2255 static const char *status
[] = { "KEEP", "DELETE", NULL
};
2257 if (!compare_to_allowed_values ("STATUS", status
, NULL
, NULL
,
2258 close
->status
->value
.character
.string
,
2263 new_st
.op
= EXEC_CLOSE
;
2264 new_st
.ext
.close
= close
;
2268 gfc_syntax_error (ST_CLOSE
);
2271 gfc_free_close (close
);
2276 /* Resolve everything in a gfc_close structure. */
2279 gfc_resolve_close (gfc_close
*close
)
2281 RESOLVE_TAG (&tag_unit
, close
->unit
);
2282 RESOLVE_TAG (&tag_iomsg
, close
->iomsg
);
2283 RESOLVE_TAG (&tag_iostat
, close
->iostat
);
2284 RESOLVE_TAG (&tag_status
, close
->status
);
2286 if (gfc_reference_st_label (close
->err
, ST_LABEL_TARGET
) == FAILURE
)
2289 if (close
->unit
->expr_type
== EXPR_CONSTANT
2290 && close
->unit
->ts
.type
== BT_INTEGER
2291 && mpz_sgn (close
->unit
->value
.integer
) < 0)
2293 gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2294 &close
->unit
->where
);
2301 /* Free a gfc_filepos structure. */
2304 gfc_free_filepos (gfc_filepos
*fp
)
2306 gfc_free_expr (fp
->unit
);
2307 gfc_free_expr (fp
->iomsg
);
2308 gfc_free_expr (fp
->iostat
);
2313 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
2316 match_file_element (gfc_filepos
*fp
)
2320 m
= match_etag (&tag_unit
, &fp
->unit
);
2323 m
= match_out_tag (&tag_iomsg
, &fp
->iomsg
);
2326 m
= match_out_tag (&tag_iostat
, &fp
->iostat
);
2329 m
= match_ltag (&tag_err
, &fp
->err
);
2337 /* Match the second half of the file-positioning statements, REWIND,
2338 BACKSPACE, ENDFILE, or the FLUSH statement. */
2341 match_filepos (gfc_statement st
, gfc_exec_op op
)
2346 fp
= XCNEW (gfc_filepos
);
2348 if (gfc_match_char ('(') == MATCH_NO
)
2350 m
= gfc_match_expr (&fp
->unit
);
2351 if (m
== MATCH_ERROR
)
2359 m
= match_file_element (fp
);
2360 if (m
== MATCH_ERROR
)
2364 m
= gfc_match_expr (&fp
->unit
);
2365 if (m
== MATCH_ERROR
)
2373 if (gfc_match_char (')') == MATCH_YES
)
2375 if (gfc_match_char (',') != MATCH_YES
)
2378 m
= match_file_element (fp
);
2379 if (m
== MATCH_ERROR
)
2386 if (gfc_match_eos () != MATCH_YES
)
2389 if (gfc_pure (NULL
))
2391 gfc_error ("%s statement not allowed in PURE procedure at %C",
2392 gfc_ascii_statement (st
));
2397 if (gfc_implicit_pure (NULL
))
2398 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
2401 new_st
.ext
.filepos
= fp
;
2405 gfc_syntax_error (st
);
2408 gfc_free_filepos (fp
);
2414 gfc_resolve_filepos (gfc_filepos
*fp
)
2416 RESOLVE_TAG (&tag_unit
, fp
->unit
);
2417 RESOLVE_TAG (&tag_iostat
, fp
->iostat
);
2418 RESOLVE_TAG (&tag_iomsg
, fp
->iomsg
);
2419 if (gfc_reference_st_label (fp
->err
, ST_LABEL_TARGET
) == FAILURE
)
2422 if (fp
->unit
->expr_type
== EXPR_CONSTANT
2423 && fp
->unit
->ts
.type
== BT_INTEGER
2424 && mpz_sgn (fp
->unit
->value
.integer
) < 0)
2426 gfc_error ("UNIT number in statement at %L must be non-negative",
2434 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2435 and the FLUSH statement. */
2438 gfc_match_endfile (void)
2440 return match_filepos (ST_END_FILE
, EXEC_ENDFILE
);
2444 gfc_match_backspace (void)
2446 return match_filepos (ST_BACKSPACE
, EXEC_BACKSPACE
);
2450 gfc_match_rewind (void)
2452 return match_filepos (ST_REWIND
, EXEC_REWIND
);
2456 gfc_match_flush (void)
2458 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: FLUSH statement at %C")
2462 return match_filepos (ST_FLUSH
, EXEC_FLUSH
);
2465 /******************** Data Transfer Statements *********************/
2467 /* Return a default unit number. */
2470 default_unit (io_kind k
)
2479 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, unit
);
2483 /* Match a unit specification for a data transfer statement. */
2486 match_dt_unit (io_kind k
, gfc_dt
*dt
)
2490 if (gfc_match_char ('*') == MATCH_YES
)
2492 if (dt
->io_unit
!= NULL
)
2495 dt
->io_unit
= default_unit (k
);
2499 if (gfc_match_expr (&e
) == MATCH_YES
)
2501 if (dt
->io_unit
!= NULL
)
2514 gfc_error ("Duplicate UNIT specification at %C");
2519 /* Match a format specification. */
2522 match_dt_format (gfc_dt
*dt
)
2526 gfc_st_label
*label
;
2529 where
= gfc_current_locus
;
2531 if (gfc_match_char ('*') == MATCH_YES
)
2533 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2536 dt
->format_label
= &format_asterisk
;
2540 if ((m
= gfc_match_st_label (&label
)) == MATCH_YES
)
2542 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2544 gfc_free_st_label (label
);
2548 if (gfc_reference_st_label (label
, ST_LABEL_FORMAT
) == FAILURE
)
2551 dt
->format_label
= label
;
2554 else if (m
== MATCH_ERROR
)
2555 /* The label was zero or too large. Emit the correct diagnosis. */
2558 if (gfc_match_expr (&e
) == MATCH_YES
)
2560 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2565 dt
->format_expr
= e
;
2569 gfc_current_locus
= where
; /* The only case where we have to restore */
2574 gfc_error ("Duplicate format specification at %C");
2579 /* Traverse a namelist that is part of a READ statement to make sure
2580 that none of the variables in the namelist are INTENT(IN). Returns
2581 nonzero if we find such a variable. */
2584 check_namelist (gfc_symbol
*sym
)
2588 for (p
= sym
->namelist
; p
; p
= p
->next
)
2589 if (p
->sym
->attr
.intent
== INTENT_IN
)
2591 gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
2592 p
->sym
->name
, sym
->name
);
2600 /* Match a single data transfer element. */
2603 match_dt_element (io_kind k
, gfc_dt
*dt
)
2605 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2609 if (gfc_match (" unit =") == MATCH_YES
)
2611 m
= match_dt_unit (k
, dt
);
2616 if (gfc_match (" fmt =") == MATCH_YES
)
2618 m
= match_dt_format (dt
);
2623 if (gfc_match (" nml = %n", name
) == MATCH_YES
)
2625 if (dt
->namelist
!= NULL
)
2627 gfc_error ("Duplicate NML specification at %C");
2631 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
2634 if (sym
== NULL
|| sym
->attr
.flavor
!= FL_NAMELIST
)
2636 gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
2637 sym
!= NULL
? sym
->name
: name
);
2642 if (k
== M_READ
&& check_namelist (sym
))
2648 m
= match_etag (&tag_e_async
, &dt
->asynchronous
);
2651 m
= match_etag (&tag_e_blank
, &dt
->blank
);
2654 m
= match_etag (&tag_e_delim
, &dt
->delim
);
2657 m
= match_etag (&tag_e_pad
, &dt
->pad
);
2660 m
= match_etag (&tag_e_sign
, &dt
->sign
);
2663 m
= match_etag (&tag_e_round
, &dt
->round
);
2666 m
= match_out_tag (&tag_id
, &dt
->id
);
2669 m
= match_etag (&tag_e_decimal
, &dt
->decimal
);
2672 m
= match_etag (&tag_rec
, &dt
->rec
);
2675 m
= match_etag (&tag_spos
, &dt
->pos
);
2678 m
= match_out_tag (&tag_iomsg
, &dt
->iomsg
);
2681 m
= match_out_tag (&tag_iostat
, &dt
->iostat
);
2684 m
= match_ltag (&tag_err
, &dt
->err
);
2686 dt
->err_where
= gfc_current_locus
;
2689 m
= match_etag (&tag_advance
, &dt
->advance
);
2692 m
= match_out_tag (&tag_size
, &dt
->size
);
2696 m
= match_ltag (&tag_end
, &dt
->end
);
2701 gfc_error ("END tag at %C not allowed in output statement");
2704 dt
->end_where
= gfc_current_locus
;
2709 m
= match_ltag (&tag_eor
, &dt
->eor
);
2711 dt
->eor_where
= gfc_current_locus
;
2719 /* Free a data transfer structure and everything below it. */
2722 gfc_free_dt (gfc_dt
*dt
)
2727 gfc_free_expr (dt
->io_unit
);
2728 gfc_free_expr (dt
->format_expr
);
2729 gfc_free_expr (dt
->rec
);
2730 gfc_free_expr (dt
->advance
);
2731 gfc_free_expr (dt
->iomsg
);
2732 gfc_free_expr (dt
->iostat
);
2733 gfc_free_expr (dt
->size
);
2734 gfc_free_expr (dt
->pad
);
2735 gfc_free_expr (dt
->delim
);
2736 gfc_free_expr (dt
->sign
);
2737 gfc_free_expr (dt
->round
);
2738 gfc_free_expr (dt
->blank
);
2739 gfc_free_expr (dt
->decimal
);
2740 gfc_free_expr (dt
->pos
);
2741 gfc_free_expr (dt
->dt_io_kind
);
2742 /* dt->extra_comma is a link to dt_io_kind if it is set. */
2747 /* Resolve everything in a gfc_dt structure. */
2750 gfc_resolve_dt (gfc_dt
*dt
, locus
*loc
)
2755 /* This is set in any case. */
2756 gcc_assert (dt
->dt_io_kind
);
2757 k
= dt
->dt_io_kind
->value
.iokind
;
2759 RESOLVE_TAG (&tag_format
, dt
->format_expr
);
2760 RESOLVE_TAG (&tag_rec
, dt
->rec
);
2761 RESOLVE_TAG (&tag_spos
, dt
->pos
);
2762 RESOLVE_TAG (&tag_advance
, dt
->advance
);
2763 RESOLVE_TAG (&tag_id
, dt
->id
);
2764 RESOLVE_TAG (&tag_iomsg
, dt
->iomsg
);
2765 RESOLVE_TAG (&tag_iostat
, dt
->iostat
);
2766 RESOLVE_TAG (&tag_size
, dt
->size
);
2767 RESOLVE_TAG (&tag_e_pad
, dt
->pad
);
2768 RESOLVE_TAG (&tag_e_delim
, dt
->delim
);
2769 RESOLVE_TAG (&tag_e_sign
, dt
->sign
);
2770 RESOLVE_TAG (&tag_e_round
, dt
->round
);
2771 RESOLVE_TAG (&tag_e_blank
, dt
->blank
);
2772 RESOLVE_TAG (&tag_e_decimal
, dt
->decimal
);
2773 RESOLVE_TAG (&tag_e_async
, dt
->asynchronous
);
2778 gfc_error ("UNIT not specified at %L", loc
);
2782 if (gfc_resolve_expr (e
) == SUCCESS
2783 && (e
->ts
.type
!= BT_INTEGER
2784 && (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_VARIABLE
)))
2786 /* If there is no extra comma signifying the "format" form of the IO
2787 statement, then this must be an error. */
2788 if (!dt
->extra_comma
)
2790 gfc_error ("UNIT specification at %L must be an INTEGER expression "
2791 "or a CHARACTER variable", &e
->where
);
2796 /* At this point, we have an extra comma. If io_unit has arrived as
2797 type character, we assume its really the "format" form of the I/O
2798 statement. We set the io_unit to the default unit and format to
2799 the character expression. See F95 Standard section 9.4. */
2800 if (e
->ts
.type
== BT_CHARACTER
&& (k
== M_READ
|| k
== M_PRINT
))
2802 dt
->format_expr
= dt
->io_unit
;
2803 dt
->io_unit
= default_unit (k
);
2805 /* Nullify this pointer now so that a warning/error is not
2806 triggered below for the "Extension". */
2807 dt
->extra_comma
= NULL
;
2812 gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
2813 &dt
->extra_comma
->where
);
2819 if (e
->ts
.type
== BT_CHARACTER
)
2821 if (gfc_has_vector_index (e
))
2823 gfc_error ("Internal unit with vector subscript at %L", &e
->where
);
2827 /* If we are writing, make sure the internal unit can be changed. */
2828 gcc_assert (k
!= M_PRINT
);
2830 && gfc_check_vardef_context (e
, false, _("internal unit in WRITE"))
2835 if (e
->rank
&& e
->ts
.type
!= BT_CHARACTER
)
2837 gfc_error ("External IO UNIT cannot be an array at %L", &e
->where
);
2841 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_INTEGER
2842 && mpz_sgn (e
->value
.integer
) < 0)
2844 gfc_error ("UNIT number in statement at %L must be non-negative",
2849 /* If we are reading and have a namelist, check that all namelist symbols
2850 can appear in a variable definition context. */
2851 if (k
== M_READ
&& dt
->namelist
)
2854 for (n
= dt
->namelist
->namelist
; n
; n
= n
->next
)
2859 e
= gfc_get_variable_expr (gfc_find_sym_in_symtree (n
->sym
));
2860 t
= gfc_check_vardef_context (e
, false, NULL
);
2865 gfc_error ("NAMELIST '%s' in READ statement at %L contains"
2866 " the symbol '%s' which may not appear in a"
2867 " variable definition context",
2868 dt
->namelist
->name
, loc
, n
->sym
->name
);
2875 && gfc_notify_std (GFC_STD_GNU
, "Extension: Comma before i/o "
2876 "item list at %L", &dt
->extra_comma
->where
) == FAILURE
)
2881 if (gfc_reference_st_label (dt
->err
, ST_LABEL_TARGET
) == FAILURE
)
2883 if (dt
->err
->defined
== ST_LABEL_UNKNOWN
)
2885 gfc_error ("ERR tag label %d at %L not defined",
2886 dt
->err
->value
, &dt
->err_where
);
2893 if (gfc_reference_st_label (dt
->end
, ST_LABEL_TARGET
) == FAILURE
)
2895 if (dt
->end
->defined
== ST_LABEL_UNKNOWN
)
2897 gfc_error ("END tag label %d at %L not defined",
2898 dt
->end
->value
, &dt
->end_where
);
2905 if (gfc_reference_st_label (dt
->eor
, ST_LABEL_TARGET
) == FAILURE
)
2907 if (dt
->eor
->defined
== ST_LABEL_UNKNOWN
)
2909 gfc_error ("EOR tag label %d at %L not defined",
2910 dt
->eor
->value
, &dt
->eor_where
);
2915 /* Check the format label actually exists. */
2916 if (dt
->format_label
&& dt
->format_label
!= &format_asterisk
2917 && dt
->format_label
->defined
== ST_LABEL_UNKNOWN
)
2919 gfc_error ("FORMAT label %d at %L not defined", dt
->format_label
->value
,
2920 &dt
->format_label
->where
);
2928 /* Given an io_kind, return its name. */
2931 io_kind_name (io_kind k
)
2950 gfc_internal_error ("io_kind_name(): bad I/O-kind");
2957 /* Match an IO iteration statement of the form:
2959 ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
2961 which is equivalent to a single IO element. This function is
2962 mutually recursive with match_io_element(). */
2964 static match
match_io_element (io_kind
, gfc_code
**);
2967 match_io_iterator (io_kind k
, gfc_code
**result
)
2969 gfc_code
*head
, *tail
, *new_code
;
2977 old_loc
= gfc_current_locus
;
2979 if (gfc_match_char ('(') != MATCH_YES
)
2982 m
= match_io_element (k
, &head
);
2985 if (m
!= MATCH_YES
|| gfc_match_char (',') != MATCH_YES
)
2991 /* Can't be anything but an IO iterator. Build a list. */
2992 iter
= gfc_get_iterator ();
2996 m
= gfc_match_iterator (iter
, 0);
2997 if (m
== MATCH_ERROR
)
3001 gfc_check_do_variable (iter
->var
->symtree
);
3005 m
= match_io_element (k
, &new_code
);
3006 if (m
== MATCH_ERROR
)
3015 tail
= gfc_append_code (tail
, new_code
);
3017 if (gfc_match_char (',') != MATCH_YES
)
3026 if (gfc_match_char (')') != MATCH_YES
)
3029 new_code
= gfc_get_code ();
3030 new_code
->op
= EXEC_DO
;
3031 new_code
->ext
.iterator
= iter
;
3033 new_code
->block
= gfc_get_code ();
3034 new_code
->block
->op
= EXEC_DO
;
3035 new_code
->block
->next
= head
;
3041 gfc_error ("Syntax error in I/O iterator at %C");
3045 gfc_free_iterator (iter
, 1);
3046 gfc_free_statements (head
);
3047 gfc_current_locus
= old_loc
;
3052 /* Match a single element of an IO list, which is either a single
3053 expression or an IO Iterator. */
3056 match_io_element (io_kind k
, gfc_code
**cpp
)
3064 m
= match_io_iterator (k
, cpp
);
3070 m
= gfc_match_variable (&expr
, 0);
3072 gfc_error ("Expected variable in READ statement at %C");
3076 m
= gfc_match_expr (&expr
);
3078 gfc_error ("Expected expression in %s statement at %C",
3082 if (m
== MATCH_YES
&& k
== M_READ
&& gfc_check_do_variable (expr
->symtree
))
3087 gfc_free_expr (expr
);
3091 cp
= gfc_get_code ();
3092 cp
->op
= EXEC_TRANSFER
;
3094 cp
->ext
.dt
= current_dt
;
3101 /* Match an I/O list, building gfc_code structures as we go. */
3104 match_io_list (io_kind k
, gfc_code
**head_p
)
3106 gfc_code
*head
, *tail
, *new_code
;
3109 *head_p
= head
= tail
= NULL
;
3110 if (gfc_match_eos () == MATCH_YES
)
3115 m
= match_io_element (k
, &new_code
);
3116 if (m
== MATCH_ERROR
)
3121 tail
= gfc_append_code (tail
, new_code
);
3125 if (gfc_match_eos () == MATCH_YES
)
3127 if (gfc_match_char (',') != MATCH_YES
)
3135 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
3138 gfc_free_statements (head
);
3143 /* Attach the data transfer end node. */
3146 terminate_io (gfc_code
*io_code
)
3150 if (io_code
== NULL
)
3151 io_code
= new_st
.block
;
3153 c
= gfc_get_code ();
3154 c
->op
= EXEC_DT_END
;
3156 /* Point to structure that is already there */
3157 c
->ext
.dt
= new_st
.ext
.dt
;
3158 gfc_append_code (io_code
, c
);
3162 /* Check the constraints for a data transfer statement. The majority of the
3163 constraints appearing in 9.4 of the standard appear here. Some are handled
3164 in resolve_tag and others in gfc_resolve_dt. */
3167 check_io_constraints (io_kind k
, gfc_dt
*dt
, gfc_code
*io_code
,
3170 #define io_constraint(condition,msg,arg)\
3173 gfc_error(msg,arg);\
3179 gfc_symbol
*sym
= NULL
;
3180 bool warn
, unformatted
;
3182 warn
= (dt
->err
|| dt
->iostat
) ? true : false;
3183 unformatted
= dt
->format_expr
== NULL
&& dt
->format_label
== NULL
3184 && dt
->namelist
== NULL
;
3189 if (expr
&& expr
->expr_type
== EXPR_VARIABLE
3190 && expr
->ts
.type
== BT_CHARACTER
)
3192 sym
= expr
->symtree
->n
.sym
;
3194 io_constraint (k
== M_WRITE
&& sym
->attr
.intent
== INTENT_IN
,
3195 "Internal file at %L must not be INTENT(IN)",
3198 io_constraint (gfc_has_vector_index (dt
->io_unit
),
3199 "Internal file incompatible with vector subscript at %L",
3202 io_constraint (dt
->rec
!= NULL
,
3203 "REC tag at %L is incompatible with internal file",
3206 io_constraint (dt
->pos
!= NULL
,
3207 "POS tag at %L is incompatible with internal file",
3210 io_constraint (unformatted
,
3211 "Unformatted I/O not allowed with internal unit at %L",
3212 &dt
->io_unit
->where
);
3214 io_constraint (dt
->asynchronous
!= NULL
,
3215 "ASYNCHRONOUS tag at %L not allowed with internal file",
3216 &dt
->asynchronous
->where
);
3218 if (dt
->namelist
!= NULL
)
3220 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Internal file "
3221 "at %L with namelist", &expr
->where
)
3226 io_constraint (dt
->advance
!= NULL
,
3227 "ADVANCE tag at %L is incompatible with internal file",
3228 &dt
->advance
->where
);
3231 if (expr
&& expr
->ts
.type
!= BT_CHARACTER
)
3234 io_constraint (gfc_pure (NULL
) && (k
== M_READ
|| k
== M_WRITE
),
3235 "IO UNIT in %s statement at %C must be "
3236 "an internal file in a PURE procedure",
3239 if (gfc_implicit_pure (NULL
) && (k
== M_READ
|| k
== M_WRITE
))
3240 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3246 io_constraint (dt
->end
, "END tag not allowed with output at %L",
3249 io_constraint (dt
->eor
, "EOR tag not allowed with output at %L",
3252 io_constraint (dt
->blank
, "BLANK= specifier not allowed with output at %L",
3255 io_constraint (dt
->pad
, "PAD= specifier not allowed with output at %L",
3258 io_constraint (dt
->size
, "SIZE= specifier not allowed with output at %L",
3263 io_constraint (dt
->size
&& dt
->advance
== NULL
,
3264 "SIZE tag at %L requires an ADVANCE tag",
3267 io_constraint (dt
->eor
&& dt
->advance
== NULL
,
3268 "EOR tag at %L requires an ADVANCE tag",
3272 if (dt
->asynchronous
)
3274 static const char * asynchronous
[] = { "YES", "NO", NULL
};
3276 if (gfc_reduce_init_expr (dt
->asynchronous
) != SUCCESS
)
3278 gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3279 "expression", &dt
->asynchronous
->where
);
3283 if (!compare_to_allowed_values
3284 ("ASYNCHRONOUS", asynchronous
, NULL
, NULL
,
3285 dt
->asynchronous
->value
.character
.string
,
3286 io_kind_name (k
), warn
))
3294 || gfc_wide_strlen (dt
->asynchronous
->value
.character
.string
) != 3
3295 || gfc_wide_strncasecmp (dt
->asynchronous
->value
.character
.string
,
3297 io_constraint (not_yes
,
3298 "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3299 "specifier", &dt
->id
->where
);
3304 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: DECIMAL= at %C "
3305 "not allowed in Fortran 95") == FAILURE
)
3308 if (dt
->decimal
->expr_type
== EXPR_CONSTANT
)
3310 static const char * decimal
[] = { "COMMA", "POINT", NULL
};
3312 if (!compare_to_allowed_values ("DECIMAL", decimal
, NULL
, NULL
,
3313 dt
->decimal
->value
.character
.string
,
3314 io_kind_name (k
), warn
))
3317 io_constraint (unformatted
,
3318 "the DECIMAL= specifier at %L must be with an "
3319 "explicit format expression", &dt
->decimal
->where
);
3325 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BLANK= at %C "
3326 "not allowed in Fortran 95") == FAILURE
)
3329 if (dt
->blank
->expr_type
== EXPR_CONSTANT
)
3331 static const char * blank
[] = { "NULL", "ZERO", NULL
};
3333 if (!compare_to_allowed_values ("BLANK", blank
, NULL
, NULL
,
3334 dt
->blank
->value
.character
.string
,
3335 io_kind_name (k
), warn
))
3338 io_constraint (unformatted
,
3339 "the BLANK= specifier at %L must be with an "
3340 "explicit format expression", &dt
->blank
->where
);
3346 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PAD= at %C "
3347 "not allowed in Fortran 95") == FAILURE
)
3350 if (dt
->pad
->expr_type
== EXPR_CONSTANT
)
3352 static const char * pad
[] = { "YES", "NO", NULL
};
3354 if (!compare_to_allowed_values ("PAD", pad
, NULL
, NULL
,
3355 dt
->pad
->value
.character
.string
,
3356 io_kind_name (k
), warn
))
3359 io_constraint (unformatted
,
3360 "the PAD= specifier at %L must be with an "
3361 "explicit format expression", &dt
->pad
->where
);
3367 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ROUND= at %C "
3368 "not allowed in Fortran 95") == FAILURE
)
3371 if (dt
->round
->expr_type
== EXPR_CONSTANT
)
3373 static const char * round
[] = { "UP", "DOWN", "ZERO", "NEAREST",
3374 "COMPATIBLE", "PROCESSOR_DEFINED",
3377 if (!compare_to_allowed_values ("ROUND", round
, NULL
, NULL
,
3378 dt
->round
->value
.character
.string
,
3379 io_kind_name (k
), warn
))
3386 /* When implemented, change the following to use gfc_notify_std F2003.
3387 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
3388 "not allowed in Fortran 95") == FAILURE)
3389 return MATCH_ERROR; */
3390 if (dt
->sign
->expr_type
== EXPR_CONSTANT
)
3392 static const char * sign
[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3395 if (!compare_to_allowed_values ("SIGN", sign
, NULL
, NULL
,
3396 dt
->sign
->value
.character
.string
,
3397 io_kind_name (k
), warn
))
3400 io_constraint (unformatted
,
3401 "SIGN= specifier at %L must be with an "
3402 "explicit format expression", &dt
->sign
->where
);
3404 io_constraint (k
== M_READ
,
3405 "SIGN= specifier at %L not allowed in a "
3406 "READ statement", &dt
->sign
->where
);
3412 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: DELIM= at %C "
3413 "not allowed in Fortran 95") == FAILURE
)
3416 if (dt
->delim
->expr_type
== EXPR_CONSTANT
)
3418 static const char *delim
[] = { "APOSTROPHE", "QUOTE", "NONE", NULL
};
3420 if (!compare_to_allowed_values ("DELIM", delim
, NULL
, NULL
,
3421 dt
->delim
->value
.character
.string
,
3422 io_kind_name (k
), warn
))
3425 io_constraint (k
== M_READ
,
3426 "DELIM= specifier at %L not allowed in a "
3427 "READ statement", &dt
->delim
->where
);
3429 io_constraint (dt
->format_label
!= &format_asterisk
3430 && dt
->namelist
== NULL
,
3431 "DELIM= specifier at %L must have FMT=*",
3434 io_constraint (unformatted
&& dt
->namelist
== NULL
,
3435 "DELIM= specifier at %L must be with FMT=* or "
3436 "NML= specifier ", &dt
->delim
->where
);
3442 io_constraint (io_code
&& dt
->namelist
,
3443 "NAMELIST cannot be followed by IO-list at %L",
3446 io_constraint (dt
->format_expr
,
3447 "IO spec-list cannot contain both NAMELIST group name "
3448 "and format specification at %L",
3449 &dt
->format_expr
->where
);
3451 io_constraint (dt
->format_label
,
3452 "IO spec-list cannot contain both NAMELIST group name "
3453 "and format label at %L", spec_end
);
3455 io_constraint (dt
->rec
,
3456 "NAMELIST IO is not allowed with a REC= specifier "
3457 "at %L", &dt
->rec
->where
);
3459 io_constraint (dt
->advance
,
3460 "NAMELIST IO is not allowed with a ADVANCE= specifier "
3461 "at %L", &dt
->advance
->where
);
3466 io_constraint (dt
->end
,
3467 "An END tag is not allowed with a "
3468 "REC= specifier at %L", &dt
->end_where
);
3470 io_constraint (dt
->format_label
== &format_asterisk
,
3471 "FMT=* is not allowed with a REC= specifier "
3474 io_constraint (dt
->pos
,
3475 "POS= is not allowed with REC= specifier "
3476 "at %L", &dt
->pos
->where
);
3481 int not_yes
, not_no
;
3484 io_constraint (dt
->format_label
== &format_asterisk
,
3485 "List directed format(*) is not allowed with a "
3486 "ADVANCE= specifier at %L.", &expr
->where
);
3488 io_constraint (unformatted
,
3489 "the ADVANCE= specifier at %L must appear with an "
3490 "explicit format expression", &expr
->where
);
3492 if (expr
->expr_type
== EXPR_CONSTANT
&& expr
->ts
.type
== BT_CHARACTER
)
3494 const gfc_char_t
*advance
= expr
->value
.character
.string
;
3495 not_no
= gfc_wide_strlen (advance
) != 2
3496 || gfc_wide_strncasecmp (advance
, "no", 2) != 0;
3497 not_yes
= gfc_wide_strlen (advance
) != 3
3498 || gfc_wide_strncasecmp (advance
, "yes", 3) != 0;
3506 io_constraint (not_no
&& not_yes
,
3507 "ADVANCE= specifier at %L must have value = "
3508 "YES or NO.", &expr
->where
);
3510 io_constraint (dt
->size
&& not_no
&& k
== M_READ
,
3511 "SIZE tag at %L requires an ADVANCE = 'NO'",
3514 io_constraint (dt
->eor
&& not_no
&& k
== M_READ
,
3515 "EOR tag at %L requires an ADVANCE = 'NO'",
3519 expr
= dt
->format_expr
;
3520 if (gfc_simplify_expr (expr
, 0) == FAILURE
3521 || check_format_string (expr
, k
== M_READ
) == FAILURE
)
3526 #undef io_constraint
3529 /* Match a READ, WRITE or PRINT statement. */
3532 match_io (io_kind k
)
3534 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3543 where
= gfc_current_locus
;
3545 current_dt
= dt
= XCNEW (gfc_dt
);
3546 m
= gfc_match_char ('(');
3549 where
= gfc_current_locus
;
3552 else if (k
== M_PRINT
)
3554 /* Treat the non-standard case of PRINT namelist. */
3555 if ((gfc_current_form
== FORM_FIXED
|| gfc_peek_ascii_char () == ' ')
3556 && gfc_match_name (name
) == MATCH_YES
)
3558 gfc_find_symbol (name
, NULL
, 1, &sym
);
3559 if (sym
&& sym
->attr
.flavor
== FL_NAMELIST
)
3561 if (gfc_notify_std (GFC_STD_GNU
, "PRINT namelist at "
3562 "%C is an extension") == FAILURE
)
3568 dt
->io_unit
= default_unit (k
);
3573 gfc_current_locus
= where
;
3577 if (gfc_current_form
== FORM_FREE
)
3579 char c
= gfc_peek_ascii_char ();
3580 if (c
!= ' ' && c
!= '*' && c
!= '\'' && c
!= '"')
3587 m
= match_dt_format (dt
);
3588 if (m
== MATCH_ERROR
)
3594 dt
->io_unit
= default_unit (k
);
3599 /* Before issuing an error for a malformed 'print (1,*)' type of
3600 error, check for a default-char-expr of the form ('(I0)'). */
3601 if (k
== M_PRINT
&& m
== MATCH_YES
)
3603 /* Reset current locus to get the initial '(' in an expression. */
3604 gfc_current_locus
= where
;
3605 dt
->format_expr
= NULL
;
3606 m
= match_dt_format (dt
);
3608 if (m
== MATCH_ERROR
)
3610 if (m
== MATCH_NO
|| dt
->format_expr
== NULL
)
3614 dt
->io_unit
= default_unit (k
);
3619 /* Match a control list */
3620 if (match_dt_element (k
, dt
) == MATCH_YES
)
3622 if (match_dt_unit (k
, dt
) != MATCH_YES
)
3625 if (gfc_match_char (')') == MATCH_YES
)
3627 if (gfc_match_char (',') != MATCH_YES
)
3630 m
= match_dt_element (k
, dt
);
3633 if (m
== MATCH_ERROR
)
3636 m
= match_dt_format (dt
);
3639 if (m
== MATCH_ERROR
)
3642 where
= gfc_current_locus
;
3644 m
= gfc_match_name (name
);
3647 gfc_find_symbol (name
, NULL
, 1, &sym
);
3648 if (sym
&& sym
->attr
.flavor
== FL_NAMELIST
)
3651 if (k
== M_READ
&& check_namelist (sym
))
3660 gfc_current_locus
= where
;
3662 goto loop
; /* No matches, try regular elements */
3665 if (gfc_match_char (')') == MATCH_YES
)
3667 if (gfc_match_char (',') != MATCH_YES
)
3673 m
= match_dt_element (k
, dt
);
3676 if (m
== MATCH_ERROR
)
3679 if (gfc_match_char (')') == MATCH_YES
)
3681 if (gfc_match_char (',') != MATCH_YES
)
3687 /* Used in check_io_constraints, where no locus is available. */
3688 spec_end
= gfc_current_locus
;
3690 /* Save the IO kind for later use. */
3691 dt
->dt_io_kind
= gfc_get_iokind_expr (&gfc_current_locus
, k
);
3693 /* Optional leading comma (non-standard). We use a gfc_expr structure here
3694 to save the locus. This is used later when resolving transfer statements
3695 that might have a format expression without unit number. */
3696 if (!comma_flag
&& gfc_match_char (',') == MATCH_YES
)
3697 dt
->extra_comma
= dt
->dt_io_kind
;
3700 if (gfc_match_eos () != MATCH_YES
)
3702 if (comma_flag
&& gfc_match_char (',') != MATCH_YES
)
3704 gfc_error ("Expected comma in I/O list at %C");
3709 m
= match_io_list (k
, &io_code
);
3710 if (m
== MATCH_ERROR
)
3716 /* A full IO statement has been matched. Check the constraints. spec_end is
3717 supplied for cases where no locus is supplied. */
3718 m
= check_io_constraints (k
, dt
, io_code
, &spec_end
);
3720 if (m
== MATCH_ERROR
)
3723 new_st
.op
= (k
== M_READ
) ? EXEC_READ
: EXEC_WRITE
;
3725 new_st
.block
= gfc_get_code ();
3726 new_st
.block
->op
= new_st
.op
;
3727 new_st
.block
->next
= io_code
;
3729 terminate_io (io_code
);
3734 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
3744 gfc_match_read (void)
3746 return match_io (M_READ
);
3751 gfc_match_write (void)
3753 return match_io (M_WRITE
);
3758 gfc_match_print (void)
3762 m
= match_io (M_PRINT
);
3766 if (gfc_pure (NULL
))
3768 gfc_error ("PRINT statement at %C not allowed within PURE procedure");
3772 if (gfc_implicit_pure (NULL
))
3773 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3779 /* Free a gfc_inquire structure. */
3782 gfc_free_inquire (gfc_inquire
*inquire
)
3785 if (inquire
== NULL
)
3788 gfc_free_expr (inquire
->unit
);
3789 gfc_free_expr (inquire
->file
);
3790 gfc_free_expr (inquire
->iomsg
);
3791 gfc_free_expr (inquire
->iostat
);
3792 gfc_free_expr (inquire
->exist
);
3793 gfc_free_expr (inquire
->opened
);
3794 gfc_free_expr (inquire
->number
);
3795 gfc_free_expr (inquire
->named
);
3796 gfc_free_expr (inquire
->name
);
3797 gfc_free_expr (inquire
->access
);
3798 gfc_free_expr (inquire
->sequential
);
3799 gfc_free_expr (inquire
->direct
);
3800 gfc_free_expr (inquire
->form
);
3801 gfc_free_expr (inquire
->formatted
);
3802 gfc_free_expr (inquire
->unformatted
);
3803 gfc_free_expr (inquire
->recl
);
3804 gfc_free_expr (inquire
->nextrec
);
3805 gfc_free_expr (inquire
->blank
);
3806 gfc_free_expr (inquire
->position
);
3807 gfc_free_expr (inquire
->action
);
3808 gfc_free_expr (inquire
->read
);
3809 gfc_free_expr (inquire
->write
);
3810 gfc_free_expr (inquire
->readwrite
);
3811 gfc_free_expr (inquire
->delim
);
3812 gfc_free_expr (inquire
->encoding
);
3813 gfc_free_expr (inquire
->pad
);
3814 gfc_free_expr (inquire
->iolength
);
3815 gfc_free_expr (inquire
->convert
);
3816 gfc_free_expr (inquire
->strm_pos
);
3817 gfc_free_expr (inquire
->asynchronous
);
3818 gfc_free_expr (inquire
->decimal
);
3819 gfc_free_expr (inquire
->pending
);
3820 gfc_free_expr (inquire
->id
);
3821 gfc_free_expr (inquire
->sign
);
3822 gfc_free_expr (inquire
->size
);
3823 gfc_free_expr (inquire
->round
);
3828 /* Match an element of an INQUIRE statement. */
3830 #define RETM if (m != MATCH_NO) return m;
3833 match_inquire_element (gfc_inquire
*inquire
)
3837 m
= match_etag (&tag_unit
, &inquire
->unit
);
3838 RETM m
= match_etag (&tag_file
, &inquire
->file
);
3839 RETM m
= match_ltag (&tag_err
, &inquire
->err
);
3840 RETM m
= match_out_tag (&tag_iomsg
, &inquire
->iomsg
);
3841 RETM m
= match_out_tag (&tag_iostat
, &inquire
->iostat
);
3842 RETM m
= match_vtag (&tag_exist
, &inquire
->exist
);
3843 RETM m
= match_vtag (&tag_opened
, &inquire
->opened
);
3844 RETM m
= match_vtag (&tag_named
, &inquire
->named
);
3845 RETM m
= match_vtag (&tag_name
, &inquire
->name
);
3846 RETM m
= match_out_tag (&tag_number
, &inquire
->number
);
3847 RETM m
= match_vtag (&tag_s_access
, &inquire
->access
);
3848 RETM m
= match_vtag (&tag_sequential
, &inquire
->sequential
);
3849 RETM m
= match_vtag (&tag_direct
, &inquire
->direct
);
3850 RETM m
= match_vtag (&tag_s_form
, &inquire
->form
);
3851 RETM m
= match_vtag (&tag_formatted
, &inquire
->formatted
);
3852 RETM m
= match_vtag (&tag_unformatted
, &inquire
->unformatted
);
3853 RETM m
= match_out_tag (&tag_s_recl
, &inquire
->recl
);
3854 RETM m
= match_out_tag (&tag_nextrec
, &inquire
->nextrec
);
3855 RETM m
= match_vtag (&tag_s_blank
, &inquire
->blank
);
3856 RETM m
= match_vtag (&tag_s_position
, &inquire
->position
);
3857 RETM m
= match_vtag (&tag_s_action
, &inquire
->action
);
3858 RETM m
= match_vtag (&tag_read
, &inquire
->read
);
3859 RETM m
= match_vtag (&tag_write
, &inquire
->write
);
3860 RETM m
= match_vtag (&tag_readwrite
, &inquire
->readwrite
);
3861 RETM m
= match_vtag (&tag_s_async
, &inquire
->asynchronous
);
3862 RETM m
= match_vtag (&tag_s_delim
, &inquire
->delim
);
3863 RETM m
= match_vtag (&tag_s_decimal
, &inquire
->decimal
);
3864 RETM m
= match_vtag (&tag_size
, &inquire
->size
);
3865 RETM m
= match_vtag (&tag_s_encoding
, &inquire
->encoding
);
3866 RETM m
= match_vtag (&tag_s_round
, &inquire
->round
);
3867 RETM m
= match_vtag (&tag_s_sign
, &inquire
->sign
);
3868 RETM m
= match_vtag (&tag_s_pad
, &inquire
->pad
);
3869 RETM m
= match_vtag (&tag_iolength
, &inquire
->iolength
);
3870 RETM m
= match_vtag (&tag_convert
, &inquire
->convert
);
3871 RETM m
= match_out_tag (&tag_strm_out
, &inquire
->strm_pos
);
3872 RETM m
= match_vtag (&tag_pending
, &inquire
->pending
);
3873 RETM m
= match_vtag (&tag_id
, &inquire
->id
);
3874 RETM
return MATCH_NO
;
3881 gfc_match_inquire (void)
3883 gfc_inquire
*inquire
;
3888 m
= gfc_match_char ('(');
3892 inquire
= XCNEW (gfc_inquire
);
3894 loc
= gfc_current_locus
;
3896 m
= match_inquire_element (inquire
);
3897 if (m
== MATCH_ERROR
)
3901 m
= gfc_match_expr (&inquire
->unit
);
3902 if (m
== MATCH_ERROR
)
3908 /* See if we have the IOLENGTH form of the inquire statement. */
3909 if (inquire
->iolength
!= NULL
)
3911 if (gfc_match_char (')') != MATCH_YES
)
3914 m
= match_io_list (M_INQUIRE
, &code
);
3915 if (m
== MATCH_ERROR
)
3920 new_st
.op
= EXEC_IOLENGTH
;
3921 new_st
.expr1
= inquire
->iolength
;
3922 new_st
.ext
.inquire
= inquire
;
3924 if (gfc_pure (NULL
))
3926 gfc_free_statements (code
);
3927 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3931 if (gfc_implicit_pure (NULL
))
3932 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3934 new_st
.block
= gfc_get_code ();
3935 new_st
.block
->op
= EXEC_IOLENGTH
;
3936 terminate_io (code
);
3937 new_st
.block
->next
= code
;
3941 /* At this point, we have the non-IOLENGTH inquire statement. */
3944 if (gfc_match_char (')') == MATCH_YES
)
3946 if (gfc_match_char (',') != MATCH_YES
)
3949 m
= match_inquire_element (inquire
);
3950 if (m
== MATCH_ERROR
)
3955 if (inquire
->iolength
!= NULL
)
3957 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
3962 if (gfc_match_eos () != MATCH_YES
)
3965 if (inquire
->unit
!= NULL
&& inquire
->file
!= NULL
)
3967 gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
3968 "UNIT specifiers", &loc
);
3972 if (inquire
->unit
== NULL
&& inquire
->file
== NULL
)
3974 gfc_error ("INQUIRE statement at %L requires either FILE or "
3975 "UNIT specifier", &loc
);
3979 if (gfc_pure (NULL
))
3981 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3985 if (gfc_implicit_pure (NULL
))
3986 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3988 if (inquire
->id
!= NULL
&& inquire
->pending
== NULL
)
3990 gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
3991 "the ID= specifier", &loc
);
3995 new_st
.op
= EXEC_INQUIRE
;
3996 new_st
.ext
.inquire
= inquire
;
4000 gfc_syntax_error (ST_INQUIRE
);
4003 gfc_free_inquire (inquire
);
4008 /* Resolve everything in a gfc_inquire structure. */
4011 gfc_resolve_inquire (gfc_inquire
*inquire
)
4013 RESOLVE_TAG (&tag_unit
, inquire
->unit
);
4014 RESOLVE_TAG (&tag_file
, inquire
->file
);
4015 RESOLVE_TAG (&tag_id
, inquire
->id
);
4017 /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4018 contexts. Thus, use an extended RESOLVE_TAG macro for that. */
4019 #define INQUIRE_RESOLVE_TAG(tag, expr) \
4020 RESOLVE_TAG (tag, expr); \
4024 sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
4025 if (gfc_check_vardef_context ((expr), false, context) == FAILURE) \
4028 INQUIRE_RESOLVE_TAG (&tag_iomsg
, inquire
->iomsg
);
4029 INQUIRE_RESOLVE_TAG (&tag_iostat
, inquire
->iostat
);
4030 INQUIRE_RESOLVE_TAG (&tag_exist
, inquire
->exist
);
4031 INQUIRE_RESOLVE_TAG (&tag_opened
, inquire
->opened
);
4032 INQUIRE_RESOLVE_TAG (&tag_number
, inquire
->number
);
4033 INQUIRE_RESOLVE_TAG (&tag_named
, inquire
->named
);
4034 INQUIRE_RESOLVE_TAG (&tag_name
, inquire
->name
);
4035 INQUIRE_RESOLVE_TAG (&tag_s_access
, inquire
->access
);
4036 INQUIRE_RESOLVE_TAG (&tag_sequential
, inquire
->sequential
);
4037 INQUIRE_RESOLVE_TAG (&tag_direct
, inquire
->direct
);
4038 INQUIRE_RESOLVE_TAG (&tag_s_form
, inquire
->form
);
4039 INQUIRE_RESOLVE_TAG (&tag_formatted
, inquire
->formatted
);
4040 INQUIRE_RESOLVE_TAG (&tag_unformatted
, inquire
->unformatted
);
4041 INQUIRE_RESOLVE_TAG (&tag_s_recl
, inquire
->recl
);
4042 INQUIRE_RESOLVE_TAG (&tag_nextrec
, inquire
->nextrec
);
4043 INQUIRE_RESOLVE_TAG (&tag_s_blank
, inquire
->blank
);
4044 INQUIRE_RESOLVE_TAG (&tag_s_position
, inquire
->position
);
4045 INQUIRE_RESOLVE_TAG (&tag_s_action
, inquire
->action
);
4046 INQUIRE_RESOLVE_TAG (&tag_read
, inquire
->read
);
4047 INQUIRE_RESOLVE_TAG (&tag_write
, inquire
->write
);
4048 INQUIRE_RESOLVE_TAG (&tag_readwrite
, inquire
->readwrite
);
4049 INQUIRE_RESOLVE_TAG (&tag_s_delim
, inquire
->delim
);
4050 INQUIRE_RESOLVE_TAG (&tag_s_pad
, inquire
->pad
);
4051 INQUIRE_RESOLVE_TAG (&tag_s_encoding
, inquire
->encoding
);
4052 INQUIRE_RESOLVE_TAG (&tag_s_round
, inquire
->round
);
4053 INQUIRE_RESOLVE_TAG (&tag_iolength
, inquire
->iolength
);
4054 INQUIRE_RESOLVE_TAG (&tag_convert
, inquire
->convert
);
4055 INQUIRE_RESOLVE_TAG (&tag_strm_out
, inquire
->strm_pos
);
4056 INQUIRE_RESOLVE_TAG (&tag_s_async
, inquire
->asynchronous
);
4057 INQUIRE_RESOLVE_TAG (&tag_s_sign
, inquire
->sign
);
4058 INQUIRE_RESOLVE_TAG (&tag_s_round
, inquire
->round
);
4059 INQUIRE_RESOLVE_TAG (&tag_pending
, inquire
->pending
);
4060 INQUIRE_RESOLVE_TAG (&tag_size
, inquire
->size
);
4061 #undef INQUIRE_RESOLVE_TAG
4063 if (gfc_reference_st_label (inquire
->err
, ST_LABEL_TARGET
) == FAILURE
)
4071 gfc_free_wait (gfc_wait
*wait
)
4076 gfc_free_expr (wait
->unit
);
4077 gfc_free_expr (wait
->iostat
);
4078 gfc_free_expr (wait
->iomsg
);
4079 gfc_free_expr (wait
->id
);
4084 gfc_resolve_wait (gfc_wait
*wait
)
4086 RESOLVE_TAG (&tag_unit
, wait
->unit
);
4087 RESOLVE_TAG (&tag_iomsg
, wait
->iomsg
);
4088 RESOLVE_TAG (&tag_iostat
, wait
->iostat
);
4089 RESOLVE_TAG (&tag_id
, wait
->id
);
4091 if (gfc_reference_st_label (wait
->err
, ST_LABEL_TARGET
) == FAILURE
)
4094 if (gfc_reference_st_label (wait
->end
, ST_LABEL_TARGET
) == FAILURE
)
4100 /* Match an element of a WAIT statement. */
4102 #define RETM if (m != MATCH_NO) return m;
4105 match_wait_element (gfc_wait
*wait
)
4109 m
= match_etag (&tag_unit
, &wait
->unit
);
4110 RETM m
= match_ltag (&tag_err
, &wait
->err
);
4111 RETM m
= match_ltag (&tag_end
, &wait
->eor
);
4112 RETM m
= match_ltag (&tag_eor
, &wait
->end
);
4113 RETM m
= match_out_tag (&tag_iomsg
, &wait
->iomsg
);
4114 RETM m
= match_out_tag (&tag_iostat
, &wait
->iostat
);
4115 RETM m
= match_etag (&tag_id
, &wait
->id
);
4116 RETM
return MATCH_NO
;
4123 gfc_match_wait (void)
4128 m
= gfc_match_char ('(');
4132 wait
= XCNEW (gfc_wait
);
4134 m
= match_wait_element (wait
);
4135 if (m
== MATCH_ERROR
)
4139 m
= gfc_match_expr (&wait
->unit
);
4140 if (m
== MATCH_ERROR
)
4148 if (gfc_match_char (')') == MATCH_YES
)
4150 if (gfc_match_char (',') != MATCH_YES
)
4153 m
= match_wait_element (wait
);
4154 if (m
== MATCH_ERROR
)
4160 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: WAIT at %C "
4161 "not allowed in Fortran 95") == FAILURE
)
4164 if (gfc_pure (NULL
))
4166 gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4170 if (gfc_implicit_pure (NULL
))
4171 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
4173 new_st
.op
= EXEC_WAIT
;
4174 new_st
.ext
.wait
= wait
;
4179 gfc_syntax_error (ST_WAIT
);
4182 gfc_free_wait (wait
);