1 /* Deal with I/O statements & related stuff.
2 Copyright (C) 2000-2013 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
30 format_asterisk
= {0, NULL
, NULL
, -1, ST_LABEL_FORMAT
, ST_LABEL_FORMAT
, NULL
,
35 const char *name
, *spec
, *value
;
41 tag_file
= {"FILE", " file =", " %e", BT_CHARACTER
},
42 tag_status
= {"STATUS", " status =", " %e", BT_CHARACTER
},
43 tag_e_access
= {"ACCESS", " access =", " %e", BT_CHARACTER
},
44 tag_e_form
= {"FORM", " form =", " %e", BT_CHARACTER
},
45 tag_e_recl
= {"RECL", " recl =", " %e", BT_INTEGER
},
46 tag_e_blank
= {"BLANK", " blank =", " %e", BT_CHARACTER
},
47 tag_e_position
= {"POSITION", " position =", " %e", BT_CHARACTER
},
48 tag_e_action
= {"ACTION", " action =", " %e", BT_CHARACTER
},
49 tag_e_delim
= {"DELIM", " delim =", " %e", BT_CHARACTER
},
50 tag_e_pad
= {"PAD", " pad =", " %e", BT_CHARACTER
},
51 tag_e_decimal
= {"DECIMAL", " decimal =", " %e", BT_CHARACTER
},
52 tag_e_encoding
= {"ENCODING", " encoding =", " %e", BT_CHARACTER
},
53 tag_e_async
= {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER
},
54 tag_e_round
= {"ROUND", " round =", " %e", BT_CHARACTER
},
55 tag_e_sign
= {"SIGN", " sign =", " %e", BT_CHARACTER
},
56 tag_unit
= {"UNIT", " unit =", " %e", BT_INTEGER
},
57 tag_advance
= {"ADVANCE", " advance =", " %e", BT_CHARACTER
},
58 tag_rec
= {"REC", " rec =", " %e", BT_INTEGER
},
59 tag_spos
= {"POSITION", " pos =", " %e", BT_INTEGER
},
60 tag_format
= {"FORMAT", NULL
, NULL
, BT_CHARACTER
},
61 tag_iomsg
= {"IOMSG", " iomsg =", " %e", BT_CHARACTER
},
62 tag_iostat
= {"IOSTAT", " iostat =", " %v", BT_INTEGER
},
63 tag_size
= {"SIZE", " size =", " %v", BT_INTEGER
},
64 tag_exist
= {"EXIST", " exist =", " %v", BT_LOGICAL
},
65 tag_opened
= {"OPENED", " opened =", " %v", BT_LOGICAL
},
66 tag_named
= {"NAMED", " named =", " %v", BT_LOGICAL
},
67 tag_name
= {"NAME", " name =", " %v", BT_CHARACTER
},
68 tag_number
= {"NUMBER", " number =", " %v", BT_INTEGER
},
69 tag_s_access
= {"ACCESS", " access =", " %v", BT_CHARACTER
},
70 tag_sequential
= {"SEQUENTIAL", " sequential =", " %v", BT_CHARACTER
},
71 tag_direct
= {"DIRECT", " direct =", " %v", BT_CHARACTER
},
72 tag_s_form
= {"FORM", " form =", " %v", BT_CHARACTER
},
73 tag_formatted
= {"FORMATTED", " formatted =", " %v", BT_CHARACTER
},
74 tag_unformatted
= {"UNFORMATTED", " unformatted =", " %v", BT_CHARACTER
},
75 tag_s_recl
= {"RECL", " recl =", " %v", BT_INTEGER
},
76 tag_nextrec
= {"NEXTREC", " nextrec =", " %v", BT_INTEGER
},
77 tag_s_blank
= {"BLANK", " blank =", " %v", BT_CHARACTER
},
78 tag_s_position
= {"POSITION", " position =", " %v", BT_CHARACTER
},
79 tag_s_action
= {"ACTION", " action =", " %v", BT_CHARACTER
},
80 tag_read
= {"READ", " read =", " %v", BT_CHARACTER
},
81 tag_write
= {"WRITE", " write =", " %v", BT_CHARACTER
},
82 tag_readwrite
= {"READWRITE", " readwrite =", " %v", BT_CHARACTER
},
83 tag_s_delim
= {"DELIM", " delim =", " %v", BT_CHARACTER
},
84 tag_s_pad
= {"PAD", " pad =", " %v", BT_CHARACTER
},
85 tag_s_decimal
= {"DECIMAL", " decimal =", " %v", BT_CHARACTER
},
86 tag_s_encoding
= {"ENCODING", " encoding =", " %v", BT_CHARACTER
},
87 tag_s_async
= {"ASYNCHRONOUS", " asynchronous =", " %v", BT_CHARACTER
},
88 tag_s_round
= {"ROUND", " round =", " %v", BT_CHARACTER
},
89 tag_s_sign
= {"SIGN", " sign =", " %v", BT_CHARACTER
},
90 tag_iolength
= {"IOLENGTH", " iolength =", " %v", BT_INTEGER
},
91 tag_convert
= {"CONVERT", " convert =", " %e", BT_CHARACTER
},
92 tag_strm_out
= {"POS", " pos =", " %v", BT_INTEGER
},
93 tag_err
= {"ERR", " err =", " %l", BT_UNKNOWN
},
94 tag_end
= {"END", " end =", " %l", BT_UNKNOWN
},
95 tag_eor
= {"EOR", " eor =", " %l", BT_UNKNOWN
},
96 tag_id
= {"ID", " id =", " %v", BT_INTEGER
},
97 tag_pending
= {"PENDING", " pending =", " %v", BT_LOGICAL
},
98 tag_newunit
= {"NEWUNIT", " newunit =", " %v", BT_INTEGER
},
99 tag_s_iqstream
= {"STREAM", " stream =", " %v", BT_CHARACTER
};
101 static gfc_dt
*current_dt
;
103 #define RESOLVE_TAG(x, y) if (resolve_tag(x, y) == 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
);
248 c
= next_char_not_space (&error
);
259 c
= next_char_not_space (&error
);
261 value
= 10 * value
+ c
- '0';
270 token
= FMT_SIGNED_INT
;
289 c
= next_char_not_space (&error
);
292 value
= 10 * value
+ c
- '0';
300 token
= zflag
? FMT_ZERO
: FMT_POSINT
;
324 c
= next_char_not_space (&error
);
352 c
= next_char_not_space (&error
);
353 if (c
!= 'P' && c
!= 'S')
360 c
= next_char_not_space (&error
);
361 if (c
== 'N' || c
== 'Z')
379 c
= next_char (INSTRING_WARN
);
388 c
= next_char (INSTRING_NOWARN
);
422 c
= next_char_not_space (&error
);
452 c
= next_char_not_space (&error
);
455 if (gfc_notify_std (GFC_STD_F2003
, "DP format "
456 "specifier not allowed at %C") == FAILURE
)
462 if (gfc_notify_std (GFC_STD_F2003
, "DC format "
463 "specifier not allowed at %C") == FAILURE
)
475 c
= next_char_not_space (&error
);
524 token_to_string (format_token t
)
543 /* Check a format statement. The format string, either from a FORMAT
544 statement or a constant in an I/O statement has already been parsed
545 by itself, and we are checking it for validity. The dual origin
546 means that the warning message is a little less than great. */
549 check_format (bool is_input
)
551 const char *posint_required
= _("Positive width required");
552 const char *nonneg_required
= _("Nonnegative width required");
553 const char *unexpected_element
= _("Unexpected element '%c' in format string"
555 const char *unexpected_end
= _("Unexpected end of format string");
556 const char *zero_width
= _("Zero width in format descriptor");
565 saved_token
= FMT_NONE
;
569 format_string_pos
= 0;
576 error
= _("Missing leading left parenthesis");
584 goto finished
; /* Empty format is legal */
588 /* In this state, the next thing has to be a format item. */
605 error
= _("Left parenthesis required after '*'");
630 /* Signed integer can only precede a P format. */
636 error
= _("Expected P edit descriptor");
643 /* P requires a prior number. */
644 error
= _("P descriptor requires leading scale factor");
648 /* X requires a prior number if we're being pedantic. */
649 if (mode
!= MODE_FORMAT
)
650 format_locus
.nextc
+= format_string_pos
;
651 if (gfc_notify_std (GFC_STD_GNU
, "X descriptor "
652 "requires leading space count at %L", &format_locus
)
670 goto extension_optional_comma
;
681 if (gfc_notify_std (GFC_STD_GNU
, "$ descriptor at %L",
682 &format_locus
) == FAILURE
)
684 if (t
!= FMT_RPAREN
|| level
> 0)
686 gfc_warning ("$ should be the last specifier in format at %L",
688 goto optional_comma_1
;
709 error
= unexpected_end
;
713 error
= unexpected_element
;
718 /* In this state, t must currently be a data descriptor.
719 Deal with things that can/must follow the descriptor. */
730 /* No comma after P allowed only for F, E, EN, ES, D, or G.
735 if (!(gfc_option
.allow_std
& GFC_STD_F2003
) && t
!= FMT_COMMA
736 && t
!= FMT_F
&& t
!= FMT_E
&& t
!= FMT_EN
&& t
!= FMT_ES
737 && t
!= FMT_D
&& t
!= FMT_G
&& t
!= FMT_RPAREN
&& t
!= FMT_SLASH
)
739 error
= _("Comma required after P descriptor");
750 if (t
!= FMT_F
&& t
!= FMT_E
&& t
!= FMT_EN
&& t
!= FMT_ES
&& t
!= FMT_D
751 && t
!= FMT_G
&& t
!= FMT_RPAREN
&& t
!= FMT_SLASH
)
753 error
= _("Comma required after P descriptor");
767 error
= _("Positive width required with T descriptor");
779 switch (gfc_notification_std (GFC_STD_GNU
))
782 if (mode
!= MODE_FORMAT
)
783 format_locus
.nextc
+= format_string_pos
;
784 gfc_warning ("Extension: Missing positive width after L "
785 "descriptor at %L", &format_locus
);
790 error
= posint_required
;
821 if (t
== FMT_G
&& u
== FMT_ZERO
)
828 if (gfc_notify_std (GFC_STD_F2008
, "'G0' in "
829 "format at %L", &format_locus
) == FAILURE
)
840 error
= posint_required
;
846 error
= _("E specifier not allowed with g0 descriptor");
855 format_locus
.nextc
+= format_string_pos
;
856 gfc_error ("Positive width required in format "
857 "specifier %s at %L", token_to_string (t
),
868 /* Warn if -std=legacy, otherwise error. */
869 format_locus
.nextc
+= format_string_pos
;
870 if (gfc_option
.warn_std
!= 0)
872 gfc_error ("Period required in format "
873 "specifier %s at %L", token_to_string (t
),
879 gfc_warning ("Period required in format "
880 "specifier %s at %L", token_to_string (t
),
882 /* If we go to finished, we need to unwind this
883 before the next round. */
884 format_locus
.nextc
-= format_string_pos
;
892 if (u
!= FMT_ZERO
&& u
!= FMT_POSINT
)
894 error
= nonneg_required
;
901 /* Look for optional exponent. */
916 error
= _("Positive exponent width required");
927 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
929 error
= nonneg_required
;
932 else if (is_input
&& t
== FMT_ZERO
)
934 error
= posint_required
;
943 /* Warn if -std=legacy, otherwise error. */
944 if (gfc_option
.warn_std
!= 0)
946 error
= _("Period required in format specifier");
949 if (mode
!= MODE_FORMAT
)
950 format_locus
.nextc
+= format_string_pos
;
951 gfc_warning ("Period required in format specifier at %L",
960 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
962 error
= nonneg_required
;
969 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
971 if (mode
!= MODE_FORMAT
)
972 format_locus
.nextc
+= format_string_pos
;
973 gfc_warning ("The H format specifier at %L is"
974 " a Fortran 95 deleted feature", &format_locus
);
976 if (mode
== MODE_STRING
)
978 format_string
+= value
;
979 format_length
-= value
;
980 format_string_pos
+= repeat
;
986 next_char (INSTRING_WARN
);
996 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
998 error
= nonneg_required
;
1001 else if (is_input
&& t
== FMT_ZERO
)
1003 error
= posint_required
;
1010 if (t
!= FMT_PERIOD
)
1019 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
1021 error
= nonneg_required
;
1029 error
= unexpected_element
;
1034 /* Between a descriptor and what comes next. */
1052 goto optional_comma
;
1055 error
= unexpected_end
;
1059 if (mode
!= MODE_FORMAT
)
1060 format_locus
.nextc
+= format_string_pos
- 1;
1061 if (gfc_notify_std (GFC_STD_GNU
, "Missing comma at %L",
1062 &format_locus
) == FAILURE
)
1064 /* If we do not actually return a failure, we need to unwind this
1065 before the next round. */
1066 if (mode
!= MODE_FORMAT
)
1067 format_locus
.nextc
-= format_string_pos
;
1072 /* Optional comma is a weird between state where we've just finished
1073 reading a colon, slash, dollar or P descriptor. */
1090 /* Assume that we have another format item. */
1097 extension_optional_comma
:
1098 /* As a GNU extension, permit a missing comma after a string literal. */
1115 goto optional_comma
;
1118 error
= unexpected_end
;
1122 if (mode
!= MODE_FORMAT
)
1123 format_locus
.nextc
+= format_string_pos
;
1124 if (gfc_notify_std (GFC_STD_GNU
, "Missing comma at %L",
1125 &format_locus
) == FAILURE
)
1127 /* If we do not actually return a failure, we need to unwind this
1128 before the next round. */
1129 if (mode
!= MODE_FORMAT
)
1130 format_locus
.nextc
-= format_string_pos
;
1138 if (mode
!= MODE_FORMAT
)
1139 format_locus
.nextc
+= format_string_pos
;
1140 if (error
== unexpected_element
)
1141 gfc_error (error
, error_element
, &format_locus
);
1143 gfc_error ("%s in format string at %L", error
, &format_locus
);
1152 /* Given an expression node that is a constant string, see if it looks
1153 like a format string. */
1156 check_format_string (gfc_expr
*e
, bool is_input
)
1160 if (!e
|| e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1164 format_string
= e
->value
.character
.string
;
1166 /* More elaborate measures are needed to show where a problem is within a
1167 format string that has been calculated, but that's probably not worth the
1169 format_locus
= e
->where
;
1170 rv
= check_format (is_input
);
1171 /* check for extraneous characters at the end of an otherwise valid format
1172 string, like '(A10,I3)F5'
1173 start at the end and move back to the last character processed,
1175 if (rv
== SUCCESS
&& e
->value
.character
.length
> format_string_pos
)
1176 for (i
=e
->value
.character
.length
-1;i
>format_string_pos
-1;i
--)
1177 if (e
->value
.character
.string
[i
] != ' ')
1179 format_locus
.nextc
+= format_length
+ 1;
1180 gfc_warning ("Extraneous characters in format at %L", &format_locus
);
1187 /************ Fortran 95 I/O statement matchers *************/
1189 /* Match a FORMAT statement. This amounts to actually parsing the
1190 format descriptors in order to correctly locate the end of the
1194 gfc_match_format (void)
1199 if (gfc_current_ns
->proc_name
1200 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1202 gfc_error ("Format statement in module main block at %C");
1206 if (gfc_statement_label
== NULL
)
1208 gfc_error ("Missing format label at %C");
1211 gfc_gobble_whitespace ();
1216 start
= gfc_current_locus
;
1218 if (check_format (false) == FAILURE
)
1221 if (gfc_match_eos () != MATCH_YES
)
1223 gfc_syntax_error (ST_FORMAT
);
1227 /* The label doesn't get created until after the statement is done
1228 being matched, so we have to leave the string for later. */
1230 gfc_current_locus
= start
; /* Back to the beginning */
1233 new_st
.op
= EXEC_NOP
;
1235 e
= gfc_get_character_expr (gfc_default_character_kind
, &start
,
1236 NULL
, format_length
);
1237 format_string
= e
->value
.character
.string
;
1238 gfc_statement_label
->format
= e
;
1241 check_format (false); /* Guaranteed to succeed */
1242 gfc_match_eos (); /* Guaranteed to succeed */
1248 /* Match an expression I/O tag of some sort. */
1251 match_etag (const io_tag
*tag
, gfc_expr
**v
)
1256 m
= gfc_match (tag
->spec
);
1260 m
= gfc_match (tag
->value
, &result
);
1263 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1269 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1270 gfc_free_expr (result
);
1279 /* Match a variable I/O tag of some sort. */
1282 match_vtag (const io_tag
*tag
, gfc_expr
**v
)
1287 m
= gfc_match (tag
->spec
);
1291 m
= gfc_match (tag
->value
, &result
);
1294 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1300 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1301 gfc_free_expr (result
);
1305 if (result
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1307 gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag
->name
);
1308 gfc_free_expr (result
);
1312 if (gfc_pure (NULL
) && gfc_impure_variable (result
->symtree
->n
.sym
))
1314 gfc_error ("Variable %s cannot be assigned in PURE procedure at %C",
1316 gfc_free_expr (result
);
1320 if (gfc_implicit_pure (NULL
) && gfc_impure_variable (result
->symtree
->n
.sym
))
1321 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1328 /* Match I/O tags that cause variables to become redefined. */
1331 match_out_tag (const io_tag
*tag
, gfc_expr
**result
)
1335 m
= match_vtag (tag
, result
);
1337 gfc_check_do_variable ((*result
)->symtree
);
1343 /* Match a label I/O tag. */
1346 match_ltag (const io_tag
*tag
, gfc_st_label
** label
)
1352 m
= gfc_match (tag
->spec
);
1356 m
= gfc_match (tag
->value
, label
);
1359 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1365 gfc_error ("Duplicate %s label specification at %C", tag
->name
);
1369 if (gfc_reference_st_label (*label
, ST_LABEL_TARGET
) == FAILURE
)
1376 /* Resolution of the FORMAT tag, to be called from resolve_tag. */
1379 resolve_tag_format (const gfc_expr
*e
)
1381 if (e
->expr_type
== EXPR_CONSTANT
1382 && (e
->ts
.type
!= BT_CHARACTER
1383 || e
->ts
.kind
!= gfc_default_character_kind
))
1385 gfc_error ("Constant expression in FORMAT tag at %L must be "
1386 "of type default CHARACTER", &e
->where
);
1390 /* If e's rank is zero and e is not an element of an array, it should be
1391 of integer or character type. The integer variable should be
1394 && (e
->expr_type
!= EXPR_VARIABLE
1395 || e
->symtree
== NULL
1396 || e
->symtree
->n
.sym
->as
== NULL
1397 || e
->symtree
->n
.sym
->as
->rank
== 0))
1399 if ((e
->ts
.type
!= BT_CHARACTER
1400 || e
->ts
.kind
!= gfc_default_character_kind
)
1401 && e
->ts
.type
!= BT_INTEGER
)
1403 gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER "
1404 "or of INTEGER", &e
->where
);
1407 else if (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_VARIABLE
)
1409 if (gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGNED "
1410 "variable in FORMAT tag at %L", &e
->where
)
1413 if (e
->symtree
->n
.sym
->attr
.assign
!= 1)
1415 gfc_error ("Variable '%s' at %L has not been assigned a "
1416 "format label", e
->symtree
->n
.sym
->name
, &e
->where
);
1420 else if (e
->ts
.type
== BT_INTEGER
)
1422 gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
1423 "variable", gfc_basic_typename (e
->ts
.type
), &e
->where
);
1430 /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
1431 It may be assigned an Hollerith constant. */
1432 if (e
->ts
.type
!= BT_CHARACTER
)
1434 if (gfc_notify_std (GFC_STD_LEGACY
, "Non-character "
1435 "in FORMAT tag at %L", &e
->where
) == FAILURE
)
1438 if (e
->rank
== 0 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
)
1440 gfc_error ("Non-character assumed shape array element in FORMAT"
1441 " tag at %L", &e
->where
);
1445 if (e
->rank
== 0 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
)
1447 gfc_error ("Non-character assumed size array element in FORMAT"
1448 " tag at %L", &e
->where
);
1452 if (e
->rank
== 0 && e
->symtree
->n
.sym
->attr
.pointer
)
1454 gfc_error ("Non-character pointer array element in FORMAT tag at %L",
1464 /* Do expression resolution and type-checking on an expression tag. */
1467 resolve_tag (const io_tag
*tag
, gfc_expr
*e
)
1472 if (gfc_resolve_expr (e
) == FAILURE
)
1475 if (tag
== &tag_format
)
1476 return resolve_tag_format (e
);
1478 if (e
->ts
.type
!= tag
->type
)
1480 gfc_error ("%s tag at %L must be of type %s", tag
->name
,
1481 &e
->where
, gfc_basic_typename (tag
->type
));
1485 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= gfc_default_character_kind
)
1487 gfc_error ("%s tag at %L must be a character string of default kind",
1488 tag
->name
, &e
->where
);
1494 gfc_error ("%s tag at %L must be scalar", tag
->name
, &e
->where
);
1498 if (tag
== &tag_iomsg
)
1500 if (gfc_notify_std (GFC_STD_F2003
, "IOMSG tag at %L",
1501 &e
->where
) == FAILURE
)
1505 if ((tag
== &tag_iostat
|| tag
== &tag_size
|| tag
== &tag_iolength
)
1506 && e
->ts
.kind
!= gfc_default_integer_kind
)
1508 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 95 requires default "
1509 "INTEGER in %s tag at %L", tag
->name
, &e
->where
)
1514 if (tag
== &tag_exist
&& e
->ts
.kind
!= gfc_default_logical_kind
)
1516 if (gfc_notify_std (GFC_STD_F2008
, "Nondefault LOGICAL "
1517 "in %s tag at %L", tag
->name
, &e
->where
)
1522 if (tag
== &tag_newunit
)
1524 if (gfc_notify_std (GFC_STD_F2008
, "NEWUNIT specifier"
1525 " at %L", &e
->where
) == FAILURE
)
1529 /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */
1530 if (tag
== &tag_newunit
|| tag
== &tag_iostat
1531 || tag
== &tag_size
|| tag
== &tag_iomsg
)
1535 sprintf (context
, _("%s tag"), tag
->name
);
1536 if (gfc_check_vardef_context (e
, false, false, false, context
) == FAILURE
)
1540 if (tag
== &tag_convert
)
1542 if (gfc_notify_std (GFC_STD_GNU
, "CONVERT tag at %L",
1543 &e
->where
) == FAILURE
)
1551 /* Match a single tag of an OPEN statement. */
1554 match_open_element (gfc_open
*open
)
1558 m
= match_etag (&tag_e_async
, &open
->asynchronous
);
1561 m
= match_etag (&tag_unit
, &open
->unit
);
1564 m
= match_out_tag (&tag_iomsg
, &open
->iomsg
);
1567 m
= match_out_tag (&tag_iostat
, &open
->iostat
);
1570 m
= match_etag (&tag_file
, &open
->file
);
1573 m
= match_etag (&tag_status
, &open
->status
);
1576 m
= match_etag (&tag_e_access
, &open
->access
);
1579 m
= match_etag (&tag_e_form
, &open
->form
);
1582 m
= match_etag (&tag_e_recl
, &open
->recl
);
1585 m
= match_etag (&tag_e_blank
, &open
->blank
);
1588 m
= match_etag (&tag_e_position
, &open
->position
);
1591 m
= match_etag (&tag_e_action
, &open
->action
);
1594 m
= match_etag (&tag_e_delim
, &open
->delim
);
1597 m
= match_etag (&tag_e_pad
, &open
->pad
);
1600 m
= match_etag (&tag_e_decimal
, &open
->decimal
);
1603 m
= match_etag (&tag_e_encoding
, &open
->encoding
);
1606 m
= match_etag (&tag_e_round
, &open
->round
);
1609 m
= match_etag (&tag_e_sign
, &open
->sign
);
1612 m
= match_ltag (&tag_err
, &open
->err
);
1615 m
= match_etag (&tag_convert
, &open
->convert
);
1618 m
= match_out_tag (&tag_newunit
, &open
->newunit
);
1626 /* Free the gfc_open structure and all the expressions it contains. */
1629 gfc_free_open (gfc_open
*open
)
1634 gfc_free_expr (open
->unit
);
1635 gfc_free_expr (open
->iomsg
);
1636 gfc_free_expr (open
->iostat
);
1637 gfc_free_expr (open
->file
);
1638 gfc_free_expr (open
->status
);
1639 gfc_free_expr (open
->access
);
1640 gfc_free_expr (open
->form
);
1641 gfc_free_expr (open
->recl
);
1642 gfc_free_expr (open
->blank
);
1643 gfc_free_expr (open
->position
);
1644 gfc_free_expr (open
->action
);
1645 gfc_free_expr (open
->delim
);
1646 gfc_free_expr (open
->pad
);
1647 gfc_free_expr (open
->decimal
);
1648 gfc_free_expr (open
->encoding
);
1649 gfc_free_expr (open
->round
);
1650 gfc_free_expr (open
->sign
);
1651 gfc_free_expr (open
->convert
);
1652 gfc_free_expr (open
->asynchronous
);
1653 gfc_free_expr (open
->newunit
);
1658 /* Resolve everything in a gfc_open structure. */
1661 gfc_resolve_open (gfc_open
*open
)
1664 RESOLVE_TAG (&tag_unit
, open
->unit
);
1665 RESOLVE_TAG (&tag_iomsg
, open
->iomsg
);
1666 RESOLVE_TAG (&tag_iostat
, open
->iostat
);
1667 RESOLVE_TAG (&tag_file
, open
->file
);
1668 RESOLVE_TAG (&tag_status
, open
->status
);
1669 RESOLVE_TAG (&tag_e_access
, open
->access
);
1670 RESOLVE_TAG (&tag_e_form
, open
->form
);
1671 RESOLVE_TAG (&tag_e_recl
, open
->recl
);
1672 RESOLVE_TAG (&tag_e_blank
, open
->blank
);
1673 RESOLVE_TAG (&tag_e_position
, open
->position
);
1674 RESOLVE_TAG (&tag_e_action
, open
->action
);
1675 RESOLVE_TAG (&tag_e_delim
, open
->delim
);
1676 RESOLVE_TAG (&tag_e_pad
, open
->pad
);
1677 RESOLVE_TAG (&tag_e_decimal
, open
->decimal
);
1678 RESOLVE_TAG (&tag_e_encoding
, open
->encoding
);
1679 RESOLVE_TAG (&tag_e_async
, open
->asynchronous
);
1680 RESOLVE_TAG (&tag_e_round
, open
->round
);
1681 RESOLVE_TAG (&tag_e_sign
, open
->sign
);
1682 RESOLVE_TAG (&tag_convert
, open
->convert
);
1683 RESOLVE_TAG (&tag_newunit
, open
->newunit
);
1685 if (gfc_reference_st_label (open
->err
, ST_LABEL_TARGET
) == FAILURE
)
1692 /* Check if a given value for a SPECIFIER is either in the list of values
1693 allowed in F95 or F2003, issuing an error message and returning a zero
1694 value if it is not allowed. */
1697 compare_to_allowed_values (const char *specifier
, const char *allowed
[],
1698 const char *allowed_f2003
[],
1699 const char *allowed_gnu
[], gfc_char_t
*value
,
1700 const char *statement
, bool warn
)
1705 len
= gfc_wide_strlen (value
);
1708 for (len
--; len
> 0; len
--)
1709 if (value
[len
] != ' ')
1714 for (i
= 0; allowed
[i
]; i
++)
1715 if (len
== strlen (allowed
[i
])
1716 && gfc_wide_strncasecmp (value
, allowed
[i
], strlen (allowed
[i
])) == 0)
1719 for (i
= 0; allowed_f2003
&& allowed_f2003
[i
]; i
++)
1720 if (len
== strlen (allowed_f2003
[i
])
1721 && gfc_wide_strncasecmp (value
, allowed_f2003
[i
],
1722 strlen (allowed_f2003
[i
])) == 0)
1724 notification n
= gfc_notification_std (GFC_STD_F2003
);
1726 if (n
== WARNING
|| (warn
&& n
== ERROR
))
1728 gfc_warning ("Fortran 2003: %s specifier in %s statement at %C "
1729 "has value '%s'", specifier
, statement
,
1736 gfc_notify_std (GFC_STD_F2003
, "%s specifier in "
1737 "%s statement at %C has value '%s'", specifier
,
1738 statement
, allowed_f2003
[i
]);
1746 for (i
= 0; allowed_gnu
&& allowed_gnu
[i
]; i
++)
1747 if (len
== strlen (allowed_gnu
[i
])
1748 && gfc_wide_strncasecmp (value
, allowed_gnu
[i
],
1749 strlen (allowed_gnu
[i
])) == 0)
1751 notification n
= gfc_notification_std (GFC_STD_GNU
);
1753 if (n
== WARNING
|| (warn
&& n
== ERROR
))
1755 gfc_warning ("Extension: %s specifier in %s statement at %C "
1756 "has value '%s'", specifier
, statement
,
1763 gfc_notify_std (GFC_STD_GNU
, "%s specifier in "
1764 "%s statement at %C has value '%s'", specifier
,
1765 statement
, allowed_gnu
[i
]);
1775 char *s
= gfc_widechar_to_char (value
, -1);
1776 gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
1777 specifier
, statement
, s
);
1783 char *s
= gfc_widechar_to_char (value
, -1);
1784 gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
1785 specifier
, statement
, s
);
1792 /* Match an OPEN statement. */
1795 gfc_match_open (void)
1801 m
= gfc_match_char ('(');
1805 open
= XCNEW (gfc_open
);
1807 m
= match_open_element (open
);
1809 if (m
== MATCH_ERROR
)
1813 m
= gfc_match_expr (&open
->unit
);
1814 if (m
== MATCH_ERROR
)
1820 if (gfc_match_char (')') == MATCH_YES
)
1822 if (gfc_match_char (',') != MATCH_YES
)
1825 m
= match_open_element (open
);
1826 if (m
== MATCH_ERROR
)
1832 if (gfc_match_eos () == MATCH_NO
)
1835 if (gfc_pure (NULL
))
1837 gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1841 if (gfc_implicit_pure (NULL
))
1842 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1844 warn
= (open
->err
|| open
->iostat
) ? true : false;
1846 /* Checks on NEWUNIT specifier. */
1851 gfc_error ("UNIT specifier not allowed with NEWUNIT at %C");
1855 if (!(open
->file
|| (open
->status
1856 && gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
1857 "scratch", 7) == 0)))
1859 gfc_error ("NEWUNIT specifier must have FILE= "
1860 "or STATUS='scratch' at %C");
1864 else if (!open
->unit
)
1866 gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified");
1870 /* Checks on the ACCESS specifier. */
1871 if (open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
)
1873 static const char *access_f95
[] = { "SEQUENTIAL", "DIRECT", NULL
};
1874 static const char *access_f2003
[] = { "STREAM", NULL
};
1875 static const char *access_gnu
[] = { "APPEND", NULL
};
1877 if (!compare_to_allowed_values ("ACCESS", access_f95
, access_f2003
,
1879 open
->access
->value
.character
.string
,
1884 /* Checks on the ACTION specifier. */
1885 if (open
->action
&& open
->action
->expr_type
== EXPR_CONSTANT
)
1887 static const char *action
[] = { "READ", "WRITE", "READWRITE", NULL
};
1889 if (!compare_to_allowed_values ("ACTION", action
, NULL
, NULL
,
1890 open
->action
->value
.character
.string
,
1895 /* Checks on the ASYNCHRONOUS specifier. */
1896 if (open
->asynchronous
)
1898 if (gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS= at %C "
1899 "not allowed in Fortran 95") == FAILURE
)
1902 if (open
->asynchronous
->expr_type
== EXPR_CONSTANT
)
1904 static const char * asynchronous
[] = { "YES", "NO", NULL
};
1906 if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous
,
1907 NULL
, NULL
, open
->asynchronous
->value
.character
.string
,
1913 /* Checks on the BLANK specifier. */
1916 if (gfc_notify_std (GFC_STD_F2003
, "BLANK= at %C "
1917 "not allowed in Fortran 95") == FAILURE
)
1920 if (open
->blank
->expr_type
== EXPR_CONSTANT
)
1922 static const char *blank
[] = { "ZERO", "NULL", NULL
};
1924 if (!compare_to_allowed_values ("BLANK", blank
, NULL
, NULL
,
1925 open
->blank
->value
.character
.string
,
1931 /* Checks on the DECIMAL specifier. */
1934 if (gfc_notify_std (GFC_STD_F2003
, "DECIMAL= at %C "
1935 "not allowed in Fortran 95") == FAILURE
)
1938 if (open
->decimal
->expr_type
== EXPR_CONSTANT
)
1940 static const char * decimal
[] = { "COMMA", "POINT", NULL
};
1942 if (!compare_to_allowed_values ("DECIMAL", decimal
, NULL
, NULL
,
1943 open
->decimal
->value
.character
.string
,
1949 /* Checks on the DELIM specifier. */
1952 if (open
->delim
->expr_type
== EXPR_CONSTANT
)
1954 static const char *delim
[] = { "APOSTROPHE", "QUOTE", "NONE", NULL
};
1956 if (!compare_to_allowed_values ("DELIM", delim
, NULL
, NULL
,
1957 open
->delim
->value
.character
.string
,
1963 /* Checks on the ENCODING specifier. */
1966 if (gfc_notify_std (GFC_STD_F2003
, "ENCODING= at %C "
1967 "not allowed in Fortran 95") == FAILURE
)
1970 if (open
->encoding
->expr_type
== EXPR_CONSTANT
)
1972 static const char * encoding
[] = { "DEFAULT", "UTF-8", NULL
};
1974 if (!compare_to_allowed_values ("ENCODING", encoding
, NULL
, NULL
,
1975 open
->encoding
->value
.character
.string
,
1981 /* Checks on the FORM specifier. */
1982 if (open
->form
&& open
->form
->expr_type
== EXPR_CONSTANT
)
1984 static const char *form
[] = { "FORMATTED", "UNFORMATTED", NULL
};
1986 if (!compare_to_allowed_values ("FORM", form
, NULL
, NULL
,
1987 open
->form
->value
.character
.string
,
1992 /* Checks on the PAD specifier. */
1993 if (open
->pad
&& open
->pad
->expr_type
== EXPR_CONSTANT
)
1995 static const char *pad
[] = { "YES", "NO", NULL
};
1997 if (!compare_to_allowed_values ("PAD", pad
, NULL
, NULL
,
1998 open
->pad
->value
.character
.string
,
2003 /* Checks on the POSITION specifier. */
2004 if (open
->position
&& open
->position
->expr_type
== EXPR_CONSTANT
)
2006 static const char *position
[] = { "ASIS", "REWIND", "APPEND", NULL
};
2008 if (!compare_to_allowed_values ("POSITION", position
, NULL
, NULL
,
2009 open
->position
->value
.character
.string
,
2014 /* Checks on the ROUND specifier. */
2017 if (gfc_notify_std (GFC_STD_F2003
, "ROUND= at %C "
2018 "not allowed in Fortran 95") == FAILURE
)
2021 if (open
->round
->expr_type
== EXPR_CONSTANT
)
2023 static const char * round
[] = { "UP", "DOWN", "ZERO", "NEAREST",
2024 "COMPATIBLE", "PROCESSOR_DEFINED",
2027 if (!compare_to_allowed_values ("ROUND", round
, NULL
, NULL
,
2028 open
->round
->value
.character
.string
,
2034 /* Checks on the SIGN specifier. */
2037 if (gfc_notify_std (GFC_STD_F2003
, "SIGN= at %C "
2038 "not allowed in Fortran 95") == FAILURE
)
2041 if (open
->sign
->expr_type
== EXPR_CONSTANT
)
2043 static const char * sign
[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
2046 if (!compare_to_allowed_values ("SIGN", sign
, NULL
, NULL
,
2047 open
->sign
->value
.character
.string
,
2053 #define warn_or_error(...) \
2056 gfc_warning (__VA_ARGS__); \
2059 gfc_error (__VA_ARGS__); \
2064 /* Checks on the RECL specifier. */
2065 if (open
->recl
&& open
->recl
->expr_type
== EXPR_CONSTANT
2066 && open
->recl
->ts
.type
== BT_INTEGER
2067 && mpz_sgn (open
->recl
->value
.integer
) != 1)
2069 warn_or_error ("RECL in OPEN statement at %C must be positive");
2072 /* Checks on the STATUS specifier. */
2073 if (open
->status
&& open
->status
->expr_type
== EXPR_CONSTANT
)
2075 static const char *status
[] = { "OLD", "NEW", "SCRATCH",
2076 "REPLACE", "UNKNOWN", NULL
};
2078 if (!compare_to_allowed_values ("STATUS", status
, NULL
, NULL
,
2079 open
->status
->value
.character
.string
,
2083 /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2084 the FILE= specifier shall appear. */
2085 if (open
->file
== NULL
2086 && (gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2088 || gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2091 char *s
= gfc_widechar_to_char (open
->status
->value
.character
.string
,
2093 warn_or_error ("The STATUS specified in OPEN statement at %C is "
2094 "'%s' and no FILE specifier is present", s
);
2098 /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2099 the FILE= specifier shall not appear. */
2100 if (gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2101 "scratch", 7) == 0 && open
->file
)
2103 warn_or_error ("The STATUS specified in OPEN statement at %C "
2104 "cannot have the value SCRATCH if a FILE specifier "
2109 /* Things that are not allowed for unformatted I/O. */
2110 if (open
->form
&& open
->form
->expr_type
== EXPR_CONSTANT
2111 && (open
->delim
|| open
->decimal
|| open
->encoding
|| open
->round
2112 || open
->sign
|| open
->pad
|| open
->blank
)
2113 && gfc_wide_strncasecmp (open
->form
->value
.character
.string
,
2114 "unformatted", 11) == 0)
2116 const char *spec
= (open
->delim
? "DELIM "
2117 : (open
->pad
? "PAD " : open
->blank
2120 warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
2121 "unformatted I/O", spec
);
2124 if (open
->recl
&& open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
2125 && gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2128 warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
2133 && open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
2134 && !(gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2135 "sequential", 10) == 0
2136 || gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2138 || gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2141 warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
2142 "for stream or sequential ACCESS");
2145 #undef warn_or_error
2147 new_st
.op
= EXEC_OPEN
;
2148 new_st
.ext
.open
= open
;
2152 gfc_syntax_error (ST_OPEN
);
2155 gfc_free_open (open
);
2160 /* Free a gfc_close structure an all its expressions. */
2163 gfc_free_close (gfc_close
*close
)
2168 gfc_free_expr (close
->unit
);
2169 gfc_free_expr (close
->iomsg
);
2170 gfc_free_expr (close
->iostat
);
2171 gfc_free_expr (close
->status
);
2176 /* Match elements of a CLOSE statement. */
2179 match_close_element (gfc_close
*close
)
2183 m
= match_etag (&tag_unit
, &close
->unit
);
2186 m
= match_etag (&tag_status
, &close
->status
);
2189 m
= match_out_tag (&tag_iomsg
, &close
->iomsg
);
2192 m
= match_out_tag (&tag_iostat
, &close
->iostat
);
2195 m
= match_ltag (&tag_err
, &close
->err
);
2203 /* Match a CLOSE statement. */
2206 gfc_match_close (void)
2212 m
= gfc_match_char ('(');
2216 close
= XCNEW (gfc_close
);
2218 m
= match_close_element (close
);
2220 if (m
== MATCH_ERROR
)
2224 m
= gfc_match_expr (&close
->unit
);
2227 if (m
== MATCH_ERROR
)
2233 if (gfc_match_char (')') == MATCH_YES
)
2235 if (gfc_match_char (',') != MATCH_YES
)
2238 m
= match_close_element (close
);
2239 if (m
== MATCH_ERROR
)
2245 if (gfc_match_eos () == MATCH_NO
)
2248 if (gfc_pure (NULL
))
2250 gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2254 if (gfc_implicit_pure (NULL
))
2255 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
2257 warn
= (close
->iostat
|| close
->err
) ? true : false;
2259 /* Checks on the STATUS specifier. */
2260 if (close
->status
&& close
->status
->expr_type
== EXPR_CONSTANT
)
2262 static const char *status
[] = { "KEEP", "DELETE", NULL
};
2264 if (!compare_to_allowed_values ("STATUS", status
, NULL
, NULL
,
2265 close
->status
->value
.character
.string
,
2270 new_st
.op
= EXEC_CLOSE
;
2271 new_st
.ext
.close
= close
;
2275 gfc_syntax_error (ST_CLOSE
);
2278 gfc_free_close (close
);
2283 /* Resolve everything in a gfc_close structure. */
2286 gfc_resolve_close (gfc_close
*close
)
2288 RESOLVE_TAG (&tag_unit
, close
->unit
);
2289 RESOLVE_TAG (&tag_iomsg
, close
->iomsg
);
2290 RESOLVE_TAG (&tag_iostat
, close
->iostat
);
2291 RESOLVE_TAG (&tag_status
, close
->status
);
2293 if (gfc_reference_st_label (close
->err
, ST_LABEL_TARGET
) == FAILURE
)
2296 if (close
->unit
== NULL
)
2298 /* Find a locus from one of the arguments to close, when UNIT is
2300 locus loc
= gfc_current_locus
;
2302 loc
= close
->status
->where
;
2303 else if (close
->iostat
)
2304 loc
= close
->iostat
->where
;
2305 else if (close
->iomsg
)
2306 loc
= close
->iomsg
->where
;
2307 else if (close
->err
)
2308 loc
= close
->err
->where
;
2310 gfc_error ("CLOSE statement at %L requires a UNIT number", &loc
);
2314 if (close
->unit
->expr_type
== EXPR_CONSTANT
2315 && close
->unit
->ts
.type
== BT_INTEGER
2316 && mpz_sgn (close
->unit
->value
.integer
) < 0)
2318 gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2319 &close
->unit
->where
);
2326 /* Free a gfc_filepos structure. */
2329 gfc_free_filepos (gfc_filepos
*fp
)
2331 gfc_free_expr (fp
->unit
);
2332 gfc_free_expr (fp
->iomsg
);
2333 gfc_free_expr (fp
->iostat
);
2338 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
2341 match_file_element (gfc_filepos
*fp
)
2345 m
= match_etag (&tag_unit
, &fp
->unit
);
2348 m
= match_out_tag (&tag_iomsg
, &fp
->iomsg
);
2351 m
= match_out_tag (&tag_iostat
, &fp
->iostat
);
2354 m
= match_ltag (&tag_err
, &fp
->err
);
2362 /* Match the second half of the file-positioning statements, REWIND,
2363 BACKSPACE, ENDFILE, or the FLUSH statement. */
2366 match_filepos (gfc_statement st
, gfc_exec_op op
)
2371 fp
= XCNEW (gfc_filepos
);
2373 if (gfc_match_char ('(') == MATCH_NO
)
2375 m
= gfc_match_expr (&fp
->unit
);
2376 if (m
== MATCH_ERROR
)
2384 m
= match_file_element (fp
);
2385 if (m
== MATCH_ERROR
)
2389 m
= gfc_match_expr (&fp
->unit
);
2390 if (m
== MATCH_ERROR
)
2398 if (gfc_match_char (')') == MATCH_YES
)
2400 if (gfc_match_char (',') != MATCH_YES
)
2403 m
= match_file_element (fp
);
2404 if (m
== MATCH_ERROR
)
2411 if (gfc_match_eos () != MATCH_YES
)
2414 if (gfc_pure (NULL
))
2416 gfc_error ("%s statement not allowed in PURE procedure at %C",
2417 gfc_ascii_statement (st
));
2422 if (gfc_implicit_pure (NULL
))
2423 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
2426 new_st
.ext
.filepos
= fp
;
2430 gfc_syntax_error (st
);
2433 gfc_free_filepos (fp
);
2439 gfc_resolve_filepos (gfc_filepos
*fp
)
2441 RESOLVE_TAG (&tag_unit
, fp
->unit
);
2442 RESOLVE_TAG (&tag_iostat
, fp
->iostat
);
2443 RESOLVE_TAG (&tag_iomsg
, fp
->iomsg
);
2444 if (gfc_reference_st_label (fp
->err
, ST_LABEL_TARGET
) == FAILURE
)
2447 if (fp
->unit
->expr_type
== EXPR_CONSTANT
2448 && fp
->unit
->ts
.type
== BT_INTEGER
2449 && mpz_sgn (fp
->unit
->value
.integer
) < 0)
2451 gfc_error ("UNIT number in statement at %L must be non-negative",
2459 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2460 and the FLUSH statement. */
2463 gfc_match_endfile (void)
2465 return match_filepos (ST_END_FILE
, EXEC_ENDFILE
);
2469 gfc_match_backspace (void)
2471 return match_filepos (ST_BACKSPACE
, EXEC_BACKSPACE
);
2475 gfc_match_rewind (void)
2477 return match_filepos (ST_REWIND
, EXEC_REWIND
);
2481 gfc_match_flush (void)
2483 if (gfc_notify_std (GFC_STD_F2003
, "FLUSH statement at %C")
2487 return match_filepos (ST_FLUSH
, EXEC_FLUSH
);
2490 /******************** Data Transfer Statements *********************/
2492 /* Return a default unit number. */
2495 default_unit (io_kind k
)
2504 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, unit
);
2508 /* Match a unit specification for a data transfer statement. */
2511 match_dt_unit (io_kind k
, gfc_dt
*dt
)
2515 if (gfc_match_char ('*') == MATCH_YES
)
2517 if (dt
->io_unit
!= NULL
)
2520 dt
->io_unit
= default_unit (k
);
2524 if (gfc_match_expr (&e
) == MATCH_YES
)
2526 if (dt
->io_unit
!= NULL
)
2539 gfc_error ("Duplicate UNIT specification at %C");
2544 /* Match a format specification. */
2547 match_dt_format (gfc_dt
*dt
)
2551 gfc_st_label
*label
;
2554 where
= gfc_current_locus
;
2556 if (gfc_match_char ('*') == MATCH_YES
)
2558 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2561 dt
->format_label
= &format_asterisk
;
2565 if ((m
= gfc_match_st_label (&label
)) == MATCH_YES
)
2569 /* Need to check if the format label is actually either an operand
2570 to a user-defined operator or is a kind type parameter. That is,
2571 print 2.ip.8 ! .ip. is a user-defined operator return CHARACTER.
2572 print 1_'(I0)', i ! 1_'(I0)' is a default character string. */
2574 gfc_gobble_whitespace ();
2575 c
= gfc_peek_ascii_char ();
2576 if (c
== '.' || c
== '_')
2577 gfc_current_locus
= where
;
2580 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2582 gfc_free_st_label (label
);
2586 if (gfc_reference_st_label (label
, ST_LABEL_FORMAT
) == FAILURE
)
2589 dt
->format_label
= label
;
2593 else if (m
== MATCH_ERROR
)
2594 /* The label was zero or too large. Emit the correct diagnosis. */
2597 if (gfc_match_expr (&e
) == MATCH_YES
)
2599 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2604 dt
->format_expr
= e
;
2608 gfc_current_locus
= where
; /* The only case where we have to restore */
2613 gfc_error ("Duplicate format specification at %C");
2618 /* Traverse a namelist that is part of a READ statement to make sure
2619 that none of the variables in the namelist are INTENT(IN). Returns
2620 nonzero if we find such a variable. */
2623 check_namelist (gfc_symbol
*sym
)
2627 for (p
= sym
->namelist
; p
; p
= p
->next
)
2628 if (p
->sym
->attr
.intent
== INTENT_IN
)
2630 gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
2631 p
->sym
->name
, sym
->name
);
2639 /* Match a single data transfer element. */
2642 match_dt_element (io_kind k
, gfc_dt
*dt
)
2644 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2648 if (gfc_match (" unit =") == MATCH_YES
)
2650 m
= match_dt_unit (k
, dt
);
2655 if (gfc_match (" fmt =") == MATCH_YES
)
2657 m
= match_dt_format (dt
);
2662 if (gfc_match (" nml = %n", name
) == MATCH_YES
)
2664 if (dt
->namelist
!= NULL
)
2666 gfc_error ("Duplicate NML specification at %C");
2670 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
2673 if (sym
== NULL
|| sym
->attr
.flavor
!= FL_NAMELIST
)
2675 gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
2676 sym
!= NULL
? sym
->name
: name
);
2681 if (k
== M_READ
&& check_namelist (sym
))
2687 m
= match_etag (&tag_e_async
, &dt
->asynchronous
);
2690 m
= match_etag (&tag_e_blank
, &dt
->blank
);
2693 m
= match_etag (&tag_e_delim
, &dt
->delim
);
2696 m
= match_etag (&tag_e_pad
, &dt
->pad
);
2699 m
= match_etag (&tag_e_sign
, &dt
->sign
);
2702 m
= match_etag (&tag_e_round
, &dt
->round
);
2705 m
= match_out_tag (&tag_id
, &dt
->id
);
2708 m
= match_etag (&tag_e_decimal
, &dt
->decimal
);
2711 m
= match_etag (&tag_rec
, &dt
->rec
);
2714 m
= match_etag (&tag_spos
, &dt
->pos
);
2717 m
= match_out_tag (&tag_iomsg
, &dt
->iomsg
);
2720 m
= match_out_tag (&tag_iostat
, &dt
->iostat
);
2723 m
= match_ltag (&tag_err
, &dt
->err
);
2725 dt
->err_where
= gfc_current_locus
;
2728 m
= match_etag (&tag_advance
, &dt
->advance
);
2731 m
= match_out_tag (&tag_size
, &dt
->size
);
2735 m
= match_ltag (&tag_end
, &dt
->end
);
2740 gfc_error ("END tag at %C not allowed in output statement");
2743 dt
->end_where
= gfc_current_locus
;
2748 m
= match_ltag (&tag_eor
, &dt
->eor
);
2750 dt
->eor_where
= gfc_current_locus
;
2758 /* Free a data transfer structure and everything below it. */
2761 gfc_free_dt (gfc_dt
*dt
)
2766 gfc_free_expr (dt
->io_unit
);
2767 gfc_free_expr (dt
->format_expr
);
2768 gfc_free_expr (dt
->rec
);
2769 gfc_free_expr (dt
->advance
);
2770 gfc_free_expr (dt
->iomsg
);
2771 gfc_free_expr (dt
->iostat
);
2772 gfc_free_expr (dt
->size
);
2773 gfc_free_expr (dt
->pad
);
2774 gfc_free_expr (dt
->delim
);
2775 gfc_free_expr (dt
->sign
);
2776 gfc_free_expr (dt
->round
);
2777 gfc_free_expr (dt
->blank
);
2778 gfc_free_expr (dt
->decimal
);
2779 gfc_free_expr (dt
->pos
);
2780 gfc_free_expr (dt
->dt_io_kind
);
2781 /* dt->extra_comma is a link to dt_io_kind if it is set. */
2786 /* Resolve everything in a gfc_dt structure. */
2789 gfc_resolve_dt (gfc_dt
*dt
, locus
*loc
)
2794 /* This is set in any case. */
2795 gcc_assert (dt
->dt_io_kind
);
2796 k
= dt
->dt_io_kind
->value
.iokind
;
2798 RESOLVE_TAG (&tag_format
, dt
->format_expr
);
2799 RESOLVE_TAG (&tag_rec
, dt
->rec
);
2800 RESOLVE_TAG (&tag_spos
, dt
->pos
);
2801 RESOLVE_TAG (&tag_advance
, dt
->advance
);
2802 RESOLVE_TAG (&tag_id
, dt
->id
);
2803 RESOLVE_TAG (&tag_iomsg
, dt
->iomsg
);
2804 RESOLVE_TAG (&tag_iostat
, dt
->iostat
);
2805 RESOLVE_TAG (&tag_size
, dt
->size
);
2806 RESOLVE_TAG (&tag_e_pad
, dt
->pad
);
2807 RESOLVE_TAG (&tag_e_delim
, dt
->delim
);
2808 RESOLVE_TAG (&tag_e_sign
, dt
->sign
);
2809 RESOLVE_TAG (&tag_e_round
, dt
->round
);
2810 RESOLVE_TAG (&tag_e_blank
, dt
->blank
);
2811 RESOLVE_TAG (&tag_e_decimal
, dt
->decimal
);
2812 RESOLVE_TAG (&tag_e_async
, dt
->asynchronous
);
2817 gfc_error ("UNIT not specified at %L", loc
);
2821 if (gfc_resolve_expr (e
) == SUCCESS
2822 && (e
->ts
.type
!= BT_INTEGER
2823 && (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_VARIABLE
)))
2825 /* If there is no extra comma signifying the "format" form of the IO
2826 statement, then this must be an error. */
2827 if (!dt
->extra_comma
)
2829 gfc_error ("UNIT specification at %L must be an INTEGER expression "
2830 "or a CHARACTER variable", &e
->where
);
2835 /* At this point, we have an extra comma. If io_unit has arrived as
2836 type character, we assume its really the "format" form of the I/O
2837 statement. We set the io_unit to the default unit and format to
2838 the character expression. See F95 Standard section 9.4. */
2839 if (e
->ts
.type
== BT_CHARACTER
&& (k
== M_READ
|| k
== M_PRINT
))
2841 dt
->format_expr
= dt
->io_unit
;
2842 dt
->io_unit
= default_unit (k
);
2844 /* Nullify this pointer now so that a warning/error is not
2845 triggered below for the "Extension". */
2846 dt
->extra_comma
= NULL
;
2851 gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
2852 &dt
->extra_comma
->where
);
2858 if (e
->ts
.type
== BT_CHARACTER
)
2860 if (gfc_has_vector_index (e
))
2862 gfc_error ("Internal unit with vector subscript at %L", &e
->where
);
2866 /* If we are writing, make sure the internal unit can be changed. */
2867 gcc_assert (k
!= M_PRINT
);
2869 && gfc_check_vardef_context (e
, false, false, false,
2870 _("internal unit in WRITE")) == FAILURE
)
2874 if (e
->rank
&& e
->ts
.type
!= BT_CHARACTER
)
2876 gfc_error ("External IO UNIT cannot be an array at %L", &e
->where
);
2880 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_INTEGER
2881 && mpz_sgn (e
->value
.integer
) < 0)
2883 gfc_error ("UNIT number in statement at %L must be non-negative",
2888 /* If we are reading and have a namelist, check that all namelist symbols
2889 can appear in a variable definition context. */
2890 if (k
== M_READ
&& dt
->namelist
)
2893 for (n
= dt
->namelist
->namelist
; n
; n
= n
->next
)
2898 e
= gfc_get_variable_expr (gfc_find_sym_in_symtree (n
->sym
));
2899 t
= gfc_check_vardef_context (e
, false, false, false, NULL
);
2904 gfc_error ("NAMELIST '%s' in READ statement at %L contains"
2905 " the symbol '%s' which may not appear in a"
2906 " variable definition context",
2907 dt
->namelist
->name
, loc
, n
->sym
->name
);
2914 && gfc_notify_std (GFC_STD_GNU
, "Comma before i/o "
2915 "item list at %L", &dt
->extra_comma
->where
) == FAILURE
)
2920 if (gfc_reference_st_label (dt
->err
, ST_LABEL_TARGET
) == FAILURE
)
2922 if (dt
->err
->defined
== ST_LABEL_UNKNOWN
)
2924 gfc_error ("ERR tag label %d at %L not defined",
2925 dt
->err
->value
, &dt
->err_where
);
2932 if (gfc_reference_st_label (dt
->end
, ST_LABEL_TARGET
) == FAILURE
)
2934 if (dt
->end
->defined
== ST_LABEL_UNKNOWN
)
2936 gfc_error ("END tag label %d at %L not defined",
2937 dt
->end
->value
, &dt
->end_where
);
2944 if (gfc_reference_st_label (dt
->eor
, ST_LABEL_TARGET
) == FAILURE
)
2946 if (dt
->eor
->defined
== ST_LABEL_UNKNOWN
)
2948 gfc_error ("EOR tag label %d at %L not defined",
2949 dt
->eor
->value
, &dt
->eor_where
);
2954 /* Check the format label actually exists. */
2955 if (dt
->format_label
&& dt
->format_label
!= &format_asterisk
2956 && dt
->format_label
->defined
== ST_LABEL_UNKNOWN
)
2958 gfc_error ("FORMAT label %d at %L not defined", dt
->format_label
->value
,
2959 &dt
->format_label
->where
);
2967 /* Given an io_kind, return its name. */
2970 io_kind_name (io_kind k
)
2989 gfc_internal_error ("io_kind_name(): bad I/O-kind");
2996 /* Match an IO iteration statement of the form:
2998 ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
3000 which is equivalent to a single IO element. This function is
3001 mutually recursive with match_io_element(). */
3003 static match
match_io_element (io_kind
, gfc_code
**);
3006 match_io_iterator (io_kind k
, gfc_code
**result
)
3008 gfc_code
*head
, *tail
, *new_code
;
3016 old_loc
= gfc_current_locus
;
3018 if (gfc_match_char ('(') != MATCH_YES
)
3021 m
= match_io_element (k
, &head
);
3024 if (m
!= MATCH_YES
|| gfc_match_char (',') != MATCH_YES
)
3030 /* Can't be anything but an IO iterator. Build a list. */
3031 iter
= gfc_get_iterator ();
3035 m
= gfc_match_iterator (iter
, 0);
3036 if (m
== MATCH_ERROR
)
3040 gfc_check_do_variable (iter
->var
->symtree
);
3044 m
= match_io_element (k
, &new_code
);
3045 if (m
== MATCH_ERROR
)
3054 tail
= gfc_append_code (tail
, new_code
);
3056 if (gfc_match_char (',') != MATCH_YES
)
3065 if (gfc_match_char (')') != MATCH_YES
)
3068 new_code
= gfc_get_code ();
3069 new_code
->op
= EXEC_DO
;
3070 new_code
->ext
.iterator
= iter
;
3072 new_code
->block
= gfc_get_code ();
3073 new_code
->block
->op
= EXEC_DO
;
3074 new_code
->block
->next
= head
;
3080 gfc_error ("Syntax error in I/O iterator at %C");
3084 gfc_free_iterator (iter
, 1);
3085 gfc_free_statements (head
);
3086 gfc_current_locus
= old_loc
;
3091 /* Match a single element of an IO list, which is either a single
3092 expression or an IO Iterator. */
3095 match_io_element (io_kind k
, gfc_code
**cpp
)
3103 m
= match_io_iterator (k
, cpp
);
3109 m
= gfc_match_variable (&expr
, 0);
3111 gfc_error ("Expected variable in READ statement at %C");
3115 m
= gfc_match_expr (&expr
);
3117 gfc_error ("Expected expression in %s statement at %C",
3121 if (m
== MATCH_YES
&& k
== M_READ
&& gfc_check_do_variable (expr
->symtree
))
3126 gfc_free_expr (expr
);
3130 cp
= gfc_get_code ();
3131 cp
->op
= EXEC_TRANSFER
;
3134 cp
->ext
.dt
= current_dt
;
3141 /* Match an I/O list, building gfc_code structures as we go. */
3144 match_io_list (io_kind k
, gfc_code
**head_p
)
3146 gfc_code
*head
, *tail
, *new_code
;
3149 *head_p
= head
= tail
= NULL
;
3150 if (gfc_match_eos () == MATCH_YES
)
3155 m
= match_io_element (k
, &new_code
);
3156 if (m
== MATCH_ERROR
)
3161 tail
= gfc_append_code (tail
, new_code
);
3165 if (gfc_match_eos () == MATCH_YES
)
3167 if (gfc_match_char (',') != MATCH_YES
)
3175 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
3178 gfc_free_statements (head
);
3183 /* Attach the data transfer end node. */
3186 terminate_io (gfc_code
*io_code
)
3190 if (io_code
== NULL
)
3191 io_code
= new_st
.block
;
3193 c
= gfc_get_code ();
3194 c
->op
= EXEC_DT_END
;
3196 /* Point to structure that is already there */
3197 c
->ext
.dt
= new_st
.ext
.dt
;
3198 gfc_append_code (io_code
, c
);
3202 /* Check the constraints for a data transfer statement. The majority of the
3203 constraints appearing in 9.4 of the standard appear here. Some are handled
3204 in resolve_tag and others in gfc_resolve_dt. */
3207 check_io_constraints (io_kind k
, gfc_dt
*dt
, gfc_code
*io_code
,
3210 #define io_constraint(condition,msg,arg)\
3213 gfc_error(msg,arg);\
3219 gfc_symbol
*sym
= NULL
;
3220 bool warn
, unformatted
;
3222 warn
= (dt
->err
|| dt
->iostat
) ? true : false;
3223 unformatted
= dt
->format_expr
== NULL
&& dt
->format_label
== NULL
3224 && dt
->namelist
== NULL
;
3229 if (expr
&& expr
->expr_type
== EXPR_VARIABLE
3230 && expr
->ts
.type
== BT_CHARACTER
)
3232 sym
= expr
->symtree
->n
.sym
;
3234 io_constraint (k
== M_WRITE
&& sym
->attr
.intent
== INTENT_IN
,
3235 "Internal file at %L must not be INTENT(IN)",
3238 io_constraint (gfc_has_vector_index (dt
->io_unit
),
3239 "Internal file incompatible with vector subscript at %L",
3242 io_constraint (dt
->rec
!= NULL
,
3243 "REC tag at %L is incompatible with internal file",
3246 io_constraint (dt
->pos
!= NULL
,
3247 "POS tag at %L is incompatible with internal file",
3250 io_constraint (unformatted
,
3251 "Unformatted I/O not allowed with internal unit at %L",
3252 &dt
->io_unit
->where
);
3254 io_constraint (dt
->asynchronous
!= NULL
,
3255 "ASYNCHRONOUS tag at %L not allowed with internal file",
3256 &dt
->asynchronous
->where
);
3258 if (dt
->namelist
!= NULL
)
3260 if (gfc_notify_std (GFC_STD_F2003
, "Internal file "
3261 "at %L with namelist", &expr
->where
)
3266 io_constraint (dt
->advance
!= NULL
,
3267 "ADVANCE tag at %L is incompatible with internal file",
3268 &dt
->advance
->where
);
3271 if (expr
&& expr
->ts
.type
!= BT_CHARACTER
)
3274 io_constraint (gfc_pure (NULL
) && (k
== M_READ
|| k
== M_WRITE
),
3275 "IO UNIT in %s statement at %C must be "
3276 "an internal file in a PURE procedure",
3279 if (gfc_implicit_pure (NULL
) && (k
== M_READ
|| k
== M_WRITE
))
3280 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3286 io_constraint (dt
->end
, "END tag not allowed with output at %L",
3289 io_constraint (dt
->eor
, "EOR tag not allowed with output at %L",
3292 io_constraint (dt
->blank
, "BLANK= specifier not allowed with output at %L",
3295 io_constraint (dt
->pad
, "PAD= specifier not allowed with output at %L",
3298 io_constraint (dt
->size
, "SIZE= specifier not allowed with output at %L",
3303 io_constraint (dt
->size
&& dt
->advance
== NULL
,
3304 "SIZE tag at %L requires an ADVANCE tag",
3307 io_constraint (dt
->eor
&& dt
->advance
== NULL
,
3308 "EOR tag at %L requires an ADVANCE tag",
3312 if (dt
->asynchronous
)
3314 static const char * asynchronous
[] = { "YES", "NO", NULL
};
3316 if (gfc_reduce_init_expr (dt
->asynchronous
) != SUCCESS
)
3318 gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3319 "expression", &dt
->asynchronous
->where
);
3323 if (!compare_to_allowed_values
3324 ("ASYNCHRONOUS", asynchronous
, NULL
, NULL
,
3325 dt
->asynchronous
->value
.character
.string
,
3326 io_kind_name (k
), warn
))
3334 || gfc_wide_strlen (dt
->asynchronous
->value
.character
.string
) != 3
3335 || gfc_wide_strncasecmp (dt
->asynchronous
->value
.character
.string
,
3337 io_constraint (not_yes
,
3338 "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3339 "specifier", &dt
->id
->where
);
3344 if (gfc_notify_std (GFC_STD_F2003
, "DECIMAL= at %C "
3345 "not allowed in Fortran 95") == FAILURE
)
3348 if (dt
->decimal
->expr_type
== EXPR_CONSTANT
)
3350 static const char * decimal
[] = { "COMMA", "POINT", NULL
};
3352 if (!compare_to_allowed_values ("DECIMAL", decimal
, NULL
, NULL
,
3353 dt
->decimal
->value
.character
.string
,
3354 io_kind_name (k
), warn
))
3357 io_constraint (unformatted
,
3358 "the DECIMAL= specifier at %L must be with an "
3359 "explicit format expression", &dt
->decimal
->where
);
3365 if (gfc_notify_std (GFC_STD_F2003
, "BLANK= at %C "
3366 "not allowed in Fortran 95") == FAILURE
)
3369 if (dt
->blank
->expr_type
== EXPR_CONSTANT
)
3371 static const char * blank
[] = { "NULL", "ZERO", NULL
};
3373 if (!compare_to_allowed_values ("BLANK", blank
, NULL
, NULL
,
3374 dt
->blank
->value
.character
.string
,
3375 io_kind_name (k
), warn
))
3378 io_constraint (unformatted
,
3379 "the BLANK= specifier at %L must be with an "
3380 "explicit format expression", &dt
->blank
->where
);
3386 if (gfc_notify_std (GFC_STD_F2003
, "PAD= at %C "
3387 "not allowed in Fortran 95") == FAILURE
)
3390 if (dt
->pad
->expr_type
== EXPR_CONSTANT
)
3392 static const char * pad
[] = { "YES", "NO", NULL
};
3394 if (!compare_to_allowed_values ("PAD", pad
, NULL
, NULL
,
3395 dt
->pad
->value
.character
.string
,
3396 io_kind_name (k
), warn
))
3399 io_constraint (unformatted
,
3400 "the PAD= specifier at %L must be with an "
3401 "explicit format expression", &dt
->pad
->where
);
3407 if (gfc_notify_std (GFC_STD_F2003
, "ROUND= at %C "
3408 "not allowed in Fortran 95") == FAILURE
)
3411 if (dt
->round
->expr_type
== EXPR_CONSTANT
)
3413 static const char * round
[] = { "UP", "DOWN", "ZERO", "NEAREST",
3414 "COMPATIBLE", "PROCESSOR_DEFINED",
3417 if (!compare_to_allowed_values ("ROUND", round
, NULL
, NULL
,
3418 dt
->round
->value
.character
.string
,
3419 io_kind_name (k
), warn
))
3426 /* When implemented, change the following to use gfc_notify_std F2003.
3427 if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C "
3428 "not allowed in Fortran 95") == FAILURE)
3429 return MATCH_ERROR; */
3430 if (dt
->sign
->expr_type
== EXPR_CONSTANT
)
3432 static const char * sign
[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3435 if (!compare_to_allowed_values ("SIGN", sign
, NULL
, NULL
,
3436 dt
->sign
->value
.character
.string
,
3437 io_kind_name (k
), warn
))
3440 io_constraint (unformatted
,
3441 "SIGN= specifier at %L must be with an "
3442 "explicit format expression", &dt
->sign
->where
);
3444 io_constraint (k
== M_READ
,
3445 "SIGN= specifier at %L not allowed in a "
3446 "READ statement", &dt
->sign
->where
);
3452 if (gfc_notify_std (GFC_STD_F2003
, "DELIM= at %C "
3453 "not allowed in Fortran 95") == FAILURE
)
3456 if (dt
->delim
->expr_type
== EXPR_CONSTANT
)
3458 static const char *delim
[] = { "APOSTROPHE", "QUOTE", "NONE", NULL
};
3460 if (!compare_to_allowed_values ("DELIM", delim
, NULL
, NULL
,
3461 dt
->delim
->value
.character
.string
,
3462 io_kind_name (k
), warn
))
3465 io_constraint (k
== M_READ
,
3466 "DELIM= specifier at %L not allowed in a "
3467 "READ statement", &dt
->delim
->where
);
3469 io_constraint (dt
->format_label
!= &format_asterisk
3470 && dt
->namelist
== NULL
,
3471 "DELIM= specifier at %L must have FMT=*",
3474 io_constraint (unformatted
&& dt
->namelist
== NULL
,
3475 "DELIM= specifier at %L must be with FMT=* or "
3476 "NML= specifier ", &dt
->delim
->where
);
3482 io_constraint (io_code
&& dt
->namelist
,
3483 "NAMELIST cannot be followed by IO-list at %L",
3486 io_constraint (dt
->format_expr
,
3487 "IO spec-list cannot contain both NAMELIST group name "
3488 "and format specification at %L",
3489 &dt
->format_expr
->where
);
3491 io_constraint (dt
->format_label
,
3492 "IO spec-list cannot contain both NAMELIST group name "
3493 "and format label at %L", spec_end
);
3495 io_constraint (dt
->rec
,
3496 "NAMELIST IO is not allowed with a REC= specifier "
3497 "at %L", &dt
->rec
->where
);
3499 io_constraint (dt
->advance
,
3500 "NAMELIST IO is not allowed with a ADVANCE= specifier "
3501 "at %L", &dt
->advance
->where
);
3506 io_constraint (dt
->end
,
3507 "An END tag is not allowed with a "
3508 "REC= specifier at %L", &dt
->end_where
);
3510 io_constraint (dt
->format_label
== &format_asterisk
,
3511 "FMT=* is not allowed with a REC= specifier "
3514 io_constraint (dt
->pos
,
3515 "POS= is not allowed with REC= specifier "
3516 "at %L", &dt
->pos
->where
);
3521 int not_yes
, not_no
;
3524 io_constraint (dt
->format_label
== &format_asterisk
,
3525 "List directed format(*) is not allowed with a "
3526 "ADVANCE= specifier at %L.", &expr
->where
);
3528 io_constraint (unformatted
,
3529 "the ADVANCE= specifier at %L must appear with an "
3530 "explicit format expression", &expr
->where
);
3532 if (expr
->expr_type
== EXPR_CONSTANT
&& expr
->ts
.type
== BT_CHARACTER
)
3534 const gfc_char_t
*advance
= expr
->value
.character
.string
;
3535 not_no
= gfc_wide_strlen (advance
) != 2
3536 || gfc_wide_strncasecmp (advance
, "no", 2) != 0;
3537 not_yes
= gfc_wide_strlen (advance
) != 3
3538 || gfc_wide_strncasecmp (advance
, "yes", 3) != 0;
3546 io_constraint (not_no
&& not_yes
,
3547 "ADVANCE= specifier at %L must have value = "
3548 "YES or NO.", &expr
->where
);
3550 io_constraint (dt
->size
&& not_no
&& k
== M_READ
,
3551 "SIZE tag at %L requires an ADVANCE = 'NO'",
3554 io_constraint (dt
->eor
&& not_no
&& k
== M_READ
,
3555 "EOR tag at %L requires an ADVANCE = 'NO'",
3559 expr
= dt
->format_expr
;
3560 if (gfc_simplify_expr (expr
, 0) == FAILURE
3561 || check_format_string (expr
, k
== M_READ
) == FAILURE
)
3566 #undef io_constraint
3569 /* Match a READ, WRITE or PRINT statement. */
3572 match_io (io_kind k
)
3574 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3583 where
= gfc_current_locus
;
3585 current_dt
= dt
= XCNEW (gfc_dt
);
3586 m
= gfc_match_char ('(');
3589 where
= gfc_current_locus
;
3592 else if (k
== M_PRINT
)
3594 /* Treat the non-standard case of PRINT namelist. */
3595 if ((gfc_current_form
== FORM_FIXED
|| gfc_peek_ascii_char () == ' ')
3596 && gfc_match_name (name
) == MATCH_YES
)
3598 gfc_find_symbol (name
, NULL
, 1, &sym
);
3599 if (sym
&& sym
->attr
.flavor
== FL_NAMELIST
)
3601 if (gfc_notify_std (GFC_STD_GNU
, "PRINT namelist at "
3602 "%C is an extension") == FAILURE
)
3608 dt
->io_unit
= default_unit (k
);
3613 gfc_current_locus
= where
;
3617 if (gfc_current_form
== FORM_FREE
)
3619 char c
= gfc_peek_ascii_char ();
3620 if (c
!= ' ' && c
!= '*' && c
!= '\'' && c
!= '"')
3627 m
= match_dt_format (dt
);
3628 if (m
== MATCH_ERROR
)
3634 dt
->io_unit
= default_unit (k
);
3639 /* Before issuing an error for a malformed 'print (1,*)' type of
3640 error, check for a default-char-expr of the form ('(I0)'). */
3641 if (k
== M_PRINT
&& m
== MATCH_YES
)
3643 /* Reset current locus to get the initial '(' in an expression. */
3644 gfc_current_locus
= where
;
3645 dt
->format_expr
= NULL
;
3646 m
= match_dt_format (dt
);
3648 if (m
== MATCH_ERROR
)
3650 if (m
== MATCH_NO
|| dt
->format_expr
== NULL
)
3654 dt
->io_unit
= default_unit (k
);
3659 /* Match a control list */
3660 if (match_dt_element (k
, dt
) == MATCH_YES
)
3662 if (match_dt_unit (k
, dt
) != MATCH_YES
)
3665 if (gfc_match_char (')') == MATCH_YES
)
3667 if (gfc_match_char (',') != MATCH_YES
)
3670 m
= match_dt_element (k
, dt
);
3673 if (m
== MATCH_ERROR
)
3676 m
= match_dt_format (dt
);
3679 if (m
== MATCH_ERROR
)
3682 where
= gfc_current_locus
;
3684 m
= gfc_match_name (name
);
3687 gfc_find_symbol (name
, NULL
, 1, &sym
);
3688 if (sym
&& sym
->attr
.flavor
== FL_NAMELIST
)
3691 if (k
== M_READ
&& check_namelist (sym
))
3700 gfc_current_locus
= where
;
3702 goto loop
; /* No matches, try regular elements */
3705 if (gfc_match_char (')') == MATCH_YES
)
3707 if (gfc_match_char (',') != MATCH_YES
)
3713 m
= match_dt_element (k
, dt
);
3716 if (m
== MATCH_ERROR
)
3719 if (gfc_match_char (')') == MATCH_YES
)
3721 if (gfc_match_char (',') != MATCH_YES
)
3727 /* Used in check_io_constraints, where no locus is available. */
3728 spec_end
= gfc_current_locus
;
3730 /* Save the IO kind for later use. */
3731 dt
->dt_io_kind
= gfc_get_iokind_expr (&gfc_current_locus
, k
);
3733 /* Optional leading comma (non-standard). We use a gfc_expr structure here
3734 to save the locus. This is used later when resolving transfer statements
3735 that might have a format expression without unit number. */
3736 if (!comma_flag
&& gfc_match_char (',') == MATCH_YES
)
3737 dt
->extra_comma
= dt
->dt_io_kind
;
3740 if (gfc_match_eos () != MATCH_YES
)
3742 if (comma_flag
&& gfc_match_char (',') != MATCH_YES
)
3744 gfc_error ("Expected comma in I/O list at %C");
3749 m
= match_io_list (k
, &io_code
);
3750 if (m
== MATCH_ERROR
)
3756 /* A full IO statement has been matched. Check the constraints. spec_end is
3757 supplied for cases where no locus is supplied. */
3758 m
= check_io_constraints (k
, dt
, io_code
, &spec_end
);
3760 if (m
== MATCH_ERROR
)
3763 new_st
.op
= (k
== M_READ
) ? EXEC_READ
: EXEC_WRITE
;
3765 new_st
.block
= gfc_get_code ();
3766 new_st
.block
->op
= new_st
.op
;
3767 new_st
.block
->next
= io_code
;
3769 terminate_io (io_code
);
3774 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
3784 gfc_match_read (void)
3786 return match_io (M_READ
);
3791 gfc_match_write (void)
3793 return match_io (M_WRITE
);
3798 gfc_match_print (void)
3802 m
= match_io (M_PRINT
);
3806 if (gfc_pure (NULL
))
3808 gfc_error ("PRINT statement at %C not allowed within PURE procedure");
3812 if (gfc_implicit_pure (NULL
))
3813 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3819 /* Free a gfc_inquire structure. */
3822 gfc_free_inquire (gfc_inquire
*inquire
)
3825 if (inquire
== NULL
)
3828 gfc_free_expr (inquire
->unit
);
3829 gfc_free_expr (inquire
->file
);
3830 gfc_free_expr (inquire
->iomsg
);
3831 gfc_free_expr (inquire
->iostat
);
3832 gfc_free_expr (inquire
->exist
);
3833 gfc_free_expr (inquire
->opened
);
3834 gfc_free_expr (inquire
->number
);
3835 gfc_free_expr (inquire
->named
);
3836 gfc_free_expr (inquire
->name
);
3837 gfc_free_expr (inquire
->access
);
3838 gfc_free_expr (inquire
->sequential
);
3839 gfc_free_expr (inquire
->direct
);
3840 gfc_free_expr (inquire
->form
);
3841 gfc_free_expr (inquire
->formatted
);
3842 gfc_free_expr (inquire
->unformatted
);
3843 gfc_free_expr (inquire
->recl
);
3844 gfc_free_expr (inquire
->nextrec
);
3845 gfc_free_expr (inquire
->blank
);
3846 gfc_free_expr (inquire
->position
);
3847 gfc_free_expr (inquire
->action
);
3848 gfc_free_expr (inquire
->read
);
3849 gfc_free_expr (inquire
->write
);
3850 gfc_free_expr (inquire
->readwrite
);
3851 gfc_free_expr (inquire
->delim
);
3852 gfc_free_expr (inquire
->encoding
);
3853 gfc_free_expr (inquire
->pad
);
3854 gfc_free_expr (inquire
->iolength
);
3855 gfc_free_expr (inquire
->convert
);
3856 gfc_free_expr (inquire
->strm_pos
);
3857 gfc_free_expr (inquire
->asynchronous
);
3858 gfc_free_expr (inquire
->decimal
);
3859 gfc_free_expr (inquire
->pending
);
3860 gfc_free_expr (inquire
->id
);
3861 gfc_free_expr (inquire
->sign
);
3862 gfc_free_expr (inquire
->size
);
3863 gfc_free_expr (inquire
->round
);
3868 /* Match an element of an INQUIRE statement. */
3870 #define RETM if (m != MATCH_NO) return m;
3873 match_inquire_element (gfc_inquire
*inquire
)
3877 m
= match_etag (&tag_unit
, &inquire
->unit
);
3878 RETM m
= match_etag (&tag_file
, &inquire
->file
);
3879 RETM m
= match_ltag (&tag_err
, &inquire
->err
);
3880 RETM m
= match_out_tag (&tag_iomsg
, &inquire
->iomsg
);
3881 RETM m
= match_out_tag (&tag_iostat
, &inquire
->iostat
);
3882 RETM m
= match_vtag (&tag_exist
, &inquire
->exist
);
3883 RETM m
= match_vtag (&tag_opened
, &inquire
->opened
);
3884 RETM m
= match_vtag (&tag_named
, &inquire
->named
);
3885 RETM m
= match_vtag (&tag_name
, &inquire
->name
);
3886 RETM m
= match_out_tag (&tag_number
, &inquire
->number
);
3887 RETM m
= match_vtag (&tag_s_access
, &inquire
->access
);
3888 RETM m
= match_vtag (&tag_sequential
, &inquire
->sequential
);
3889 RETM m
= match_vtag (&tag_direct
, &inquire
->direct
);
3890 RETM m
= match_vtag (&tag_s_form
, &inquire
->form
);
3891 RETM m
= match_vtag (&tag_formatted
, &inquire
->formatted
);
3892 RETM m
= match_vtag (&tag_unformatted
, &inquire
->unformatted
);
3893 RETM m
= match_out_tag (&tag_s_recl
, &inquire
->recl
);
3894 RETM m
= match_out_tag (&tag_nextrec
, &inquire
->nextrec
);
3895 RETM m
= match_vtag (&tag_s_blank
, &inquire
->blank
);
3896 RETM m
= match_vtag (&tag_s_position
, &inquire
->position
);
3897 RETM m
= match_vtag (&tag_s_action
, &inquire
->action
);
3898 RETM m
= match_vtag (&tag_read
, &inquire
->read
);
3899 RETM m
= match_vtag (&tag_write
, &inquire
->write
);
3900 RETM m
= match_vtag (&tag_readwrite
, &inquire
->readwrite
);
3901 RETM m
= match_vtag (&tag_s_async
, &inquire
->asynchronous
);
3902 RETM m
= match_vtag (&tag_s_delim
, &inquire
->delim
);
3903 RETM m
= match_vtag (&tag_s_decimal
, &inquire
->decimal
);
3904 RETM m
= match_vtag (&tag_size
, &inquire
->size
);
3905 RETM m
= match_vtag (&tag_s_encoding
, &inquire
->encoding
);
3906 RETM m
= match_vtag (&tag_s_round
, &inquire
->round
);
3907 RETM m
= match_vtag (&tag_s_sign
, &inquire
->sign
);
3908 RETM m
= match_vtag (&tag_s_pad
, &inquire
->pad
);
3909 RETM m
= match_vtag (&tag_iolength
, &inquire
->iolength
);
3910 RETM m
= match_vtag (&tag_convert
, &inquire
->convert
);
3911 RETM m
= match_out_tag (&tag_strm_out
, &inquire
->strm_pos
);
3912 RETM m
= match_vtag (&tag_pending
, &inquire
->pending
);
3913 RETM m
= match_vtag (&tag_id
, &inquire
->id
);
3914 RETM m
= match_vtag (&tag_s_iqstream
, &inquire
->iqstream
);
3915 RETM
return MATCH_NO
;
3922 gfc_match_inquire (void)
3924 gfc_inquire
*inquire
;
3929 m
= gfc_match_char ('(');
3933 inquire
= XCNEW (gfc_inquire
);
3935 loc
= gfc_current_locus
;
3937 m
= match_inquire_element (inquire
);
3938 if (m
== MATCH_ERROR
)
3942 m
= gfc_match_expr (&inquire
->unit
);
3943 if (m
== MATCH_ERROR
)
3949 /* See if we have the IOLENGTH form of the inquire statement. */
3950 if (inquire
->iolength
!= NULL
)
3952 if (gfc_match_char (')') != MATCH_YES
)
3955 m
= match_io_list (M_INQUIRE
, &code
);
3956 if (m
== MATCH_ERROR
)
3961 new_st
.op
= EXEC_IOLENGTH
;
3962 new_st
.expr1
= inquire
->iolength
;
3963 new_st
.ext
.inquire
= inquire
;
3965 if (gfc_pure (NULL
))
3967 gfc_free_statements (code
);
3968 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3972 if (gfc_implicit_pure (NULL
))
3973 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3975 new_st
.block
= gfc_get_code ();
3976 new_st
.block
->op
= EXEC_IOLENGTH
;
3977 terminate_io (code
);
3978 new_st
.block
->next
= code
;
3982 /* At this point, we have the non-IOLENGTH inquire statement. */
3985 if (gfc_match_char (')') == MATCH_YES
)
3987 if (gfc_match_char (',') != MATCH_YES
)
3990 m
= match_inquire_element (inquire
);
3991 if (m
== MATCH_ERROR
)
3996 if (inquire
->iolength
!= NULL
)
3998 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
4003 if (gfc_match_eos () != MATCH_YES
)
4006 if (inquire
->unit
!= NULL
&& inquire
->file
!= NULL
)
4008 gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
4009 "UNIT specifiers", &loc
);
4013 if (inquire
->unit
== NULL
&& inquire
->file
== NULL
)
4015 gfc_error ("INQUIRE statement at %L requires either FILE or "
4016 "UNIT specifier", &loc
);
4020 if (gfc_pure (NULL
))
4022 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4026 if (gfc_implicit_pure (NULL
))
4027 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
4029 if (inquire
->id
!= NULL
&& inquire
->pending
== NULL
)
4031 gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
4032 "the ID= specifier", &loc
);
4036 new_st
.op
= EXEC_INQUIRE
;
4037 new_st
.ext
.inquire
= inquire
;
4041 gfc_syntax_error (ST_INQUIRE
);
4044 gfc_free_inquire (inquire
);
4049 /* Resolve everything in a gfc_inquire structure. */
4052 gfc_resolve_inquire (gfc_inquire
*inquire
)
4054 RESOLVE_TAG (&tag_unit
, inquire
->unit
);
4055 RESOLVE_TAG (&tag_file
, inquire
->file
);
4056 RESOLVE_TAG (&tag_id
, inquire
->id
);
4058 /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4059 contexts. Thus, use an extended RESOLVE_TAG macro for that. */
4060 #define INQUIRE_RESOLVE_TAG(tag, expr) \
4061 RESOLVE_TAG (tag, expr); \
4065 sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
4066 if (gfc_check_vardef_context ((expr), false, false, false, \
4067 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 INQUIRE_RESOLVE_TAG (&tag_s_iqstream
, inquire
->iqstream
);
4105 #undef INQUIRE_RESOLVE_TAG
4107 if (gfc_reference_st_label (inquire
->err
, ST_LABEL_TARGET
) == FAILURE
)
4115 gfc_free_wait (gfc_wait
*wait
)
4120 gfc_free_expr (wait
->unit
);
4121 gfc_free_expr (wait
->iostat
);
4122 gfc_free_expr (wait
->iomsg
);
4123 gfc_free_expr (wait
->id
);
4129 gfc_resolve_wait (gfc_wait
*wait
)
4131 RESOLVE_TAG (&tag_unit
, wait
->unit
);
4132 RESOLVE_TAG (&tag_iomsg
, wait
->iomsg
);
4133 RESOLVE_TAG (&tag_iostat
, wait
->iostat
);
4134 RESOLVE_TAG (&tag_id
, wait
->id
);
4136 if (gfc_reference_st_label (wait
->err
, ST_LABEL_TARGET
) == FAILURE
)
4139 if (gfc_reference_st_label (wait
->end
, ST_LABEL_TARGET
) == FAILURE
)
4145 /* Match an element of a WAIT statement. */
4147 #define RETM if (m != MATCH_NO) return m;
4150 match_wait_element (gfc_wait
*wait
)
4154 m
= match_etag (&tag_unit
, &wait
->unit
);
4155 RETM m
= match_ltag (&tag_err
, &wait
->err
);
4156 RETM m
= match_ltag (&tag_end
, &wait
->eor
);
4157 RETM m
= match_ltag (&tag_eor
, &wait
->end
);
4158 RETM m
= match_out_tag (&tag_iomsg
, &wait
->iomsg
);
4159 RETM m
= match_out_tag (&tag_iostat
, &wait
->iostat
);
4160 RETM m
= match_etag (&tag_id
, &wait
->id
);
4161 RETM
return MATCH_NO
;
4168 gfc_match_wait (void)
4173 m
= gfc_match_char ('(');
4177 wait
= XCNEW (gfc_wait
);
4179 m
= match_wait_element (wait
);
4180 if (m
== MATCH_ERROR
)
4184 m
= gfc_match_expr (&wait
->unit
);
4185 if (m
== MATCH_ERROR
)
4193 if (gfc_match_char (')') == MATCH_YES
)
4195 if (gfc_match_char (',') != MATCH_YES
)
4198 m
= match_wait_element (wait
);
4199 if (m
== MATCH_ERROR
)
4205 if (gfc_notify_std (GFC_STD_F2003
, "WAIT at %C "
4206 "not allowed in Fortran 95") == FAILURE
)
4209 if (gfc_pure (NULL
))
4211 gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4215 if (gfc_implicit_pure (NULL
))
4216 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
4218 new_st
.op
= EXEC_WAIT
;
4219 new_st
.ext
.wait
= wait
;
4224 gfc_syntax_error (ST_WAIT
);
4227 gfc_free_wait (wait
);