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
1398 || e
->ts
.kind
!= gfc_default_character_kind
)
1399 && e
->ts
.type
!= BT_INTEGER
)
1401 gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER "
1402 "or of INTEGER", &e
->where
);
1405 else if (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_VARIABLE
)
1407 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: ASSIGNED "
1408 "variable in FORMAT tag at %L", &e
->where
)
1411 if (e
->symtree
->n
.sym
->attr
.assign
!= 1)
1413 gfc_error ("Variable '%s' at %L has not been assigned a "
1414 "format label", e
->symtree
->n
.sym
->name
, &e
->where
);
1418 else if (e
->ts
.type
== BT_INTEGER
)
1420 gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
1421 "variable", gfc_basic_typename (e
->ts
.type
), &e
->where
);
1428 /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
1429 It may be assigned an Hollerith constant. */
1430 if (e
->ts
.type
!= BT_CHARACTER
)
1432 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: Non-character "
1433 "in FORMAT tag at %L", &e
->where
) == FAILURE
)
1436 if (e
->rank
== 0 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
)
1438 gfc_error ("Non-character assumed shape array element in FORMAT"
1439 " tag at %L", &e
->where
);
1443 if (e
->rank
== 0 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
)
1445 gfc_error ("Non-character assumed size array element in FORMAT"
1446 " tag at %L", &e
->where
);
1450 if (e
->rank
== 0 && e
->symtree
->n
.sym
->attr
.pointer
)
1452 gfc_error ("Non-character pointer array element in FORMAT tag at %L",
1462 /* Do expression resolution and type-checking on an expression tag. */
1465 resolve_tag (const io_tag
*tag
, gfc_expr
*e
)
1470 if (gfc_resolve_expr (e
) == FAILURE
)
1473 if (tag
== &tag_format
)
1474 return resolve_tag_format (e
);
1476 if (e
->ts
.type
!= tag
->type
)
1478 gfc_error ("%s tag at %L must be of type %s", tag
->name
,
1479 &e
->where
, gfc_basic_typename (tag
->type
));
1483 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= gfc_default_character_kind
)
1485 gfc_error ("%s tag at %L must be a character string of default kind",
1486 tag
->name
, &e
->where
);
1492 gfc_error ("%s tag at %L must be scalar", tag
->name
, &e
->where
);
1496 if (tag
== &tag_iomsg
)
1498 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: IOMSG tag at %L",
1499 &e
->where
) == FAILURE
)
1503 if ((tag
== &tag_iostat
|| tag
== &tag_size
|| tag
== &tag_iolength
)
1504 && e
->ts
.kind
!= gfc_default_integer_kind
)
1506 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 95 requires default "
1507 "INTEGER in %s tag at %L", tag
->name
, &e
->where
)
1512 if (tag
== &tag_exist
&& e
->ts
.kind
!= gfc_default_logical_kind
)
1514 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Nondefault LOGICAL "
1515 "in %s tag at %L", tag
->name
, &e
->where
)
1520 if (tag
== &tag_newunit
)
1522 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: NEWUNIT specifier"
1523 " at %L", &e
->where
) == FAILURE
)
1527 /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */
1528 if (tag
== &tag_newunit
|| tag
== &tag_iostat
1529 || tag
== &tag_size
|| tag
== &tag_iomsg
)
1533 sprintf (context
, _("%s tag"), tag
->name
);
1534 if (gfc_check_vardef_context (e
, false, false, context
) == FAILURE
)
1538 if (tag
== &tag_convert
)
1540 if (gfc_notify_std (GFC_STD_GNU
, "Extension: CONVERT tag at %L",
1541 &e
->where
) == FAILURE
)
1549 /* Match a single tag of an OPEN statement. */
1552 match_open_element (gfc_open
*open
)
1556 m
= match_etag (&tag_e_async
, &open
->asynchronous
);
1559 m
= match_etag (&tag_unit
, &open
->unit
);
1562 m
= match_out_tag (&tag_iomsg
, &open
->iomsg
);
1565 m
= match_out_tag (&tag_iostat
, &open
->iostat
);
1568 m
= match_etag (&tag_file
, &open
->file
);
1571 m
= match_etag (&tag_status
, &open
->status
);
1574 m
= match_etag (&tag_e_access
, &open
->access
);
1577 m
= match_etag (&tag_e_form
, &open
->form
);
1580 m
= match_etag (&tag_e_recl
, &open
->recl
);
1583 m
= match_etag (&tag_e_blank
, &open
->blank
);
1586 m
= match_etag (&tag_e_position
, &open
->position
);
1589 m
= match_etag (&tag_e_action
, &open
->action
);
1592 m
= match_etag (&tag_e_delim
, &open
->delim
);
1595 m
= match_etag (&tag_e_pad
, &open
->pad
);
1598 m
= match_etag (&tag_e_decimal
, &open
->decimal
);
1601 m
= match_etag (&tag_e_encoding
, &open
->encoding
);
1604 m
= match_etag (&tag_e_round
, &open
->round
);
1607 m
= match_etag (&tag_e_sign
, &open
->sign
);
1610 m
= match_ltag (&tag_err
, &open
->err
);
1613 m
= match_etag (&tag_convert
, &open
->convert
);
1616 m
= match_out_tag (&tag_newunit
, &open
->newunit
);
1624 /* Free the gfc_open structure and all the expressions it contains. */
1627 gfc_free_open (gfc_open
*open
)
1632 gfc_free_expr (open
->unit
);
1633 gfc_free_expr (open
->iomsg
);
1634 gfc_free_expr (open
->iostat
);
1635 gfc_free_expr (open
->file
);
1636 gfc_free_expr (open
->status
);
1637 gfc_free_expr (open
->access
);
1638 gfc_free_expr (open
->form
);
1639 gfc_free_expr (open
->recl
);
1640 gfc_free_expr (open
->blank
);
1641 gfc_free_expr (open
->position
);
1642 gfc_free_expr (open
->action
);
1643 gfc_free_expr (open
->delim
);
1644 gfc_free_expr (open
->pad
);
1645 gfc_free_expr (open
->decimal
);
1646 gfc_free_expr (open
->encoding
);
1647 gfc_free_expr (open
->round
);
1648 gfc_free_expr (open
->sign
);
1649 gfc_free_expr (open
->convert
);
1650 gfc_free_expr (open
->asynchronous
);
1651 gfc_free_expr (open
->newunit
);
1656 /* Resolve everything in a gfc_open structure. */
1659 gfc_resolve_open (gfc_open
*open
)
1662 RESOLVE_TAG (&tag_unit
, open
->unit
);
1663 RESOLVE_TAG (&tag_iomsg
, open
->iomsg
);
1664 RESOLVE_TAG (&tag_iostat
, open
->iostat
);
1665 RESOLVE_TAG (&tag_file
, open
->file
);
1666 RESOLVE_TAG (&tag_status
, open
->status
);
1667 RESOLVE_TAG (&tag_e_access
, open
->access
);
1668 RESOLVE_TAG (&tag_e_form
, open
->form
);
1669 RESOLVE_TAG (&tag_e_recl
, open
->recl
);
1670 RESOLVE_TAG (&tag_e_blank
, open
->blank
);
1671 RESOLVE_TAG (&tag_e_position
, open
->position
);
1672 RESOLVE_TAG (&tag_e_action
, open
->action
);
1673 RESOLVE_TAG (&tag_e_delim
, open
->delim
);
1674 RESOLVE_TAG (&tag_e_pad
, open
->pad
);
1675 RESOLVE_TAG (&tag_e_decimal
, open
->decimal
);
1676 RESOLVE_TAG (&tag_e_encoding
, open
->encoding
);
1677 RESOLVE_TAG (&tag_e_async
, open
->asynchronous
);
1678 RESOLVE_TAG (&tag_e_round
, open
->round
);
1679 RESOLVE_TAG (&tag_e_sign
, open
->sign
);
1680 RESOLVE_TAG (&tag_convert
, open
->convert
);
1681 RESOLVE_TAG (&tag_newunit
, open
->newunit
);
1683 if (gfc_reference_st_label (open
->err
, ST_LABEL_TARGET
) == FAILURE
)
1690 /* Check if a given value for a SPECIFIER is either in the list of values
1691 allowed in F95 or F2003, issuing an error message and returning a zero
1692 value if it is not allowed. */
1695 compare_to_allowed_values (const char *specifier
, const char *allowed
[],
1696 const char *allowed_f2003
[],
1697 const char *allowed_gnu
[], gfc_char_t
*value
,
1698 const char *statement
, bool warn
)
1703 len
= gfc_wide_strlen (value
);
1706 for (len
--; len
> 0; len
--)
1707 if (value
[len
] != ' ')
1712 for (i
= 0; allowed
[i
]; i
++)
1713 if (len
== strlen (allowed
[i
])
1714 && gfc_wide_strncasecmp (value
, allowed
[i
], strlen (allowed
[i
])) == 0)
1717 for (i
= 0; allowed_f2003
&& allowed_f2003
[i
]; i
++)
1718 if (len
== strlen (allowed_f2003
[i
])
1719 && gfc_wide_strncasecmp (value
, allowed_f2003
[i
],
1720 strlen (allowed_f2003
[i
])) == 0)
1722 notification n
= gfc_notification_std (GFC_STD_F2003
);
1724 if (n
== WARNING
|| (warn
&& n
== ERROR
))
1726 gfc_warning ("Fortran 2003: %s specifier in %s statement at %C "
1727 "has value '%s'", specifier
, statement
,
1734 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: %s specifier in "
1735 "%s statement at %C has value '%s'", specifier
,
1736 statement
, allowed_f2003
[i
]);
1744 for (i
= 0; allowed_gnu
&& allowed_gnu
[i
]; i
++)
1745 if (len
== strlen (allowed_gnu
[i
])
1746 && gfc_wide_strncasecmp (value
, allowed_gnu
[i
],
1747 strlen (allowed_gnu
[i
])) == 0)
1749 notification n
= gfc_notification_std (GFC_STD_GNU
);
1751 if (n
== WARNING
|| (warn
&& n
== ERROR
))
1753 gfc_warning ("Extension: %s specifier in %s statement at %C "
1754 "has value '%s'", specifier
, statement
,
1761 gfc_notify_std (GFC_STD_GNU
, "Extension: %s specifier in "
1762 "%s statement at %C has value '%s'", specifier
,
1763 statement
, allowed_gnu
[i
]);
1773 char *s
= gfc_widechar_to_char (value
, -1);
1774 gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
1775 specifier
, statement
, s
);
1781 char *s
= gfc_widechar_to_char (value
, -1);
1782 gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
1783 specifier
, statement
, s
);
1790 /* Match an OPEN statement. */
1793 gfc_match_open (void)
1799 m
= gfc_match_char ('(');
1803 open
= XCNEW (gfc_open
);
1805 m
= match_open_element (open
);
1807 if (m
== MATCH_ERROR
)
1811 m
= gfc_match_expr (&open
->unit
);
1812 if (m
== MATCH_ERROR
)
1818 if (gfc_match_char (')') == MATCH_YES
)
1820 if (gfc_match_char (',') != MATCH_YES
)
1823 m
= match_open_element (open
);
1824 if (m
== MATCH_ERROR
)
1830 if (gfc_match_eos () == MATCH_NO
)
1833 if (gfc_pure (NULL
))
1835 gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1839 if (gfc_implicit_pure (NULL
))
1840 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1842 warn
= (open
->err
|| open
->iostat
) ? true : false;
1844 /* Checks on NEWUNIT specifier. */
1849 gfc_error ("UNIT specifier not allowed with NEWUNIT at %C");
1853 if (!(open
->file
|| (open
->status
1854 && gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
1855 "scratch", 7) == 0)))
1857 gfc_error ("NEWUNIT specifier must have FILE= "
1858 "or STATUS='scratch' at %C");
1862 else if (!open
->unit
)
1864 gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified");
1868 /* Checks on the ACCESS specifier. */
1869 if (open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
)
1871 static const char *access_f95
[] = { "SEQUENTIAL", "DIRECT", NULL
};
1872 static const char *access_f2003
[] = { "STREAM", NULL
};
1873 static const char *access_gnu
[] = { "APPEND", NULL
};
1875 if (!compare_to_allowed_values ("ACCESS", access_f95
, access_f2003
,
1877 open
->access
->value
.character
.string
,
1882 /* Checks on the ACTION specifier. */
1883 if (open
->action
&& open
->action
->expr_type
== EXPR_CONSTANT
)
1885 static const char *action
[] = { "READ", "WRITE", "READWRITE", NULL
};
1887 if (!compare_to_allowed_values ("ACTION", action
, NULL
, NULL
,
1888 open
->action
->value
.character
.string
,
1893 /* Checks on the ASYNCHRONOUS specifier. */
1894 if (open
->asynchronous
)
1896 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ASYNCHRONOUS= at %C "
1897 "not allowed in Fortran 95") == FAILURE
)
1900 if (open
->asynchronous
->expr_type
== EXPR_CONSTANT
)
1902 static const char * asynchronous
[] = { "YES", "NO", NULL
};
1904 if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous
,
1905 NULL
, NULL
, open
->asynchronous
->value
.character
.string
,
1911 /* Checks on the BLANK specifier. */
1914 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BLANK= at %C "
1915 "not allowed in Fortran 95") == FAILURE
)
1918 if (open
->blank
->expr_type
== EXPR_CONSTANT
)
1920 static const char *blank
[] = { "ZERO", "NULL", NULL
};
1922 if (!compare_to_allowed_values ("BLANK", blank
, NULL
, NULL
,
1923 open
->blank
->value
.character
.string
,
1929 /* Checks on the DECIMAL specifier. */
1932 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: DECIMAL= at %C "
1933 "not allowed in Fortran 95") == FAILURE
)
1936 if (open
->decimal
->expr_type
== EXPR_CONSTANT
)
1938 static const char * decimal
[] = { "COMMA", "POINT", NULL
};
1940 if (!compare_to_allowed_values ("DECIMAL", decimal
, NULL
, NULL
,
1941 open
->decimal
->value
.character
.string
,
1947 /* Checks on the DELIM specifier. */
1950 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: DELIM= at %C "
1951 "not allowed in Fortran 95") == FAILURE
)
1954 if (open
->delim
->expr_type
== EXPR_CONSTANT
)
1956 static const char *delim
[] = { "APOSTROPHE", "QUOTE", "NONE", NULL
};
1958 if (!compare_to_allowed_values ("DELIM", delim
, NULL
, NULL
,
1959 open
->delim
->value
.character
.string
,
1965 /* Checks on the ENCODING specifier. */
1968 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ENCODING= at %C "
1969 "not allowed in Fortran 95") == FAILURE
)
1972 if (open
->encoding
->expr_type
== EXPR_CONSTANT
)
1974 static const char * encoding
[] = { "DEFAULT", "UTF-8", NULL
};
1976 if (!compare_to_allowed_values ("ENCODING", encoding
, NULL
, NULL
,
1977 open
->encoding
->value
.character
.string
,
1983 /* Checks on the FORM specifier. */
1984 if (open
->form
&& open
->form
->expr_type
== EXPR_CONSTANT
)
1986 static const char *form
[] = { "FORMATTED", "UNFORMATTED", NULL
};
1988 if (!compare_to_allowed_values ("FORM", form
, NULL
, NULL
,
1989 open
->form
->value
.character
.string
,
1994 /* Checks on the PAD specifier. */
1995 if (open
->pad
&& open
->pad
->expr_type
== EXPR_CONSTANT
)
1997 static const char *pad
[] = { "YES", "NO", NULL
};
1999 if (!compare_to_allowed_values ("PAD", pad
, NULL
, NULL
,
2000 open
->pad
->value
.character
.string
,
2005 /* Checks on the POSITION specifier. */
2006 if (open
->position
&& open
->position
->expr_type
== EXPR_CONSTANT
)
2008 static const char *position
[] = { "ASIS", "REWIND", "APPEND", NULL
};
2010 if (!compare_to_allowed_values ("POSITION", position
, NULL
, NULL
,
2011 open
->position
->value
.character
.string
,
2016 /* Checks on the ROUND specifier. */
2019 if (gfc_notify_std (GFC_STD_F2003
, "Fortran F2003: ROUND= at %C "
2020 "not allowed in Fortran 95") == FAILURE
)
2023 if (open
->round
->expr_type
== EXPR_CONSTANT
)
2025 static const char * round
[] = { "UP", "DOWN", "ZERO", "NEAREST",
2026 "COMPATIBLE", "PROCESSOR_DEFINED",
2029 if (!compare_to_allowed_values ("ROUND", round
, NULL
, NULL
,
2030 open
->round
->value
.character
.string
,
2036 /* Checks on the SIGN specifier. */
2039 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: SIGN= at %C "
2040 "not allowed in Fortran 95") == FAILURE
)
2043 if (open
->sign
->expr_type
== EXPR_CONSTANT
)
2045 static const char * sign
[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
2048 if (!compare_to_allowed_values ("SIGN", sign
, NULL
, NULL
,
2049 open
->sign
->value
.character
.string
,
2055 #define warn_or_error(...) \
2058 gfc_warning (__VA_ARGS__); \
2061 gfc_error (__VA_ARGS__); \
2066 /* Checks on the RECL specifier. */
2067 if (open
->recl
&& open
->recl
->expr_type
== EXPR_CONSTANT
2068 && open
->recl
->ts
.type
== BT_INTEGER
2069 && mpz_sgn (open
->recl
->value
.integer
) != 1)
2071 warn_or_error ("RECL in OPEN statement at %C must be positive");
2074 /* Checks on the STATUS specifier. */
2075 if (open
->status
&& open
->status
->expr_type
== EXPR_CONSTANT
)
2077 static const char *status
[] = { "OLD", "NEW", "SCRATCH",
2078 "REPLACE", "UNKNOWN", NULL
};
2080 if (!compare_to_allowed_values ("STATUS", status
, NULL
, NULL
,
2081 open
->status
->value
.character
.string
,
2085 /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2086 the FILE= specifier shall appear. */
2087 if (open
->file
== NULL
2088 && (gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2090 || gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2093 char *s
= gfc_widechar_to_char (open
->status
->value
.character
.string
,
2095 warn_or_error ("The STATUS specified in OPEN statement at %C is "
2096 "'%s' and no FILE specifier is present", s
);
2100 /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2101 the FILE= specifier shall not appear. */
2102 if (gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2103 "scratch", 7) == 0 && open
->file
)
2105 warn_or_error ("The STATUS specified in OPEN statement at %C "
2106 "cannot have the value SCRATCH if a FILE specifier "
2111 /* Things that are not allowed for unformatted I/O. */
2112 if (open
->form
&& open
->form
->expr_type
== EXPR_CONSTANT
2113 && (open
->delim
|| open
->decimal
|| open
->encoding
|| open
->round
2114 || open
->sign
|| open
->pad
|| open
->blank
)
2115 && gfc_wide_strncasecmp (open
->form
->value
.character
.string
,
2116 "unformatted", 11) == 0)
2118 const char *spec
= (open
->delim
? "DELIM "
2119 : (open
->pad
? "PAD " : open
->blank
2122 warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
2123 "unformatted I/O", spec
);
2126 if (open
->recl
&& open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
2127 && gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2130 warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
2135 && open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
2136 && !(gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2137 "sequential", 10) == 0
2138 || gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2140 || gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2143 warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
2144 "for stream or sequential ACCESS");
2147 #undef warn_or_error
2149 new_st
.op
= EXEC_OPEN
;
2150 new_st
.ext
.open
= open
;
2154 gfc_syntax_error (ST_OPEN
);
2157 gfc_free_open (open
);
2162 /* Free a gfc_close structure an all its expressions. */
2165 gfc_free_close (gfc_close
*close
)
2170 gfc_free_expr (close
->unit
);
2171 gfc_free_expr (close
->iomsg
);
2172 gfc_free_expr (close
->iostat
);
2173 gfc_free_expr (close
->status
);
2178 /* Match elements of a CLOSE statement. */
2181 match_close_element (gfc_close
*close
)
2185 m
= match_etag (&tag_unit
, &close
->unit
);
2188 m
= match_etag (&tag_status
, &close
->status
);
2191 m
= match_out_tag (&tag_iomsg
, &close
->iomsg
);
2194 m
= match_out_tag (&tag_iostat
, &close
->iostat
);
2197 m
= match_ltag (&tag_err
, &close
->err
);
2205 /* Match a CLOSE statement. */
2208 gfc_match_close (void)
2214 m
= gfc_match_char ('(');
2218 close
= XCNEW (gfc_close
);
2220 m
= match_close_element (close
);
2222 if (m
== MATCH_ERROR
)
2226 m
= gfc_match_expr (&close
->unit
);
2229 if (m
== MATCH_ERROR
)
2235 if (gfc_match_char (')') == MATCH_YES
)
2237 if (gfc_match_char (',') != MATCH_YES
)
2240 m
= match_close_element (close
);
2241 if (m
== MATCH_ERROR
)
2247 if (gfc_match_eos () == MATCH_NO
)
2250 if (gfc_pure (NULL
))
2252 gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2256 if (gfc_implicit_pure (NULL
))
2257 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
2259 warn
= (close
->iostat
|| close
->err
) ? true : false;
2261 /* Checks on the STATUS specifier. */
2262 if (close
->status
&& close
->status
->expr_type
== EXPR_CONSTANT
)
2264 static const char *status
[] = { "KEEP", "DELETE", NULL
};
2266 if (!compare_to_allowed_values ("STATUS", status
, NULL
, NULL
,
2267 close
->status
->value
.character
.string
,
2272 new_st
.op
= EXEC_CLOSE
;
2273 new_st
.ext
.close
= close
;
2277 gfc_syntax_error (ST_CLOSE
);
2280 gfc_free_close (close
);
2285 /* Resolve everything in a gfc_close structure. */
2288 gfc_resolve_close (gfc_close
*close
)
2290 RESOLVE_TAG (&tag_unit
, close
->unit
);
2291 RESOLVE_TAG (&tag_iomsg
, close
->iomsg
);
2292 RESOLVE_TAG (&tag_iostat
, close
->iostat
);
2293 RESOLVE_TAG (&tag_status
, close
->status
);
2295 if (gfc_reference_st_label (close
->err
, ST_LABEL_TARGET
) == FAILURE
)
2298 if (close
->unit
== NULL
)
2300 /* Find a locus from one of the arguments to close, when UNIT is
2302 locus loc
= gfc_current_locus
;
2304 loc
= close
->status
->where
;
2305 else if (close
->iostat
)
2306 loc
= close
->iostat
->where
;
2307 else if (close
->iomsg
)
2308 loc
= close
->iomsg
->where
;
2309 else if (close
->err
)
2310 loc
= close
->err
->where
;
2312 gfc_error ("CLOSE statement at %L requires a UNIT number", &loc
);
2316 if (close
->unit
->expr_type
== EXPR_CONSTANT
2317 && close
->unit
->ts
.type
== BT_INTEGER
2318 && mpz_sgn (close
->unit
->value
.integer
) < 0)
2320 gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2321 &close
->unit
->where
);
2328 /* Free a gfc_filepos structure. */
2331 gfc_free_filepos (gfc_filepos
*fp
)
2333 gfc_free_expr (fp
->unit
);
2334 gfc_free_expr (fp
->iomsg
);
2335 gfc_free_expr (fp
->iostat
);
2340 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
2343 match_file_element (gfc_filepos
*fp
)
2347 m
= match_etag (&tag_unit
, &fp
->unit
);
2350 m
= match_out_tag (&tag_iomsg
, &fp
->iomsg
);
2353 m
= match_out_tag (&tag_iostat
, &fp
->iostat
);
2356 m
= match_ltag (&tag_err
, &fp
->err
);
2364 /* Match the second half of the file-positioning statements, REWIND,
2365 BACKSPACE, ENDFILE, or the FLUSH statement. */
2368 match_filepos (gfc_statement st
, gfc_exec_op op
)
2373 fp
= XCNEW (gfc_filepos
);
2375 if (gfc_match_char ('(') == MATCH_NO
)
2377 m
= gfc_match_expr (&fp
->unit
);
2378 if (m
== MATCH_ERROR
)
2386 m
= match_file_element (fp
);
2387 if (m
== MATCH_ERROR
)
2391 m
= gfc_match_expr (&fp
->unit
);
2392 if (m
== MATCH_ERROR
)
2400 if (gfc_match_char (')') == MATCH_YES
)
2402 if (gfc_match_char (',') != MATCH_YES
)
2405 m
= match_file_element (fp
);
2406 if (m
== MATCH_ERROR
)
2413 if (gfc_match_eos () != MATCH_YES
)
2416 if (gfc_pure (NULL
))
2418 gfc_error ("%s statement not allowed in PURE procedure at %C",
2419 gfc_ascii_statement (st
));
2424 if (gfc_implicit_pure (NULL
))
2425 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
2428 new_st
.ext
.filepos
= fp
;
2432 gfc_syntax_error (st
);
2435 gfc_free_filepos (fp
);
2441 gfc_resolve_filepos (gfc_filepos
*fp
)
2443 RESOLVE_TAG (&tag_unit
, fp
->unit
);
2444 RESOLVE_TAG (&tag_iostat
, fp
->iostat
);
2445 RESOLVE_TAG (&tag_iomsg
, fp
->iomsg
);
2446 if (gfc_reference_st_label (fp
->err
, ST_LABEL_TARGET
) == FAILURE
)
2449 if (fp
->unit
->expr_type
== EXPR_CONSTANT
2450 && fp
->unit
->ts
.type
== BT_INTEGER
2451 && mpz_sgn (fp
->unit
->value
.integer
) < 0)
2453 gfc_error ("UNIT number in statement at %L must be non-negative",
2461 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2462 and the FLUSH statement. */
2465 gfc_match_endfile (void)
2467 return match_filepos (ST_END_FILE
, EXEC_ENDFILE
);
2471 gfc_match_backspace (void)
2473 return match_filepos (ST_BACKSPACE
, EXEC_BACKSPACE
);
2477 gfc_match_rewind (void)
2479 return match_filepos (ST_REWIND
, EXEC_REWIND
);
2483 gfc_match_flush (void)
2485 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: FLUSH statement at %C")
2489 return match_filepos (ST_FLUSH
, EXEC_FLUSH
);
2492 /******************** Data Transfer Statements *********************/
2494 /* Return a default unit number. */
2497 default_unit (io_kind k
)
2506 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, unit
);
2510 /* Match a unit specification for a data transfer statement. */
2513 match_dt_unit (io_kind k
, gfc_dt
*dt
)
2517 if (gfc_match_char ('*') == MATCH_YES
)
2519 if (dt
->io_unit
!= NULL
)
2522 dt
->io_unit
= default_unit (k
);
2526 if (gfc_match_expr (&e
) == MATCH_YES
)
2528 if (dt
->io_unit
!= NULL
)
2541 gfc_error ("Duplicate UNIT specification at %C");
2546 /* Match a format specification. */
2549 match_dt_format (gfc_dt
*dt
)
2553 gfc_st_label
*label
;
2556 where
= gfc_current_locus
;
2558 if (gfc_match_char ('*') == MATCH_YES
)
2560 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2563 dt
->format_label
= &format_asterisk
;
2567 if ((m
= gfc_match_st_label (&label
)) == MATCH_YES
)
2571 /* Need to check if the format label is actually either an operand
2572 to a user-defined operator or is a kind type parameter. That is,
2573 print 2.ip.8 ! .ip. is a user-defined operator return CHARACTER.
2574 print 1_'(I0)', i ! 1_'(I0)' is a default character string. */
2576 gfc_gobble_whitespace ();
2577 c
= gfc_peek_ascii_char ();
2578 if (c
== '.' || c
== '_')
2579 gfc_current_locus
= where
;
2582 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2584 gfc_free_st_label (label
);
2588 if (gfc_reference_st_label (label
, ST_LABEL_FORMAT
) == FAILURE
)
2591 dt
->format_label
= label
;
2595 else if (m
== MATCH_ERROR
)
2596 /* The label was zero or too large. Emit the correct diagnosis. */
2599 if (gfc_match_expr (&e
) == MATCH_YES
)
2601 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2606 dt
->format_expr
= e
;
2610 gfc_current_locus
= where
; /* The only case where we have to restore */
2615 gfc_error ("Duplicate format specification at %C");
2620 /* Traverse a namelist that is part of a READ statement to make sure
2621 that none of the variables in the namelist are INTENT(IN). Returns
2622 nonzero if we find such a variable. */
2625 check_namelist (gfc_symbol
*sym
)
2629 for (p
= sym
->namelist
; p
; p
= p
->next
)
2630 if (p
->sym
->attr
.intent
== INTENT_IN
)
2632 gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
2633 p
->sym
->name
, sym
->name
);
2641 /* Match a single data transfer element. */
2644 match_dt_element (io_kind k
, gfc_dt
*dt
)
2646 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2650 if (gfc_match (" unit =") == MATCH_YES
)
2652 m
= match_dt_unit (k
, dt
);
2657 if (gfc_match (" fmt =") == MATCH_YES
)
2659 m
= match_dt_format (dt
);
2664 if (gfc_match (" nml = %n", name
) == MATCH_YES
)
2666 if (dt
->namelist
!= NULL
)
2668 gfc_error ("Duplicate NML specification at %C");
2672 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
2675 if (sym
== NULL
|| sym
->attr
.flavor
!= FL_NAMELIST
)
2677 gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
2678 sym
!= NULL
? sym
->name
: name
);
2683 if (k
== M_READ
&& check_namelist (sym
))
2689 m
= match_etag (&tag_e_async
, &dt
->asynchronous
);
2692 m
= match_etag (&tag_e_blank
, &dt
->blank
);
2695 m
= match_etag (&tag_e_delim
, &dt
->delim
);
2698 m
= match_etag (&tag_e_pad
, &dt
->pad
);
2701 m
= match_etag (&tag_e_sign
, &dt
->sign
);
2704 m
= match_etag (&tag_e_round
, &dt
->round
);
2707 m
= match_out_tag (&tag_id
, &dt
->id
);
2710 m
= match_etag (&tag_e_decimal
, &dt
->decimal
);
2713 m
= match_etag (&tag_rec
, &dt
->rec
);
2716 m
= match_etag (&tag_spos
, &dt
->pos
);
2719 m
= match_out_tag (&tag_iomsg
, &dt
->iomsg
);
2722 m
= match_out_tag (&tag_iostat
, &dt
->iostat
);
2725 m
= match_ltag (&tag_err
, &dt
->err
);
2727 dt
->err_where
= gfc_current_locus
;
2730 m
= match_etag (&tag_advance
, &dt
->advance
);
2733 m
= match_out_tag (&tag_size
, &dt
->size
);
2737 m
= match_ltag (&tag_end
, &dt
->end
);
2742 gfc_error ("END tag at %C not allowed in output statement");
2745 dt
->end_where
= gfc_current_locus
;
2750 m
= match_ltag (&tag_eor
, &dt
->eor
);
2752 dt
->eor_where
= gfc_current_locus
;
2760 /* Free a data transfer structure and everything below it. */
2763 gfc_free_dt (gfc_dt
*dt
)
2768 gfc_free_expr (dt
->io_unit
);
2769 gfc_free_expr (dt
->format_expr
);
2770 gfc_free_expr (dt
->rec
);
2771 gfc_free_expr (dt
->advance
);
2772 gfc_free_expr (dt
->iomsg
);
2773 gfc_free_expr (dt
->iostat
);
2774 gfc_free_expr (dt
->size
);
2775 gfc_free_expr (dt
->pad
);
2776 gfc_free_expr (dt
->delim
);
2777 gfc_free_expr (dt
->sign
);
2778 gfc_free_expr (dt
->round
);
2779 gfc_free_expr (dt
->blank
);
2780 gfc_free_expr (dt
->decimal
);
2781 gfc_free_expr (dt
->pos
);
2782 gfc_free_expr (dt
->dt_io_kind
);
2783 /* dt->extra_comma is a link to dt_io_kind if it is set. */
2788 /* Resolve everything in a gfc_dt structure. */
2791 gfc_resolve_dt (gfc_dt
*dt
, locus
*loc
)
2796 /* This is set in any case. */
2797 gcc_assert (dt
->dt_io_kind
);
2798 k
= dt
->dt_io_kind
->value
.iokind
;
2800 RESOLVE_TAG (&tag_format
, dt
->format_expr
);
2801 RESOLVE_TAG (&tag_rec
, dt
->rec
);
2802 RESOLVE_TAG (&tag_spos
, dt
->pos
);
2803 RESOLVE_TAG (&tag_advance
, dt
->advance
);
2804 RESOLVE_TAG (&tag_id
, dt
->id
);
2805 RESOLVE_TAG (&tag_iomsg
, dt
->iomsg
);
2806 RESOLVE_TAG (&tag_iostat
, dt
->iostat
);
2807 RESOLVE_TAG (&tag_size
, dt
->size
);
2808 RESOLVE_TAG (&tag_e_pad
, dt
->pad
);
2809 RESOLVE_TAG (&tag_e_delim
, dt
->delim
);
2810 RESOLVE_TAG (&tag_e_sign
, dt
->sign
);
2811 RESOLVE_TAG (&tag_e_round
, dt
->round
);
2812 RESOLVE_TAG (&tag_e_blank
, dt
->blank
);
2813 RESOLVE_TAG (&tag_e_decimal
, dt
->decimal
);
2814 RESOLVE_TAG (&tag_e_async
, dt
->asynchronous
);
2819 gfc_error ("UNIT not specified at %L", loc
);
2823 if (gfc_resolve_expr (e
) == SUCCESS
2824 && (e
->ts
.type
!= BT_INTEGER
2825 && (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_VARIABLE
)))
2827 /* If there is no extra comma signifying the "format" form of the IO
2828 statement, then this must be an error. */
2829 if (!dt
->extra_comma
)
2831 gfc_error ("UNIT specification at %L must be an INTEGER expression "
2832 "or a CHARACTER variable", &e
->where
);
2837 /* At this point, we have an extra comma. If io_unit has arrived as
2838 type character, we assume its really the "format" form of the I/O
2839 statement. We set the io_unit to the default unit and format to
2840 the character expression. See F95 Standard section 9.4. */
2841 if (e
->ts
.type
== BT_CHARACTER
&& (k
== M_READ
|| k
== M_PRINT
))
2843 dt
->format_expr
= dt
->io_unit
;
2844 dt
->io_unit
= default_unit (k
);
2846 /* Nullify this pointer now so that a warning/error is not
2847 triggered below for the "Extension". */
2848 dt
->extra_comma
= NULL
;
2853 gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
2854 &dt
->extra_comma
->where
);
2860 if (e
->ts
.type
== BT_CHARACTER
)
2862 if (gfc_has_vector_index (e
))
2864 gfc_error ("Internal unit with vector subscript at %L", &e
->where
);
2868 /* If we are writing, make sure the internal unit can be changed. */
2869 gcc_assert (k
!= M_PRINT
);
2871 && gfc_check_vardef_context (e
, false, false,
2872 _("internal unit in WRITE")) == FAILURE
)
2876 if (e
->rank
&& e
->ts
.type
!= BT_CHARACTER
)
2878 gfc_error ("External IO UNIT cannot be an array at %L", &e
->where
);
2882 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_INTEGER
2883 && mpz_sgn (e
->value
.integer
) < 0)
2885 gfc_error ("UNIT number in statement at %L must be non-negative",
2890 /* If we are reading and have a namelist, check that all namelist symbols
2891 can appear in a variable definition context. */
2892 if (k
== M_READ
&& dt
->namelist
)
2895 for (n
= dt
->namelist
->namelist
; n
; n
= n
->next
)
2900 e
= gfc_get_variable_expr (gfc_find_sym_in_symtree (n
->sym
));
2901 t
= gfc_check_vardef_context (e
, false, false, NULL
);
2906 gfc_error ("NAMELIST '%s' in READ statement at %L contains"
2907 " the symbol '%s' which may not appear in a"
2908 " variable definition context",
2909 dt
->namelist
->name
, loc
, n
->sym
->name
);
2916 && gfc_notify_std (GFC_STD_GNU
, "Extension: Comma before i/o "
2917 "item list at %L", &dt
->extra_comma
->where
) == FAILURE
)
2922 if (gfc_reference_st_label (dt
->err
, ST_LABEL_TARGET
) == FAILURE
)
2924 if (dt
->err
->defined
== ST_LABEL_UNKNOWN
)
2926 gfc_error ("ERR tag label %d at %L not defined",
2927 dt
->err
->value
, &dt
->err_where
);
2934 if (gfc_reference_st_label (dt
->end
, ST_LABEL_TARGET
) == FAILURE
)
2936 if (dt
->end
->defined
== ST_LABEL_UNKNOWN
)
2938 gfc_error ("END tag label %d at %L not defined",
2939 dt
->end
->value
, &dt
->end_where
);
2946 if (gfc_reference_st_label (dt
->eor
, ST_LABEL_TARGET
) == FAILURE
)
2948 if (dt
->eor
->defined
== ST_LABEL_UNKNOWN
)
2950 gfc_error ("EOR tag label %d at %L not defined",
2951 dt
->eor
->value
, &dt
->eor_where
);
2956 /* Check the format label actually exists. */
2957 if (dt
->format_label
&& dt
->format_label
!= &format_asterisk
2958 && dt
->format_label
->defined
== ST_LABEL_UNKNOWN
)
2960 gfc_error ("FORMAT label %d at %L not defined", dt
->format_label
->value
,
2961 &dt
->format_label
->where
);
2969 /* Given an io_kind, return its name. */
2972 io_kind_name (io_kind k
)
2991 gfc_internal_error ("io_kind_name(): bad I/O-kind");
2998 /* Match an IO iteration statement of the form:
3000 ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
3002 which is equivalent to a single IO element. This function is
3003 mutually recursive with match_io_element(). */
3005 static match
match_io_element (io_kind
, gfc_code
**);
3008 match_io_iterator (io_kind k
, gfc_code
**result
)
3010 gfc_code
*head
, *tail
, *new_code
;
3018 old_loc
= gfc_current_locus
;
3020 if (gfc_match_char ('(') != MATCH_YES
)
3023 m
= match_io_element (k
, &head
);
3026 if (m
!= MATCH_YES
|| gfc_match_char (',') != MATCH_YES
)
3032 /* Can't be anything but an IO iterator. Build a list. */
3033 iter
= gfc_get_iterator ();
3037 m
= gfc_match_iterator (iter
, 0);
3038 if (m
== MATCH_ERROR
)
3042 gfc_check_do_variable (iter
->var
->symtree
);
3046 m
= match_io_element (k
, &new_code
);
3047 if (m
== MATCH_ERROR
)
3056 tail
= gfc_append_code (tail
, new_code
);
3058 if (gfc_match_char (',') != MATCH_YES
)
3067 if (gfc_match_char (')') != MATCH_YES
)
3070 new_code
= gfc_get_code ();
3071 new_code
->op
= EXEC_DO
;
3072 new_code
->ext
.iterator
= iter
;
3074 new_code
->block
= gfc_get_code ();
3075 new_code
->block
->op
= EXEC_DO
;
3076 new_code
->block
->next
= head
;
3082 gfc_error ("Syntax error in I/O iterator at %C");
3086 gfc_free_iterator (iter
, 1);
3087 gfc_free_statements (head
);
3088 gfc_current_locus
= old_loc
;
3093 /* Match a single element of an IO list, which is either a single
3094 expression or an IO Iterator. */
3097 match_io_element (io_kind k
, gfc_code
**cpp
)
3105 m
= match_io_iterator (k
, cpp
);
3111 m
= gfc_match_variable (&expr
, 0);
3113 gfc_error ("Expected variable in READ statement at %C");
3117 m
= gfc_match_expr (&expr
);
3119 gfc_error ("Expected expression in %s statement at %C",
3123 if (m
== MATCH_YES
&& k
== M_READ
&& gfc_check_do_variable (expr
->symtree
))
3128 gfc_free_expr (expr
);
3132 cp
= gfc_get_code ();
3133 cp
->op
= EXEC_TRANSFER
;
3136 cp
->ext
.dt
= current_dt
;
3143 /* Match an I/O list, building gfc_code structures as we go. */
3146 match_io_list (io_kind k
, gfc_code
**head_p
)
3148 gfc_code
*head
, *tail
, *new_code
;
3151 *head_p
= head
= tail
= NULL
;
3152 if (gfc_match_eos () == MATCH_YES
)
3157 m
= match_io_element (k
, &new_code
);
3158 if (m
== MATCH_ERROR
)
3163 tail
= gfc_append_code (tail
, new_code
);
3167 if (gfc_match_eos () == MATCH_YES
)
3169 if (gfc_match_char (',') != MATCH_YES
)
3177 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
3180 gfc_free_statements (head
);
3185 /* Attach the data transfer end node. */
3188 terminate_io (gfc_code
*io_code
)
3192 if (io_code
== NULL
)
3193 io_code
= new_st
.block
;
3195 c
= gfc_get_code ();
3196 c
->op
= EXEC_DT_END
;
3198 /* Point to structure that is already there */
3199 c
->ext
.dt
= new_st
.ext
.dt
;
3200 gfc_append_code (io_code
, c
);
3204 /* Check the constraints for a data transfer statement. The majority of the
3205 constraints appearing in 9.4 of the standard appear here. Some are handled
3206 in resolve_tag and others in gfc_resolve_dt. */
3209 check_io_constraints (io_kind k
, gfc_dt
*dt
, gfc_code
*io_code
,
3212 #define io_constraint(condition,msg,arg)\
3215 gfc_error(msg,arg);\
3221 gfc_symbol
*sym
= NULL
;
3222 bool warn
, unformatted
;
3224 warn
= (dt
->err
|| dt
->iostat
) ? true : false;
3225 unformatted
= dt
->format_expr
== NULL
&& dt
->format_label
== NULL
3226 && dt
->namelist
== NULL
;
3231 if (expr
&& expr
->expr_type
== EXPR_VARIABLE
3232 && expr
->ts
.type
== BT_CHARACTER
)
3234 sym
= expr
->symtree
->n
.sym
;
3236 io_constraint (k
== M_WRITE
&& sym
->attr
.intent
== INTENT_IN
,
3237 "Internal file at %L must not be INTENT(IN)",
3240 io_constraint (gfc_has_vector_index (dt
->io_unit
),
3241 "Internal file incompatible with vector subscript at %L",
3244 io_constraint (dt
->rec
!= NULL
,
3245 "REC tag at %L is incompatible with internal file",
3248 io_constraint (dt
->pos
!= NULL
,
3249 "POS tag at %L is incompatible with internal file",
3252 io_constraint (unformatted
,
3253 "Unformatted I/O not allowed with internal unit at %L",
3254 &dt
->io_unit
->where
);
3256 io_constraint (dt
->asynchronous
!= NULL
,
3257 "ASYNCHRONOUS tag at %L not allowed with internal file",
3258 &dt
->asynchronous
->where
);
3260 if (dt
->namelist
!= NULL
)
3262 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Internal file "
3263 "at %L with namelist", &expr
->where
)
3268 io_constraint (dt
->advance
!= NULL
,
3269 "ADVANCE tag at %L is incompatible with internal file",
3270 &dt
->advance
->where
);
3273 if (expr
&& expr
->ts
.type
!= BT_CHARACTER
)
3276 io_constraint (gfc_pure (NULL
) && (k
== M_READ
|| k
== M_WRITE
),
3277 "IO UNIT in %s statement at %C must be "
3278 "an internal file in a PURE procedure",
3281 if (gfc_implicit_pure (NULL
) && (k
== M_READ
|| k
== M_WRITE
))
3282 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3288 io_constraint (dt
->end
, "END tag not allowed with output at %L",
3291 io_constraint (dt
->eor
, "EOR tag not allowed with output at %L",
3294 io_constraint (dt
->blank
, "BLANK= specifier not allowed with output at %L",
3297 io_constraint (dt
->pad
, "PAD= specifier not allowed with output at %L",
3300 io_constraint (dt
->size
, "SIZE= specifier not allowed with output at %L",
3305 io_constraint (dt
->size
&& dt
->advance
== NULL
,
3306 "SIZE tag at %L requires an ADVANCE tag",
3309 io_constraint (dt
->eor
&& dt
->advance
== NULL
,
3310 "EOR tag at %L requires an ADVANCE tag",
3314 if (dt
->asynchronous
)
3316 static const char * asynchronous
[] = { "YES", "NO", NULL
};
3318 if (gfc_reduce_init_expr (dt
->asynchronous
) != SUCCESS
)
3320 gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3321 "expression", &dt
->asynchronous
->where
);
3325 if (!compare_to_allowed_values
3326 ("ASYNCHRONOUS", asynchronous
, NULL
, NULL
,
3327 dt
->asynchronous
->value
.character
.string
,
3328 io_kind_name (k
), warn
))
3336 || gfc_wide_strlen (dt
->asynchronous
->value
.character
.string
) != 3
3337 || gfc_wide_strncasecmp (dt
->asynchronous
->value
.character
.string
,
3339 io_constraint (not_yes
,
3340 "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3341 "specifier", &dt
->id
->where
);
3346 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: DECIMAL= at %C "
3347 "not allowed in Fortran 95") == FAILURE
)
3350 if (dt
->decimal
->expr_type
== EXPR_CONSTANT
)
3352 static const char * decimal
[] = { "COMMA", "POINT", NULL
};
3354 if (!compare_to_allowed_values ("DECIMAL", decimal
, NULL
, NULL
,
3355 dt
->decimal
->value
.character
.string
,
3356 io_kind_name (k
), warn
))
3359 io_constraint (unformatted
,
3360 "the DECIMAL= specifier at %L must be with an "
3361 "explicit format expression", &dt
->decimal
->where
);
3367 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BLANK= at %C "
3368 "not allowed in Fortran 95") == FAILURE
)
3371 if (dt
->blank
->expr_type
== EXPR_CONSTANT
)
3373 static const char * blank
[] = { "NULL", "ZERO", NULL
};
3375 if (!compare_to_allowed_values ("BLANK", blank
, NULL
, NULL
,
3376 dt
->blank
->value
.character
.string
,
3377 io_kind_name (k
), warn
))
3380 io_constraint (unformatted
,
3381 "the BLANK= specifier at %L must be with an "
3382 "explicit format expression", &dt
->blank
->where
);
3388 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PAD= at %C "
3389 "not allowed in Fortran 95") == FAILURE
)
3392 if (dt
->pad
->expr_type
== EXPR_CONSTANT
)
3394 static const char * pad
[] = { "YES", "NO", NULL
};
3396 if (!compare_to_allowed_values ("PAD", pad
, NULL
, NULL
,
3397 dt
->pad
->value
.character
.string
,
3398 io_kind_name (k
), warn
))
3401 io_constraint (unformatted
,
3402 "the PAD= specifier at %L must be with an "
3403 "explicit format expression", &dt
->pad
->where
);
3409 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ROUND= at %C "
3410 "not allowed in Fortran 95") == FAILURE
)
3413 if (dt
->round
->expr_type
== EXPR_CONSTANT
)
3415 static const char * round
[] = { "UP", "DOWN", "ZERO", "NEAREST",
3416 "COMPATIBLE", "PROCESSOR_DEFINED",
3419 if (!compare_to_allowed_values ("ROUND", round
, NULL
, NULL
,
3420 dt
->round
->value
.character
.string
,
3421 io_kind_name (k
), warn
))
3428 /* When implemented, change the following to use gfc_notify_std F2003.
3429 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
3430 "not allowed in Fortran 95") == FAILURE)
3431 return MATCH_ERROR; */
3432 if (dt
->sign
->expr_type
== EXPR_CONSTANT
)
3434 static const char * sign
[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3437 if (!compare_to_allowed_values ("SIGN", sign
, NULL
, NULL
,
3438 dt
->sign
->value
.character
.string
,
3439 io_kind_name (k
), warn
))
3442 io_constraint (unformatted
,
3443 "SIGN= specifier at %L must be with an "
3444 "explicit format expression", &dt
->sign
->where
);
3446 io_constraint (k
== M_READ
,
3447 "SIGN= specifier at %L not allowed in a "
3448 "READ statement", &dt
->sign
->where
);
3454 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: DELIM= at %C "
3455 "not allowed in Fortran 95") == FAILURE
)
3458 if (dt
->delim
->expr_type
== EXPR_CONSTANT
)
3460 static const char *delim
[] = { "APOSTROPHE", "QUOTE", "NONE", NULL
};
3462 if (!compare_to_allowed_values ("DELIM", delim
, NULL
, NULL
,
3463 dt
->delim
->value
.character
.string
,
3464 io_kind_name (k
), warn
))
3467 io_constraint (k
== M_READ
,
3468 "DELIM= specifier at %L not allowed in a "
3469 "READ statement", &dt
->delim
->where
);
3471 io_constraint (dt
->format_label
!= &format_asterisk
3472 && dt
->namelist
== NULL
,
3473 "DELIM= specifier at %L must have FMT=*",
3476 io_constraint (unformatted
&& dt
->namelist
== NULL
,
3477 "DELIM= specifier at %L must be with FMT=* or "
3478 "NML= specifier ", &dt
->delim
->where
);
3484 io_constraint (io_code
&& dt
->namelist
,
3485 "NAMELIST cannot be followed by IO-list at %L",
3488 io_constraint (dt
->format_expr
,
3489 "IO spec-list cannot contain both NAMELIST group name "
3490 "and format specification at %L",
3491 &dt
->format_expr
->where
);
3493 io_constraint (dt
->format_label
,
3494 "IO spec-list cannot contain both NAMELIST group name "
3495 "and format label at %L", spec_end
);
3497 io_constraint (dt
->rec
,
3498 "NAMELIST IO is not allowed with a REC= specifier "
3499 "at %L", &dt
->rec
->where
);
3501 io_constraint (dt
->advance
,
3502 "NAMELIST IO is not allowed with a ADVANCE= specifier "
3503 "at %L", &dt
->advance
->where
);
3508 io_constraint (dt
->end
,
3509 "An END tag is not allowed with a "
3510 "REC= specifier at %L", &dt
->end_where
);
3512 io_constraint (dt
->format_label
== &format_asterisk
,
3513 "FMT=* is not allowed with a REC= specifier "
3516 io_constraint (dt
->pos
,
3517 "POS= is not allowed with REC= specifier "
3518 "at %L", &dt
->pos
->where
);
3523 int not_yes
, not_no
;
3526 io_constraint (dt
->format_label
== &format_asterisk
,
3527 "List directed format(*) is not allowed with a "
3528 "ADVANCE= specifier at %L.", &expr
->where
);
3530 io_constraint (unformatted
,
3531 "the ADVANCE= specifier at %L must appear with an "
3532 "explicit format expression", &expr
->where
);
3534 if (expr
->expr_type
== EXPR_CONSTANT
&& expr
->ts
.type
== BT_CHARACTER
)
3536 const gfc_char_t
*advance
= expr
->value
.character
.string
;
3537 not_no
= gfc_wide_strlen (advance
) != 2
3538 || gfc_wide_strncasecmp (advance
, "no", 2) != 0;
3539 not_yes
= gfc_wide_strlen (advance
) != 3
3540 || gfc_wide_strncasecmp (advance
, "yes", 3) != 0;
3548 io_constraint (not_no
&& not_yes
,
3549 "ADVANCE= specifier at %L must have value = "
3550 "YES or NO.", &expr
->where
);
3552 io_constraint (dt
->size
&& not_no
&& k
== M_READ
,
3553 "SIZE tag at %L requires an ADVANCE = 'NO'",
3556 io_constraint (dt
->eor
&& not_no
&& k
== M_READ
,
3557 "EOR tag at %L requires an ADVANCE = 'NO'",
3561 expr
= dt
->format_expr
;
3562 if (gfc_simplify_expr (expr
, 0) == FAILURE
3563 || check_format_string (expr
, k
== M_READ
) == FAILURE
)
3568 #undef io_constraint
3571 /* Match a READ, WRITE or PRINT statement. */
3574 match_io (io_kind k
)
3576 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3585 where
= gfc_current_locus
;
3587 current_dt
= dt
= XCNEW (gfc_dt
);
3588 m
= gfc_match_char ('(');
3591 where
= gfc_current_locus
;
3594 else if (k
== M_PRINT
)
3596 /* Treat the non-standard case of PRINT namelist. */
3597 if ((gfc_current_form
== FORM_FIXED
|| gfc_peek_ascii_char () == ' ')
3598 && gfc_match_name (name
) == MATCH_YES
)
3600 gfc_find_symbol (name
, NULL
, 1, &sym
);
3601 if (sym
&& sym
->attr
.flavor
== FL_NAMELIST
)
3603 if (gfc_notify_std (GFC_STD_GNU
, "PRINT namelist at "
3604 "%C is an extension") == FAILURE
)
3610 dt
->io_unit
= default_unit (k
);
3615 gfc_current_locus
= where
;
3619 if (gfc_current_form
== FORM_FREE
)
3621 char c
= gfc_peek_ascii_char ();
3622 if (c
!= ' ' && c
!= '*' && c
!= '\'' && c
!= '"')
3629 m
= match_dt_format (dt
);
3630 if (m
== MATCH_ERROR
)
3636 dt
->io_unit
= default_unit (k
);
3641 /* Before issuing an error for a malformed 'print (1,*)' type of
3642 error, check for a default-char-expr of the form ('(I0)'). */
3643 if (k
== M_PRINT
&& m
== MATCH_YES
)
3645 /* Reset current locus to get the initial '(' in an expression. */
3646 gfc_current_locus
= where
;
3647 dt
->format_expr
= NULL
;
3648 m
= match_dt_format (dt
);
3650 if (m
== MATCH_ERROR
)
3652 if (m
== MATCH_NO
|| dt
->format_expr
== NULL
)
3656 dt
->io_unit
= default_unit (k
);
3661 /* Match a control list */
3662 if (match_dt_element (k
, dt
) == MATCH_YES
)
3664 if (match_dt_unit (k
, dt
) != MATCH_YES
)
3667 if (gfc_match_char (')') == MATCH_YES
)
3669 if (gfc_match_char (',') != MATCH_YES
)
3672 m
= match_dt_element (k
, dt
);
3675 if (m
== MATCH_ERROR
)
3678 m
= match_dt_format (dt
);
3681 if (m
== MATCH_ERROR
)
3684 where
= gfc_current_locus
;
3686 m
= gfc_match_name (name
);
3689 gfc_find_symbol (name
, NULL
, 1, &sym
);
3690 if (sym
&& sym
->attr
.flavor
== FL_NAMELIST
)
3693 if (k
== M_READ
&& check_namelist (sym
))
3702 gfc_current_locus
= where
;
3704 goto loop
; /* No matches, try regular elements */
3707 if (gfc_match_char (')') == MATCH_YES
)
3709 if (gfc_match_char (',') != MATCH_YES
)
3715 m
= match_dt_element (k
, dt
);
3718 if (m
== MATCH_ERROR
)
3721 if (gfc_match_char (')') == MATCH_YES
)
3723 if (gfc_match_char (',') != MATCH_YES
)
3729 /* Used in check_io_constraints, where no locus is available. */
3730 spec_end
= gfc_current_locus
;
3732 /* Save the IO kind for later use. */
3733 dt
->dt_io_kind
= gfc_get_iokind_expr (&gfc_current_locus
, k
);
3735 /* Optional leading comma (non-standard). We use a gfc_expr structure here
3736 to save the locus. This is used later when resolving transfer statements
3737 that might have a format expression without unit number. */
3738 if (!comma_flag
&& gfc_match_char (',') == MATCH_YES
)
3739 dt
->extra_comma
= dt
->dt_io_kind
;
3742 if (gfc_match_eos () != MATCH_YES
)
3744 if (comma_flag
&& gfc_match_char (',') != MATCH_YES
)
3746 gfc_error ("Expected comma in I/O list at %C");
3751 m
= match_io_list (k
, &io_code
);
3752 if (m
== MATCH_ERROR
)
3758 /* A full IO statement has been matched. Check the constraints. spec_end is
3759 supplied for cases where no locus is supplied. */
3760 m
= check_io_constraints (k
, dt
, io_code
, &spec_end
);
3762 if (m
== MATCH_ERROR
)
3765 new_st
.op
= (k
== M_READ
) ? EXEC_READ
: EXEC_WRITE
;
3767 new_st
.block
= gfc_get_code ();
3768 new_st
.block
->op
= new_st
.op
;
3769 new_st
.block
->next
= io_code
;
3771 terminate_io (io_code
);
3776 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
3786 gfc_match_read (void)
3788 return match_io (M_READ
);
3793 gfc_match_write (void)
3795 return match_io (M_WRITE
);
3800 gfc_match_print (void)
3804 m
= match_io (M_PRINT
);
3808 if (gfc_pure (NULL
))
3810 gfc_error ("PRINT statement at %C not allowed within PURE procedure");
3814 if (gfc_implicit_pure (NULL
))
3815 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3821 /* Free a gfc_inquire structure. */
3824 gfc_free_inquire (gfc_inquire
*inquire
)
3827 if (inquire
== NULL
)
3830 gfc_free_expr (inquire
->unit
);
3831 gfc_free_expr (inquire
->file
);
3832 gfc_free_expr (inquire
->iomsg
);
3833 gfc_free_expr (inquire
->iostat
);
3834 gfc_free_expr (inquire
->exist
);
3835 gfc_free_expr (inquire
->opened
);
3836 gfc_free_expr (inquire
->number
);
3837 gfc_free_expr (inquire
->named
);
3838 gfc_free_expr (inquire
->name
);
3839 gfc_free_expr (inquire
->access
);
3840 gfc_free_expr (inquire
->sequential
);
3841 gfc_free_expr (inquire
->direct
);
3842 gfc_free_expr (inquire
->form
);
3843 gfc_free_expr (inquire
->formatted
);
3844 gfc_free_expr (inquire
->unformatted
);
3845 gfc_free_expr (inquire
->recl
);
3846 gfc_free_expr (inquire
->nextrec
);
3847 gfc_free_expr (inquire
->blank
);
3848 gfc_free_expr (inquire
->position
);
3849 gfc_free_expr (inquire
->action
);
3850 gfc_free_expr (inquire
->read
);
3851 gfc_free_expr (inquire
->write
);
3852 gfc_free_expr (inquire
->readwrite
);
3853 gfc_free_expr (inquire
->delim
);
3854 gfc_free_expr (inquire
->encoding
);
3855 gfc_free_expr (inquire
->pad
);
3856 gfc_free_expr (inquire
->iolength
);
3857 gfc_free_expr (inquire
->convert
);
3858 gfc_free_expr (inquire
->strm_pos
);
3859 gfc_free_expr (inquire
->asynchronous
);
3860 gfc_free_expr (inquire
->decimal
);
3861 gfc_free_expr (inquire
->pending
);
3862 gfc_free_expr (inquire
->id
);
3863 gfc_free_expr (inquire
->sign
);
3864 gfc_free_expr (inquire
->size
);
3865 gfc_free_expr (inquire
->round
);
3870 /* Match an element of an INQUIRE statement. */
3872 #define RETM if (m != MATCH_NO) return m;
3875 match_inquire_element (gfc_inquire
*inquire
)
3879 m
= match_etag (&tag_unit
, &inquire
->unit
);
3880 RETM m
= match_etag (&tag_file
, &inquire
->file
);
3881 RETM m
= match_ltag (&tag_err
, &inquire
->err
);
3882 RETM m
= match_out_tag (&tag_iomsg
, &inquire
->iomsg
);
3883 RETM m
= match_out_tag (&tag_iostat
, &inquire
->iostat
);
3884 RETM m
= match_vtag (&tag_exist
, &inquire
->exist
);
3885 RETM m
= match_vtag (&tag_opened
, &inquire
->opened
);
3886 RETM m
= match_vtag (&tag_named
, &inquire
->named
);
3887 RETM m
= match_vtag (&tag_name
, &inquire
->name
);
3888 RETM m
= match_out_tag (&tag_number
, &inquire
->number
);
3889 RETM m
= match_vtag (&tag_s_access
, &inquire
->access
);
3890 RETM m
= match_vtag (&tag_sequential
, &inquire
->sequential
);
3891 RETM m
= match_vtag (&tag_direct
, &inquire
->direct
);
3892 RETM m
= match_vtag (&tag_s_form
, &inquire
->form
);
3893 RETM m
= match_vtag (&tag_formatted
, &inquire
->formatted
);
3894 RETM m
= match_vtag (&tag_unformatted
, &inquire
->unformatted
);
3895 RETM m
= match_out_tag (&tag_s_recl
, &inquire
->recl
);
3896 RETM m
= match_out_tag (&tag_nextrec
, &inquire
->nextrec
);
3897 RETM m
= match_vtag (&tag_s_blank
, &inquire
->blank
);
3898 RETM m
= match_vtag (&tag_s_position
, &inquire
->position
);
3899 RETM m
= match_vtag (&tag_s_action
, &inquire
->action
);
3900 RETM m
= match_vtag (&tag_read
, &inquire
->read
);
3901 RETM m
= match_vtag (&tag_write
, &inquire
->write
);
3902 RETM m
= match_vtag (&tag_readwrite
, &inquire
->readwrite
);
3903 RETM m
= match_vtag (&tag_s_async
, &inquire
->asynchronous
);
3904 RETM m
= match_vtag (&tag_s_delim
, &inquire
->delim
);
3905 RETM m
= match_vtag (&tag_s_decimal
, &inquire
->decimal
);
3906 RETM m
= match_vtag (&tag_size
, &inquire
->size
);
3907 RETM m
= match_vtag (&tag_s_encoding
, &inquire
->encoding
);
3908 RETM m
= match_vtag (&tag_s_round
, &inquire
->round
);
3909 RETM m
= match_vtag (&tag_s_sign
, &inquire
->sign
);
3910 RETM m
= match_vtag (&tag_s_pad
, &inquire
->pad
);
3911 RETM m
= match_vtag (&tag_iolength
, &inquire
->iolength
);
3912 RETM m
= match_vtag (&tag_convert
, &inquire
->convert
);
3913 RETM m
= match_out_tag (&tag_strm_out
, &inquire
->strm_pos
);
3914 RETM m
= match_vtag (&tag_pending
, &inquire
->pending
);
3915 RETM m
= match_vtag (&tag_id
, &inquire
->id
);
3916 RETM
return MATCH_NO
;
3923 gfc_match_inquire (void)
3925 gfc_inquire
*inquire
;
3930 m
= gfc_match_char ('(');
3934 inquire
= XCNEW (gfc_inquire
);
3936 loc
= gfc_current_locus
;
3938 m
= match_inquire_element (inquire
);
3939 if (m
== MATCH_ERROR
)
3943 m
= gfc_match_expr (&inquire
->unit
);
3944 if (m
== MATCH_ERROR
)
3950 /* See if we have the IOLENGTH form of the inquire statement. */
3951 if (inquire
->iolength
!= NULL
)
3953 if (gfc_match_char (')') != MATCH_YES
)
3956 m
= match_io_list (M_INQUIRE
, &code
);
3957 if (m
== MATCH_ERROR
)
3962 new_st
.op
= EXEC_IOLENGTH
;
3963 new_st
.expr1
= inquire
->iolength
;
3964 new_st
.ext
.inquire
= inquire
;
3966 if (gfc_pure (NULL
))
3968 gfc_free_statements (code
);
3969 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3973 if (gfc_implicit_pure (NULL
))
3974 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3976 new_st
.block
= gfc_get_code ();
3977 new_st
.block
->op
= EXEC_IOLENGTH
;
3978 terminate_io (code
);
3979 new_st
.block
->next
= code
;
3983 /* At this point, we have the non-IOLENGTH inquire statement. */
3986 if (gfc_match_char (')') == MATCH_YES
)
3988 if (gfc_match_char (',') != MATCH_YES
)
3991 m
= match_inquire_element (inquire
);
3992 if (m
== MATCH_ERROR
)
3997 if (inquire
->iolength
!= NULL
)
3999 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
4004 if (gfc_match_eos () != MATCH_YES
)
4007 if (inquire
->unit
!= NULL
&& inquire
->file
!= NULL
)
4009 gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
4010 "UNIT specifiers", &loc
);
4014 if (inquire
->unit
== NULL
&& inquire
->file
== NULL
)
4016 gfc_error ("INQUIRE statement at %L requires either FILE or "
4017 "UNIT specifier", &loc
);
4021 if (gfc_pure (NULL
))
4023 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4027 if (gfc_implicit_pure (NULL
))
4028 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
4030 if (inquire
->id
!= NULL
&& inquire
->pending
== NULL
)
4032 gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
4033 "the ID= specifier", &loc
);
4037 new_st
.op
= EXEC_INQUIRE
;
4038 new_st
.ext
.inquire
= inquire
;
4042 gfc_syntax_error (ST_INQUIRE
);
4045 gfc_free_inquire (inquire
);
4050 /* Resolve everything in a gfc_inquire structure. */
4053 gfc_resolve_inquire (gfc_inquire
*inquire
)
4055 RESOLVE_TAG (&tag_unit
, inquire
->unit
);
4056 RESOLVE_TAG (&tag_file
, inquire
->file
);
4057 RESOLVE_TAG (&tag_id
, inquire
->id
);
4059 /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4060 contexts. Thus, use an extended RESOLVE_TAG macro for that. */
4061 #define INQUIRE_RESOLVE_TAG(tag, expr) \
4062 RESOLVE_TAG (tag, expr); \
4066 sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
4067 if (gfc_check_vardef_context ((expr), false, false, context) == FAILURE) \
4070 INQUIRE_RESOLVE_TAG (&tag_iomsg
, inquire
->iomsg
);
4071 INQUIRE_RESOLVE_TAG (&tag_iostat
, inquire
->iostat
);
4072 INQUIRE_RESOLVE_TAG (&tag_exist
, inquire
->exist
);
4073 INQUIRE_RESOLVE_TAG (&tag_opened
, inquire
->opened
);
4074 INQUIRE_RESOLVE_TAG (&tag_number
, inquire
->number
);
4075 INQUIRE_RESOLVE_TAG (&tag_named
, inquire
->named
);
4076 INQUIRE_RESOLVE_TAG (&tag_name
, inquire
->name
);
4077 INQUIRE_RESOLVE_TAG (&tag_s_access
, inquire
->access
);
4078 INQUIRE_RESOLVE_TAG (&tag_sequential
, inquire
->sequential
);
4079 INQUIRE_RESOLVE_TAG (&tag_direct
, inquire
->direct
);
4080 INQUIRE_RESOLVE_TAG (&tag_s_form
, inquire
->form
);
4081 INQUIRE_RESOLVE_TAG (&tag_formatted
, inquire
->formatted
);
4082 INQUIRE_RESOLVE_TAG (&tag_unformatted
, inquire
->unformatted
);
4083 INQUIRE_RESOLVE_TAG (&tag_s_recl
, inquire
->recl
);
4084 INQUIRE_RESOLVE_TAG (&tag_nextrec
, inquire
->nextrec
);
4085 INQUIRE_RESOLVE_TAG (&tag_s_blank
, inquire
->blank
);
4086 INQUIRE_RESOLVE_TAG (&tag_s_position
, inquire
->position
);
4087 INQUIRE_RESOLVE_TAG (&tag_s_action
, inquire
->action
);
4088 INQUIRE_RESOLVE_TAG (&tag_read
, inquire
->read
);
4089 INQUIRE_RESOLVE_TAG (&tag_write
, inquire
->write
);
4090 INQUIRE_RESOLVE_TAG (&tag_readwrite
, inquire
->readwrite
);
4091 INQUIRE_RESOLVE_TAG (&tag_s_delim
, inquire
->delim
);
4092 INQUIRE_RESOLVE_TAG (&tag_s_pad
, inquire
->pad
);
4093 INQUIRE_RESOLVE_TAG (&tag_s_encoding
, inquire
->encoding
);
4094 INQUIRE_RESOLVE_TAG (&tag_s_round
, inquire
->round
);
4095 INQUIRE_RESOLVE_TAG (&tag_iolength
, inquire
->iolength
);
4096 INQUIRE_RESOLVE_TAG (&tag_convert
, inquire
->convert
);
4097 INQUIRE_RESOLVE_TAG (&tag_strm_out
, inquire
->strm_pos
);
4098 INQUIRE_RESOLVE_TAG (&tag_s_async
, inquire
->asynchronous
);
4099 INQUIRE_RESOLVE_TAG (&tag_s_sign
, inquire
->sign
);
4100 INQUIRE_RESOLVE_TAG (&tag_s_round
, inquire
->round
);
4101 INQUIRE_RESOLVE_TAG (&tag_pending
, inquire
->pending
);
4102 INQUIRE_RESOLVE_TAG (&tag_size
, inquire
->size
);
4103 INQUIRE_RESOLVE_TAG (&tag_s_decimal
, inquire
->decimal
);
4104 #undef INQUIRE_RESOLVE_TAG
4106 if (gfc_reference_st_label (inquire
->err
, ST_LABEL_TARGET
) == FAILURE
)
4114 gfc_free_wait (gfc_wait
*wait
)
4119 gfc_free_expr (wait
->unit
);
4120 gfc_free_expr (wait
->iostat
);
4121 gfc_free_expr (wait
->iomsg
);
4122 gfc_free_expr (wait
->id
);
4127 gfc_resolve_wait (gfc_wait
*wait
)
4129 RESOLVE_TAG (&tag_unit
, wait
->unit
);
4130 RESOLVE_TAG (&tag_iomsg
, wait
->iomsg
);
4131 RESOLVE_TAG (&tag_iostat
, wait
->iostat
);
4132 RESOLVE_TAG (&tag_id
, wait
->id
);
4134 if (gfc_reference_st_label (wait
->err
, ST_LABEL_TARGET
) == FAILURE
)
4137 if (gfc_reference_st_label (wait
->end
, ST_LABEL_TARGET
) == FAILURE
)
4143 /* Match an element of a WAIT statement. */
4145 #define RETM if (m != MATCH_NO) return m;
4148 match_wait_element (gfc_wait
*wait
)
4152 m
= match_etag (&tag_unit
, &wait
->unit
);
4153 RETM m
= match_ltag (&tag_err
, &wait
->err
);
4154 RETM m
= match_ltag (&tag_end
, &wait
->eor
);
4155 RETM m
= match_ltag (&tag_eor
, &wait
->end
);
4156 RETM m
= match_out_tag (&tag_iomsg
, &wait
->iomsg
);
4157 RETM m
= match_out_tag (&tag_iostat
, &wait
->iostat
);
4158 RETM m
= match_etag (&tag_id
, &wait
->id
);
4159 RETM
return MATCH_NO
;
4166 gfc_match_wait (void)
4171 m
= gfc_match_char ('(');
4175 wait
= XCNEW (gfc_wait
);
4177 m
= match_wait_element (wait
);
4178 if (m
== MATCH_ERROR
)
4182 m
= gfc_match_expr (&wait
->unit
);
4183 if (m
== MATCH_ERROR
)
4191 if (gfc_match_char (')') == MATCH_YES
)
4193 if (gfc_match_char (',') != MATCH_YES
)
4196 m
= match_wait_element (wait
);
4197 if (m
== MATCH_ERROR
)
4203 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: WAIT at %C "
4204 "not allowed in Fortran 95") == FAILURE
)
4207 if (gfc_pure (NULL
))
4209 gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4213 if (gfc_implicit_pure (NULL
))
4214 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
4216 new_st
.op
= EXEC_WAIT
;
4217 new_st
.ext
.wait
= wait
;
4222 gfc_syntax_error (ST_WAIT
);
4225 gfc_free_wait (wait
);