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 (int 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 (0);
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')
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
;
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
);
1323 /* Match I/O tags that cause variables to become redefined. */
1326 match_out_tag (const io_tag
*tag
, gfc_expr
**result
)
1330 m
= match_vtag (tag
, result
);
1332 gfc_check_do_variable ((*result
)->symtree
);
1338 /* Match a label I/O tag. */
1341 match_ltag (const io_tag
*tag
, gfc_st_label
** label
)
1347 m
= gfc_match (tag
->spec
);
1351 m
= gfc_match (tag
->value
, label
);
1354 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1360 gfc_error ("Duplicate %s label specification at %C", tag
->name
);
1364 if (gfc_reference_st_label (*label
, ST_LABEL_TARGET
) == FAILURE
)
1371 /* Resolution of the FORMAT tag, to be called from resolve_tag. */
1374 resolve_tag_format (const gfc_expr
*e
)
1376 if (e
->expr_type
== EXPR_CONSTANT
1377 && (e
->ts
.type
!= BT_CHARACTER
1378 || e
->ts
.kind
!= gfc_default_character_kind
))
1380 gfc_error ("Constant expression in FORMAT tag at %L must be "
1381 "of type default CHARACTER", &e
->where
);
1385 /* If e's rank is zero and e is not an element of an array, it should be
1386 of integer or character type. The integer variable should be
1389 && (e
->expr_type
!= EXPR_VARIABLE
1390 || e
->symtree
== NULL
1391 || e
->symtree
->n
.sym
->as
== NULL
1392 || e
->symtree
->n
.sym
->as
->rank
== 0))
1394 if (e
->ts
.type
!= BT_CHARACTER
&& e
->ts
.type
!= BT_INTEGER
)
1396 gfc_error ("FORMAT tag at %L must be of type CHARACTER or INTEGER",
1400 else if (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_VARIABLE
)
1402 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: ASSIGNED "
1403 "variable in FORMAT tag at %L", &e
->where
)
1406 if (e
->symtree
->n
.sym
->attr
.assign
!= 1)
1408 gfc_error ("Variable '%s' at %L has not been assigned a "
1409 "format label", e
->symtree
->n
.sym
->name
, &e
->where
);
1413 else if (e
->ts
.type
== BT_INTEGER
)
1415 gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
1416 "variable", gfc_basic_typename (e
->ts
.type
), &e
->where
);
1423 /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
1424 It may be assigned an Hollerith constant. */
1425 if (e
->ts
.type
!= BT_CHARACTER
)
1427 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: Non-character "
1428 "in FORMAT tag at %L", &e
->where
) == FAILURE
)
1431 if (e
->rank
== 0 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
)
1433 gfc_error ("Non-character assumed shape array element in FORMAT"
1434 " tag at %L", &e
->where
);
1438 if (e
->rank
== 0 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
)
1440 gfc_error ("Non-character assumed size array element in FORMAT"
1441 " tag at %L", &e
->where
);
1445 if (e
->rank
== 0 && e
->symtree
->n
.sym
->attr
.pointer
)
1447 gfc_error ("Non-character pointer array element in FORMAT tag at %L",
1457 /* Do expression resolution and type-checking on an expression tag. */
1460 resolve_tag (const io_tag
*tag
, gfc_expr
*e
)
1465 if (gfc_resolve_expr (e
) == FAILURE
)
1468 if (tag
== &tag_format
)
1469 return resolve_tag_format (e
);
1471 if (e
->ts
.type
!= tag
->type
)
1473 gfc_error ("%s tag at %L must be of type %s", tag
->name
,
1474 &e
->where
, gfc_basic_typename (tag
->type
));
1480 gfc_error ("%s tag at %L must be scalar", tag
->name
, &e
->where
);
1484 if (tag
== &tag_iomsg
)
1486 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: IOMSG tag at %L",
1487 &e
->where
) == FAILURE
)
1491 if ((tag
== &tag_iostat
|| tag
== &tag_size
|| tag
== &tag_iolength
)
1492 && e
->ts
.kind
!= gfc_default_integer_kind
)
1494 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 95 requires default "
1495 "INTEGER in %s tag at %L", tag
->name
, &e
->where
)
1500 if (tag
== &tag_exist
&& e
->ts
.kind
!= gfc_default_logical_kind
)
1502 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Nondefault LOGICAL "
1503 "in %s tag at %L", tag
->name
, &e
->where
)
1508 if (tag
== &tag_convert
)
1510 if (gfc_notify_std (GFC_STD_GNU
, "Extension: CONVERT tag at %L",
1511 &e
->where
) == FAILURE
)
1519 /* Match a single tag of an OPEN statement. */
1522 match_open_element (gfc_open
*open
)
1526 m
= match_etag (&tag_e_async
, &open
->asynchronous
);
1529 m
= match_etag (&tag_unit
, &open
->unit
);
1532 m
= match_out_tag (&tag_iomsg
, &open
->iomsg
);
1535 m
= match_out_tag (&tag_iostat
, &open
->iostat
);
1538 m
= match_etag (&tag_file
, &open
->file
);
1541 m
= match_etag (&tag_status
, &open
->status
);
1544 m
= match_etag (&tag_e_access
, &open
->access
);
1547 m
= match_etag (&tag_e_form
, &open
->form
);
1550 m
= match_etag (&tag_e_recl
, &open
->recl
);
1553 m
= match_etag (&tag_e_blank
, &open
->blank
);
1556 m
= match_etag (&tag_e_position
, &open
->position
);
1559 m
= match_etag (&tag_e_action
, &open
->action
);
1562 m
= match_etag (&tag_e_delim
, &open
->delim
);
1565 m
= match_etag (&tag_e_pad
, &open
->pad
);
1568 m
= match_etag (&tag_e_decimal
, &open
->decimal
);
1571 m
= match_etag (&tag_e_encoding
, &open
->encoding
);
1574 m
= match_etag (&tag_e_round
, &open
->round
);
1577 m
= match_etag (&tag_e_sign
, &open
->sign
);
1580 m
= match_ltag (&tag_err
, &open
->err
);
1583 m
= match_etag (&tag_convert
, &open
->convert
);
1586 m
= match_out_tag (&tag_newunit
, &open
->newunit
);
1594 /* Free the gfc_open structure and all the expressions it contains. */
1597 gfc_free_open (gfc_open
*open
)
1602 gfc_free_expr (open
->unit
);
1603 gfc_free_expr (open
->iomsg
);
1604 gfc_free_expr (open
->iostat
);
1605 gfc_free_expr (open
->file
);
1606 gfc_free_expr (open
->status
);
1607 gfc_free_expr (open
->access
);
1608 gfc_free_expr (open
->form
);
1609 gfc_free_expr (open
->recl
);
1610 gfc_free_expr (open
->blank
);
1611 gfc_free_expr (open
->position
);
1612 gfc_free_expr (open
->action
);
1613 gfc_free_expr (open
->delim
);
1614 gfc_free_expr (open
->pad
);
1615 gfc_free_expr (open
->decimal
);
1616 gfc_free_expr (open
->encoding
);
1617 gfc_free_expr (open
->round
);
1618 gfc_free_expr (open
->sign
);
1619 gfc_free_expr (open
->convert
);
1620 gfc_free_expr (open
->asynchronous
);
1621 gfc_free_expr (open
->newunit
);
1626 /* Resolve everything in a gfc_open structure. */
1629 gfc_resolve_open (gfc_open
*open
)
1632 RESOLVE_TAG (&tag_unit
, open
->unit
);
1633 RESOLVE_TAG (&tag_iomsg
, open
->iomsg
);
1634 RESOLVE_TAG (&tag_iostat
, open
->iostat
);
1635 RESOLVE_TAG (&tag_file
, open
->file
);
1636 RESOLVE_TAG (&tag_status
, open
->status
);
1637 RESOLVE_TAG (&tag_e_access
, open
->access
);
1638 RESOLVE_TAG (&tag_e_form
, open
->form
);
1639 RESOLVE_TAG (&tag_e_recl
, open
->recl
);
1640 RESOLVE_TAG (&tag_e_blank
, open
->blank
);
1641 RESOLVE_TAG (&tag_e_position
, open
->position
);
1642 RESOLVE_TAG (&tag_e_action
, open
->action
);
1643 RESOLVE_TAG (&tag_e_delim
, open
->delim
);
1644 RESOLVE_TAG (&tag_e_pad
, open
->pad
);
1645 RESOLVE_TAG (&tag_e_decimal
, open
->decimal
);
1646 RESOLVE_TAG (&tag_e_encoding
, open
->encoding
);
1647 RESOLVE_TAG (&tag_e_async
, open
->asynchronous
);
1648 RESOLVE_TAG (&tag_e_round
, open
->round
);
1649 RESOLVE_TAG (&tag_e_sign
, open
->sign
);
1650 RESOLVE_TAG (&tag_convert
, open
->convert
);
1651 RESOLVE_TAG (&tag_newunit
, open
->newunit
);
1653 if (gfc_reference_st_label (open
->err
, ST_LABEL_TARGET
) == FAILURE
)
1660 /* Check if a given value for a SPECIFIER is either in the list of values
1661 allowed in F95 or F2003, issuing an error message and returning a zero
1662 value if it is not allowed. */
1665 compare_to_allowed_values (const char *specifier
, const char *allowed
[],
1666 const char *allowed_f2003
[],
1667 const char *allowed_gnu
[], gfc_char_t
*value
,
1668 const char *statement
, bool warn
)
1673 len
= gfc_wide_strlen (value
);
1676 for (len
--; len
> 0; len
--)
1677 if (value
[len
] != ' ')
1682 for (i
= 0; allowed
[i
]; i
++)
1683 if (len
== strlen (allowed
[i
])
1684 && gfc_wide_strncasecmp (value
, allowed
[i
], strlen (allowed
[i
])) == 0)
1687 for (i
= 0; allowed_f2003
&& allowed_f2003
[i
]; i
++)
1688 if (len
== strlen (allowed_f2003
[i
])
1689 && gfc_wide_strncasecmp (value
, allowed_f2003
[i
],
1690 strlen (allowed_f2003
[i
])) == 0)
1692 notification n
= gfc_notification_std (GFC_STD_F2003
);
1694 if (n
== WARNING
|| (warn
&& n
== ERROR
))
1696 gfc_warning ("Fortran 2003: %s specifier in %s statement at %C "
1697 "has value '%s'", specifier
, statement
,
1704 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: %s specifier in "
1705 "%s statement at %C has value '%s'", specifier
,
1706 statement
, allowed_f2003
[i
]);
1714 for (i
= 0; allowed_gnu
&& allowed_gnu
[i
]; i
++)
1715 if (len
== strlen (allowed_gnu
[i
])
1716 && gfc_wide_strncasecmp (value
, allowed_gnu
[i
],
1717 strlen (allowed_gnu
[i
])) == 0)
1719 notification n
= gfc_notification_std (GFC_STD_GNU
);
1721 if (n
== WARNING
|| (warn
&& n
== ERROR
))
1723 gfc_warning ("Extension: %s specifier in %s statement at %C "
1724 "has value '%s'", specifier
, statement
,
1731 gfc_notify_std (GFC_STD_GNU
, "Extension: %s specifier in "
1732 "%s statement at %C has value '%s'", specifier
,
1733 statement
, allowed_gnu
[i
]);
1743 char *s
= gfc_widechar_to_char (value
, -1);
1744 gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
1745 specifier
, statement
, s
);
1751 char *s
= gfc_widechar_to_char (value
, -1);
1752 gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
1753 specifier
, statement
, s
);
1760 /* Match an OPEN statement. */
1763 gfc_match_open (void)
1769 m
= gfc_match_char ('(');
1773 open
= XCNEW (gfc_open
);
1775 m
= match_open_element (open
);
1777 if (m
== MATCH_ERROR
)
1781 m
= gfc_match_expr (&open
->unit
);
1782 if (m
== MATCH_ERROR
)
1788 if (gfc_match_char (')') == MATCH_YES
)
1790 if (gfc_match_char (',') != MATCH_YES
)
1793 m
= match_open_element (open
);
1794 if (m
== MATCH_ERROR
)
1800 if (gfc_match_eos () == MATCH_NO
)
1803 if (gfc_pure (NULL
))
1805 gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1809 warn
= (open
->err
|| open
->iostat
) ? true : false;
1811 /* Checks on NEWUNIT specifier. */
1816 gfc_error ("UNIT specifier not allowed with NEWUNIT at %C");
1820 if (!(open
->file
|| (open
->status
1821 && gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
1822 "scratch", 7) == 0)))
1824 gfc_error ("NEWUNIT specifier must have FILE= "
1825 "or STATUS='scratch' at %C");
1829 else if (!open
->unit
)
1831 gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified");
1835 /* Checks on the ACCESS specifier. */
1836 if (open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
)
1838 static const char *access_f95
[] = { "SEQUENTIAL", "DIRECT", NULL
};
1839 static const char *access_f2003
[] = { "STREAM", NULL
};
1840 static const char *access_gnu
[] = { "APPEND", NULL
};
1842 if (!compare_to_allowed_values ("ACCESS", access_f95
, access_f2003
,
1844 open
->access
->value
.character
.string
,
1849 /* Checks on the ACTION specifier. */
1850 if (open
->action
&& open
->action
->expr_type
== EXPR_CONSTANT
)
1852 static const char *action
[] = { "READ", "WRITE", "READWRITE", NULL
};
1854 if (!compare_to_allowed_values ("ACTION", action
, NULL
, NULL
,
1855 open
->action
->value
.character
.string
,
1860 /* Checks on the ASYNCHRONOUS specifier. */
1861 if (open
->asynchronous
)
1863 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ASYNCHRONOUS= at %C "
1864 "not allowed in Fortran 95") == FAILURE
)
1867 if (open
->asynchronous
->expr_type
== EXPR_CONSTANT
)
1869 static const char * asynchronous
[] = { "YES", "NO", NULL
};
1871 if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous
,
1872 NULL
, NULL
, open
->asynchronous
->value
.character
.string
,
1878 /* Checks on the BLANK specifier. */
1881 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BLANK= at %C "
1882 "not allowed in Fortran 95") == FAILURE
)
1885 if (open
->blank
->expr_type
== EXPR_CONSTANT
)
1887 static const char *blank
[] = { "ZERO", "NULL", NULL
};
1889 if (!compare_to_allowed_values ("BLANK", blank
, NULL
, NULL
,
1890 open
->blank
->value
.character
.string
,
1896 /* Checks on the DECIMAL specifier. */
1899 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: DECIMAL= at %C "
1900 "not allowed in Fortran 95") == FAILURE
)
1903 if (open
->decimal
->expr_type
== EXPR_CONSTANT
)
1905 static const char * decimal
[] = { "COMMA", "POINT", NULL
};
1907 if (!compare_to_allowed_values ("DECIMAL", decimal
, NULL
, NULL
,
1908 open
->decimal
->value
.character
.string
,
1914 /* Checks on the DELIM specifier. */
1917 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: DELIM= at %C "
1918 "not allowed in Fortran 95") == FAILURE
)
1921 if (open
->delim
->expr_type
== EXPR_CONSTANT
)
1923 static const char *delim
[] = { "APOSTROPHE", "QUOTE", "NONE", NULL
};
1925 if (!compare_to_allowed_values ("DELIM", delim
, NULL
, NULL
,
1926 open
->delim
->value
.character
.string
,
1932 /* Checks on the ENCODING specifier. */
1935 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ENCODING= at %C "
1936 "not allowed in Fortran 95") == FAILURE
)
1939 if (open
->encoding
->expr_type
== EXPR_CONSTANT
)
1941 static const char * encoding
[] = { "DEFAULT", "UTF-8", NULL
};
1943 if (!compare_to_allowed_values ("ENCODING", encoding
, NULL
, NULL
,
1944 open
->encoding
->value
.character
.string
,
1950 /* Checks on the FORM specifier. */
1951 if (open
->form
&& open
->form
->expr_type
== EXPR_CONSTANT
)
1953 static const char *form
[] = { "FORMATTED", "UNFORMATTED", NULL
};
1955 if (!compare_to_allowed_values ("FORM", form
, NULL
, NULL
,
1956 open
->form
->value
.character
.string
,
1961 /* Checks on the PAD specifier. */
1962 if (open
->pad
&& open
->pad
->expr_type
== EXPR_CONSTANT
)
1964 static const char *pad
[] = { "YES", "NO", NULL
};
1966 if (!compare_to_allowed_values ("PAD", pad
, NULL
, NULL
,
1967 open
->pad
->value
.character
.string
,
1972 /* Checks on the POSITION specifier. */
1973 if (open
->position
&& open
->position
->expr_type
== EXPR_CONSTANT
)
1975 static const char *position
[] = { "ASIS", "REWIND", "APPEND", NULL
};
1977 if (!compare_to_allowed_values ("POSITION", position
, NULL
, NULL
,
1978 open
->position
->value
.character
.string
,
1983 /* Checks on the ROUND specifier. */
1986 if (gfc_notify_std (GFC_STD_F2003
, "Fortran F2003: ROUND= at %C "
1987 "not allowed in Fortran 95") == FAILURE
)
1990 if (open
->round
->expr_type
== EXPR_CONSTANT
)
1992 static const char * round
[] = { "UP", "DOWN", "ZERO", "NEAREST",
1993 "COMPATIBLE", "PROCESSOR_DEFINED",
1996 if (!compare_to_allowed_values ("ROUND", round
, NULL
, NULL
,
1997 open
->round
->value
.character
.string
,
2003 /* Checks on the SIGN specifier. */
2006 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: SIGN= at %C "
2007 "not allowed in Fortran 95") == FAILURE
)
2010 if (open
->sign
->expr_type
== EXPR_CONSTANT
)
2012 static const char * sign
[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
2015 if (!compare_to_allowed_values ("SIGN", sign
, NULL
, NULL
,
2016 open
->sign
->value
.character
.string
,
2022 #define warn_or_error(...) \
2025 gfc_warning (__VA_ARGS__); \
2028 gfc_error (__VA_ARGS__); \
2033 /* Checks on the RECL specifier. */
2034 if (open
->recl
&& open
->recl
->expr_type
== EXPR_CONSTANT
2035 && open
->recl
->ts
.type
== BT_INTEGER
2036 && mpz_sgn (open
->recl
->value
.integer
) != 1)
2038 warn_or_error ("RECL in OPEN statement at %C must be positive");
2041 /* Checks on the STATUS specifier. */
2042 if (open
->status
&& open
->status
->expr_type
== EXPR_CONSTANT
)
2044 static const char *status
[] = { "OLD", "NEW", "SCRATCH",
2045 "REPLACE", "UNKNOWN", NULL
};
2047 if (!compare_to_allowed_values ("STATUS", status
, NULL
, NULL
,
2048 open
->status
->value
.character
.string
,
2052 /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2053 the FILE= specifier shall appear. */
2054 if (open
->file
== NULL
2055 && (gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2057 || gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2060 char *s
= gfc_widechar_to_char (open
->status
->value
.character
.string
,
2062 warn_or_error ("The STATUS specified in OPEN statement at %C is "
2063 "'%s' and no FILE specifier is present", s
);
2067 /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2068 the FILE= specifier shall not appear. */
2069 if (gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2070 "scratch", 7) == 0 && open
->file
)
2072 warn_or_error ("The STATUS specified in OPEN statement at %C "
2073 "cannot have the value SCRATCH if a FILE specifier "
2078 /* Things that are not allowed for unformatted I/O. */
2079 if (open
->form
&& open
->form
->expr_type
== EXPR_CONSTANT
2080 && (open
->delim
|| open
->decimal
|| open
->encoding
|| open
->round
2081 || open
->sign
|| open
->pad
|| open
->blank
)
2082 && gfc_wide_strncasecmp (open
->form
->value
.character
.string
,
2083 "unformatted", 11) == 0)
2085 const char *spec
= (open
->delim
? "DELIM "
2086 : (open
->pad
? "PAD " : open
->blank
2089 warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
2090 "unformatted I/O", spec
);
2093 if (open
->recl
&& open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
2094 && gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2097 warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
2102 && open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
2103 && !(gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2104 "sequential", 10) == 0
2105 || gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2107 || gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2110 warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
2111 "for stream or sequential ACCESS");
2114 #undef warn_or_error
2116 new_st
.op
= EXEC_OPEN
;
2117 new_st
.ext
.open
= open
;
2121 gfc_syntax_error (ST_OPEN
);
2124 gfc_free_open (open
);
2129 /* Free a gfc_close structure an all its expressions. */
2132 gfc_free_close (gfc_close
*close
)
2137 gfc_free_expr (close
->unit
);
2138 gfc_free_expr (close
->iomsg
);
2139 gfc_free_expr (close
->iostat
);
2140 gfc_free_expr (close
->status
);
2145 /* Match elements of a CLOSE statement. */
2148 match_close_element (gfc_close
*close
)
2152 m
= match_etag (&tag_unit
, &close
->unit
);
2155 m
= match_etag (&tag_status
, &close
->status
);
2158 m
= match_out_tag (&tag_iomsg
, &close
->iomsg
);
2161 m
= match_out_tag (&tag_iostat
, &close
->iostat
);
2164 m
= match_ltag (&tag_err
, &close
->err
);
2172 /* Match a CLOSE statement. */
2175 gfc_match_close (void)
2181 m
= gfc_match_char ('(');
2185 close
= XCNEW (gfc_close
);
2187 m
= match_close_element (close
);
2189 if (m
== MATCH_ERROR
)
2193 m
= gfc_match_expr (&close
->unit
);
2196 if (m
== MATCH_ERROR
)
2202 if (gfc_match_char (')') == MATCH_YES
)
2204 if (gfc_match_char (',') != MATCH_YES
)
2207 m
= match_close_element (close
);
2208 if (m
== MATCH_ERROR
)
2214 if (gfc_match_eos () == MATCH_NO
)
2217 if (gfc_pure (NULL
))
2219 gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2223 warn
= (close
->iostat
|| close
->err
) ? true : false;
2225 /* Checks on the STATUS specifier. */
2226 if (close
->status
&& close
->status
->expr_type
== EXPR_CONSTANT
)
2228 static const char *status
[] = { "KEEP", "DELETE", NULL
};
2230 if (!compare_to_allowed_values ("STATUS", status
, NULL
, NULL
,
2231 close
->status
->value
.character
.string
,
2236 new_st
.op
= EXEC_CLOSE
;
2237 new_st
.ext
.close
= close
;
2241 gfc_syntax_error (ST_CLOSE
);
2244 gfc_free_close (close
);
2249 /* Resolve everything in a gfc_close structure. */
2252 gfc_resolve_close (gfc_close
*close
)
2254 RESOLVE_TAG (&tag_unit
, close
->unit
);
2255 RESOLVE_TAG (&tag_iomsg
, close
->iomsg
);
2256 RESOLVE_TAG (&tag_iostat
, close
->iostat
);
2257 RESOLVE_TAG (&tag_status
, close
->status
);
2259 if (gfc_reference_st_label (close
->err
, ST_LABEL_TARGET
) == FAILURE
)
2262 if (close
->unit
->expr_type
== EXPR_CONSTANT
2263 && close
->unit
->ts
.type
== BT_INTEGER
2264 && mpz_sgn (close
->unit
->value
.integer
) < 0)
2266 gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2267 &close
->unit
->where
);
2274 /* Free a gfc_filepos structure. */
2277 gfc_free_filepos (gfc_filepos
*fp
)
2279 gfc_free_expr (fp
->unit
);
2280 gfc_free_expr (fp
->iomsg
);
2281 gfc_free_expr (fp
->iostat
);
2286 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
2289 match_file_element (gfc_filepos
*fp
)
2293 m
= match_etag (&tag_unit
, &fp
->unit
);
2296 m
= match_out_tag (&tag_iomsg
, &fp
->iomsg
);
2299 m
= match_out_tag (&tag_iostat
, &fp
->iostat
);
2302 m
= match_ltag (&tag_err
, &fp
->err
);
2310 /* Match the second half of the file-positioning statements, REWIND,
2311 BACKSPACE, ENDFILE, or the FLUSH statement. */
2314 match_filepos (gfc_statement st
, gfc_exec_op op
)
2319 fp
= XCNEW (gfc_filepos
);
2321 if (gfc_match_char ('(') == MATCH_NO
)
2323 m
= gfc_match_expr (&fp
->unit
);
2324 if (m
== MATCH_ERROR
)
2332 m
= match_file_element (fp
);
2333 if (m
== MATCH_ERROR
)
2337 m
= gfc_match_expr (&fp
->unit
);
2338 if (m
== MATCH_ERROR
)
2346 if (gfc_match_char (')') == MATCH_YES
)
2348 if (gfc_match_char (',') != MATCH_YES
)
2351 m
= match_file_element (fp
);
2352 if (m
== MATCH_ERROR
)
2359 if (gfc_match_eos () != MATCH_YES
)
2362 if (gfc_pure (NULL
))
2364 gfc_error ("%s statement not allowed in PURE procedure at %C",
2365 gfc_ascii_statement (st
));
2371 new_st
.ext
.filepos
= fp
;
2375 gfc_syntax_error (st
);
2378 gfc_free_filepos (fp
);
2384 gfc_resolve_filepos (gfc_filepos
*fp
)
2386 RESOLVE_TAG (&tag_unit
, fp
->unit
);
2387 RESOLVE_TAG (&tag_iostat
, fp
->iostat
);
2388 RESOLVE_TAG (&tag_iomsg
, fp
->iomsg
);
2389 if (gfc_reference_st_label (fp
->err
, ST_LABEL_TARGET
) == FAILURE
)
2392 if (fp
->unit
->expr_type
== EXPR_CONSTANT
2393 && fp
->unit
->ts
.type
== BT_INTEGER
2394 && mpz_sgn (fp
->unit
->value
.integer
) < 0)
2396 gfc_error ("UNIT number in statement at %L must be non-negative",
2404 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2405 and the FLUSH statement. */
2408 gfc_match_endfile (void)
2410 return match_filepos (ST_END_FILE
, EXEC_ENDFILE
);
2414 gfc_match_backspace (void)
2416 return match_filepos (ST_BACKSPACE
, EXEC_BACKSPACE
);
2420 gfc_match_rewind (void)
2422 return match_filepos (ST_REWIND
, EXEC_REWIND
);
2426 gfc_match_flush (void)
2428 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: FLUSH statement at %C")
2432 return match_filepos (ST_FLUSH
, EXEC_FLUSH
);
2435 /******************** Data Transfer Statements *********************/
2437 /* Return a default unit number. */
2440 default_unit (io_kind k
)
2449 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, unit
);
2453 /* Match a unit specification for a data transfer statement. */
2456 match_dt_unit (io_kind k
, gfc_dt
*dt
)
2460 if (gfc_match_char ('*') == MATCH_YES
)
2462 if (dt
->io_unit
!= NULL
)
2465 dt
->io_unit
= default_unit (k
);
2469 if (gfc_match_expr (&e
) == MATCH_YES
)
2471 if (dt
->io_unit
!= NULL
)
2484 gfc_error ("Duplicate UNIT specification at %C");
2489 /* Match a format specification. */
2492 match_dt_format (gfc_dt
*dt
)
2496 gfc_st_label
*label
;
2499 where
= gfc_current_locus
;
2501 if (gfc_match_char ('*') == MATCH_YES
)
2503 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2506 dt
->format_label
= &format_asterisk
;
2510 if ((m
= gfc_match_st_label (&label
)) == MATCH_YES
)
2512 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2514 gfc_free_st_label (label
);
2518 if (gfc_reference_st_label (label
, ST_LABEL_FORMAT
) == FAILURE
)
2521 dt
->format_label
= label
;
2524 else if (m
== MATCH_ERROR
)
2525 /* The label was zero or too large. Emit the correct diagnosis. */
2528 if (gfc_match_expr (&e
) == MATCH_YES
)
2530 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
2535 dt
->format_expr
= e
;
2539 gfc_current_locus
= where
; /* The only case where we have to restore */
2544 gfc_error ("Duplicate format specification at %C");
2549 /* Traverse a namelist that is part of a READ statement to make sure
2550 that none of the variables in the namelist are INTENT(IN). Returns
2551 nonzero if we find such a variable. */
2554 check_namelist (gfc_symbol
*sym
)
2558 for (p
= sym
->namelist
; p
; p
= p
->next
)
2559 if (p
->sym
->attr
.intent
== INTENT_IN
)
2561 gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
2562 p
->sym
->name
, sym
->name
);
2570 /* Match a single data transfer element. */
2573 match_dt_element (io_kind k
, gfc_dt
*dt
)
2575 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2579 if (gfc_match (" unit =") == MATCH_YES
)
2581 m
= match_dt_unit (k
, dt
);
2586 if (gfc_match (" fmt =") == MATCH_YES
)
2588 m
= match_dt_format (dt
);
2593 if (gfc_match (" nml = %n", name
) == MATCH_YES
)
2595 if (dt
->namelist
!= NULL
)
2597 gfc_error ("Duplicate NML specification at %C");
2601 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
2604 if (sym
== NULL
|| sym
->attr
.flavor
!= FL_NAMELIST
)
2606 gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
2607 sym
!= NULL
? sym
->name
: name
);
2612 if (k
== M_READ
&& check_namelist (sym
))
2618 m
= match_etag (&tag_e_async
, &dt
->asynchronous
);
2621 m
= match_etag (&tag_e_blank
, &dt
->blank
);
2624 m
= match_etag (&tag_e_delim
, &dt
->delim
);
2627 m
= match_etag (&tag_e_pad
, &dt
->pad
);
2630 m
= match_etag (&tag_e_sign
, &dt
->sign
);
2633 m
= match_etag (&tag_e_round
, &dt
->round
);
2636 m
= match_out_tag (&tag_id
, &dt
->id
);
2639 m
= match_etag (&tag_e_decimal
, &dt
->decimal
);
2642 m
= match_etag (&tag_rec
, &dt
->rec
);
2645 m
= match_etag (&tag_spos
, &dt
->pos
);
2648 m
= match_out_tag (&tag_iomsg
, &dt
->iomsg
);
2651 m
= match_out_tag (&tag_iostat
, &dt
->iostat
);
2654 m
= match_ltag (&tag_err
, &dt
->err
);
2656 dt
->err_where
= gfc_current_locus
;
2659 m
= match_etag (&tag_advance
, &dt
->advance
);
2662 m
= match_out_tag (&tag_size
, &dt
->size
);
2666 m
= match_ltag (&tag_end
, &dt
->end
);
2671 gfc_error ("END tag at %C not allowed in output statement");
2674 dt
->end_where
= gfc_current_locus
;
2679 m
= match_ltag (&tag_eor
, &dt
->eor
);
2681 dt
->eor_where
= gfc_current_locus
;
2689 /* Free a data transfer structure and everything below it. */
2692 gfc_free_dt (gfc_dt
*dt
)
2697 gfc_free_expr (dt
->io_unit
);
2698 gfc_free_expr (dt
->format_expr
);
2699 gfc_free_expr (dt
->rec
);
2700 gfc_free_expr (dt
->advance
);
2701 gfc_free_expr (dt
->iomsg
);
2702 gfc_free_expr (dt
->iostat
);
2703 gfc_free_expr (dt
->size
);
2704 gfc_free_expr (dt
->pad
);
2705 gfc_free_expr (dt
->delim
);
2706 gfc_free_expr (dt
->sign
);
2707 gfc_free_expr (dt
->round
);
2708 gfc_free_expr (dt
->blank
);
2709 gfc_free_expr (dt
->decimal
);
2710 gfc_free_expr (dt
->extra_comma
);
2711 gfc_free_expr (dt
->pos
);
2716 /* Resolve everything in a gfc_dt structure. */
2719 gfc_resolve_dt (gfc_dt
*dt
, locus
*loc
)
2723 RESOLVE_TAG (&tag_format
, dt
->format_expr
);
2724 RESOLVE_TAG (&tag_rec
, dt
->rec
);
2725 RESOLVE_TAG (&tag_spos
, dt
->pos
);
2726 RESOLVE_TAG (&tag_advance
, dt
->advance
);
2727 RESOLVE_TAG (&tag_id
, dt
->id
);
2728 RESOLVE_TAG (&tag_iomsg
, dt
->iomsg
);
2729 RESOLVE_TAG (&tag_iostat
, dt
->iostat
);
2730 RESOLVE_TAG (&tag_size
, dt
->size
);
2731 RESOLVE_TAG (&tag_e_pad
, dt
->pad
);
2732 RESOLVE_TAG (&tag_e_delim
, dt
->delim
);
2733 RESOLVE_TAG (&tag_e_sign
, dt
->sign
);
2734 RESOLVE_TAG (&tag_e_round
, dt
->round
);
2735 RESOLVE_TAG (&tag_e_blank
, dt
->blank
);
2736 RESOLVE_TAG (&tag_e_decimal
, dt
->decimal
);
2737 RESOLVE_TAG (&tag_e_async
, dt
->asynchronous
);
2742 gfc_error ("UNIT not specified at %L", loc
);
2746 if (gfc_resolve_expr (e
) == SUCCESS
2747 && (e
->ts
.type
!= BT_INTEGER
2748 && (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_VARIABLE
)))
2750 /* If there is no extra comma signifying the "format" form of the IO
2751 statement, then this must be an error. */
2752 if (!dt
->extra_comma
)
2754 gfc_error ("UNIT specification at %L must be an INTEGER expression "
2755 "or a CHARACTER variable", &e
->where
);
2760 /* At this point, we have an extra comma. If io_unit has arrived as
2761 type character, we assume its really the "format" form of the I/O
2762 statement. We set the io_unit to the default unit and format to
2763 the character expression. See F95 Standard section 9.4. */
2765 k
= dt
->extra_comma
->value
.iokind
;
2766 if (e
->ts
.type
== BT_CHARACTER
&& (k
== M_READ
|| k
== M_PRINT
))
2768 dt
->format_expr
= dt
->io_unit
;
2769 dt
->io_unit
= default_unit (k
);
2771 /* Free this pointer now so that a warning/error is not triggered
2772 below for the "Extension". */
2773 gfc_free_expr (dt
->extra_comma
);
2774 dt
->extra_comma
= NULL
;
2779 gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
2780 &dt
->extra_comma
->where
);
2786 if (e
->ts
.type
== BT_CHARACTER
)
2788 if (gfc_has_vector_index (e
))
2790 gfc_error ("Internal unit with vector subscript at %L", &e
->where
);
2795 if (e
->rank
&& e
->ts
.type
!= BT_CHARACTER
)
2797 gfc_error ("External IO UNIT cannot be an array at %L", &e
->where
);
2801 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_INTEGER
2802 && mpz_sgn (e
->value
.integer
) < 0)
2804 gfc_error ("UNIT number in statement at %L must be non-negative", &e
->where
);
2809 && gfc_notify_std (GFC_STD_GNU
, "Extension: Comma before i/o "
2810 "item list at %L", &dt
->extra_comma
->where
) == FAILURE
)
2815 if (gfc_reference_st_label (dt
->err
, ST_LABEL_TARGET
) == FAILURE
)
2817 if (dt
->err
->defined
== ST_LABEL_UNKNOWN
)
2819 gfc_error ("ERR tag label %d at %L not defined",
2820 dt
->err
->value
, &dt
->err_where
);
2827 if (gfc_reference_st_label (dt
->end
, ST_LABEL_TARGET
) == FAILURE
)
2829 if (dt
->end
->defined
== ST_LABEL_UNKNOWN
)
2831 gfc_error ("END tag label %d at %L not defined",
2832 dt
->end
->value
, &dt
->end_where
);
2839 if (gfc_reference_st_label (dt
->eor
, ST_LABEL_TARGET
) == FAILURE
)
2841 if (dt
->eor
->defined
== ST_LABEL_UNKNOWN
)
2843 gfc_error ("EOR tag label %d at %L not defined",
2844 dt
->eor
->value
, &dt
->eor_where
);
2849 /* Check the format label actually exists. */
2850 if (dt
->format_label
&& dt
->format_label
!= &format_asterisk
2851 && dt
->format_label
->defined
== ST_LABEL_UNKNOWN
)
2853 gfc_error ("FORMAT label %d at %L not defined", dt
->format_label
->value
,
2854 &dt
->format_label
->where
);
2861 /* Given an io_kind, return its name. */
2864 io_kind_name (io_kind k
)
2883 gfc_internal_error ("io_kind_name(): bad I/O-kind");
2890 /* Match an IO iteration statement of the form:
2892 ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
2894 which is equivalent to a single IO element. This function is
2895 mutually recursive with match_io_element(). */
2897 static match
match_io_element (io_kind
, gfc_code
**);
2900 match_io_iterator (io_kind k
, gfc_code
**result
)
2902 gfc_code
*head
, *tail
, *new_code
;
2910 old_loc
= gfc_current_locus
;
2912 if (gfc_match_char ('(') != MATCH_YES
)
2915 m
= match_io_element (k
, &head
);
2918 if (m
!= MATCH_YES
|| gfc_match_char (',') != MATCH_YES
)
2924 /* Can't be anything but an IO iterator. Build a list. */
2925 iter
= gfc_get_iterator ();
2929 m
= gfc_match_iterator (iter
, 0);
2930 if (m
== MATCH_ERROR
)
2934 gfc_check_do_variable (iter
->var
->symtree
);
2938 m
= match_io_element (k
, &new_code
);
2939 if (m
== MATCH_ERROR
)
2948 tail
= gfc_append_code (tail
, new_code
);
2950 if (gfc_match_char (',') != MATCH_YES
)
2959 if (gfc_match_char (')') != MATCH_YES
)
2962 new_code
= gfc_get_code ();
2963 new_code
->op
= EXEC_DO
;
2964 new_code
->ext
.iterator
= iter
;
2966 new_code
->block
= gfc_get_code ();
2967 new_code
->block
->op
= EXEC_DO
;
2968 new_code
->block
->next
= head
;
2974 gfc_error ("Syntax error in I/O iterator at %C");
2978 gfc_free_iterator (iter
, 1);
2979 gfc_free_statements (head
);
2980 gfc_current_locus
= old_loc
;
2985 /* Match a single element of an IO list, which is either a single
2986 expression or an IO Iterator. */
2989 match_io_element (io_kind k
, gfc_code
**cpp
)
2997 m
= match_io_iterator (k
, cpp
);
3003 m
= gfc_match_variable (&expr
, 0);
3005 gfc_error ("Expected variable in READ statement at %C");
3009 m
= gfc_match_expr (&expr
);
3011 gfc_error ("Expected expression in %s statement at %C",
3019 if (expr
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3021 gfc_error ("Variable '%s' in input list at %C cannot be "
3022 "INTENT(IN)", expr
->symtree
->n
.sym
->name
);
3027 && gfc_impure_variable (expr
->symtree
->n
.sym
)
3028 && current_dt
->io_unit
3029 && current_dt
->io_unit
->ts
.type
== BT_CHARACTER
)
3031 gfc_error ("Cannot read to variable '%s' in PURE procedure at %C",
3032 expr
->symtree
->n
.sym
->name
);
3036 if (gfc_check_do_variable (expr
->symtree
))
3042 if (current_dt
->io_unit
3043 && current_dt
->io_unit
->ts
.type
== BT_CHARACTER
3045 && current_dt
->io_unit
->expr_type
== EXPR_VARIABLE
3046 && gfc_impure_variable (current_dt
->io_unit
->symtree
->n
.sym
))
3048 gfc_error ("Cannot write to internal file unit '%s' at %C "
3049 "inside a PURE procedure",
3050 current_dt
->io_unit
->symtree
->n
.sym
->name
);
3062 gfc_free_expr (expr
);
3066 cp
= gfc_get_code ();
3067 cp
->op
= EXEC_TRANSFER
;
3075 /* Match an I/O list, building gfc_code structures as we go. */
3078 match_io_list (io_kind k
, gfc_code
**head_p
)
3080 gfc_code
*head
, *tail
, *new_code
;
3083 *head_p
= head
= tail
= NULL
;
3084 if (gfc_match_eos () == MATCH_YES
)
3089 m
= match_io_element (k
, &new_code
);
3090 if (m
== MATCH_ERROR
)
3095 tail
= gfc_append_code (tail
, new_code
);
3099 if (gfc_match_eos () == MATCH_YES
)
3101 if (gfc_match_char (',') != MATCH_YES
)
3109 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
3112 gfc_free_statements (head
);
3117 /* Attach the data transfer end node. */
3120 terminate_io (gfc_code
*io_code
)
3124 if (io_code
== NULL
)
3125 io_code
= new_st
.block
;
3127 c
= gfc_get_code ();
3128 c
->op
= EXEC_DT_END
;
3130 /* Point to structure that is already there */
3131 c
->ext
.dt
= new_st
.ext
.dt
;
3132 gfc_append_code (io_code
, c
);
3136 /* Check the constraints for a data transfer statement. The majority of the
3137 constraints appearing in 9.4 of the standard appear here. Some are handled
3138 in resolve_tag and others in gfc_resolve_dt. */
3141 check_io_constraints (io_kind k
, gfc_dt
*dt
, gfc_code
*io_code
,
3144 #define io_constraint(condition,msg,arg)\
3147 gfc_error(msg,arg);\
3153 gfc_symbol
*sym
= NULL
;
3154 bool warn
, unformatted
;
3156 warn
= (dt
->err
|| dt
->iostat
) ? true : false;
3157 unformatted
= dt
->format_expr
== NULL
&& dt
->format_label
== NULL
3158 && dt
->namelist
== NULL
;
3163 if (expr
&& expr
->expr_type
== EXPR_VARIABLE
3164 && expr
->ts
.type
== BT_CHARACTER
)
3166 sym
= expr
->symtree
->n
.sym
;
3168 io_constraint (k
== M_WRITE
&& sym
->attr
.intent
== INTENT_IN
,
3169 "Internal file at %L must not be INTENT(IN)",
3172 io_constraint (gfc_has_vector_index (dt
->io_unit
),
3173 "Internal file incompatible with vector subscript at %L",
3176 io_constraint (dt
->rec
!= NULL
,
3177 "REC tag at %L is incompatible with internal file",
3180 io_constraint (dt
->pos
!= NULL
,
3181 "POS tag at %L is incompatible with internal file",
3184 io_constraint (unformatted
,
3185 "Unformatted I/O not allowed with internal unit at %L",
3186 &dt
->io_unit
->where
);
3188 io_constraint (dt
->asynchronous
!= NULL
,
3189 "ASYNCHRONOUS tag at %L not allowed with internal file",
3190 &dt
->asynchronous
->where
);
3192 if (dt
->namelist
!= NULL
)
3194 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Internal file "
3195 "at %L with namelist", &expr
->where
)
3200 io_constraint (dt
->advance
!= NULL
,
3201 "ADVANCE tag at %L is incompatible with internal file",
3202 &dt
->advance
->where
);
3205 if (expr
&& expr
->ts
.type
!= BT_CHARACTER
)
3208 io_constraint (gfc_pure (NULL
) && (k
== M_READ
|| k
== M_WRITE
),
3209 "IO UNIT in %s statement at %C must be "
3210 "an internal file in a PURE procedure",
3216 io_constraint (dt
->end
, "END tag not allowed with output at %L",
3219 io_constraint (dt
->eor
, "EOR tag not allowed with output at %L",
3222 io_constraint (dt
->blank
, "BLANK= specifier not allowed with output at %L",
3225 io_constraint (dt
->pad
, "PAD= specifier not allowed with output at %L",
3228 io_constraint (dt
->size
, "SIZE= specifier not allowed with output at %L",
3233 io_constraint (dt
->size
&& dt
->advance
== NULL
,
3234 "SIZE tag at %L requires an ADVANCE tag",
3237 io_constraint (dt
->eor
&& dt
->advance
== NULL
,
3238 "EOR tag at %L requires an ADVANCE tag",
3242 if (dt
->asynchronous
)
3244 static const char * asynchronous
[] = { "YES", "NO", NULL
};
3246 if (gfc_reduce_init_expr (dt
->asynchronous
) != SUCCESS
)
3248 gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3249 "expression", &dt
->asynchronous
->where
);
3253 if (!compare_to_allowed_values
3254 ("ASYNCHRONOUS", asynchronous
, NULL
, NULL
,
3255 dt
->asynchronous
->value
.character
.string
,
3256 io_kind_name (k
), warn
))
3264 || gfc_wide_strlen (dt
->asynchronous
->value
.character
.string
) != 3
3265 || gfc_wide_strncasecmp (dt
->asynchronous
->value
.character
.string
,
3267 io_constraint (not_yes
,
3268 "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3269 "specifier", &dt
->id
->where
);
3274 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: DECIMAL= at %C "
3275 "not allowed in Fortran 95") == FAILURE
)
3278 if (dt
->decimal
->expr_type
== EXPR_CONSTANT
)
3280 static const char * decimal
[] = { "COMMA", "POINT", NULL
};
3282 if (!compare_to_allowed_values ("DECIMAL", decimal
, NULL
, NULL
,
3283 dt
->decimal
->value
.character
.string
,
3284 io_kind_name (k
), warn
))
3287 io_constraint (unformatted
,
3288 "the DECIMAL= specifier at %L must be with an "
3289 "explicit format expression", &dt
->decimal
->where
);
3295 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BLANK= at %C "
3296 "not allowed in Fortran 95") == FAILURE
)
3299 if (dt
->blank
->expr_type
== EXPR_CONSTANT
)
3301 static const char * blank
[] = { "NULL", "ZERO", NULL
};
3303 if (!compare_to_allowed_values ("BLANK", blank
, NULL
, NULL
,
3304 dt
->blank
->value
.character
.string
,
3305 io_kind_name (k
), warn
))
3308 io_constraint (unformatted
,
3309 "the BLANK= specifier at %L must be with an "
3310 "explicit format expression", &dt
->blank
->where
);
3316 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PAD= at %C "
3317 "not allowed in Fortran 95") == FAILURE
)
3320 if (dt
->pad
->expr_type
== EXPR_CONSTANT
)
3322 static const char * pad
[] = { "YES", "NO", NULL
};
3324 if (!compare_to_allowed_values ("PAD", pad
, NULL
, NULL
,
3325 dt
->pad
->value
.character
.string
,
3326 io_kind_name (k
), warn
))
3329 io_constraint (unformatted
,
3330 "the PAD= specifier at %L must be with an "
3331 "explicit format expression", &dt
->pad
->where
);
3337 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ROUND= at %C "
3338 "not allowed in Fortran 95") == FAILURE
)
3341 if (dt
->round
->expr_type
== EXPR_CONSTANT
)
3343 static const char * round
[] = { "UP", "DOWN", "ZERO", "NEAREST",
3344 "COMPATIBLE", "PROCESSOR_DEFINED",
3347 if (!compare_to_allowed_values ("ROUND", round
, NULL
, NULL
,
3348 dt
->round
->value
.character
.string
,
3349 io_kind_name (k
), warn
))
3356 /* When implemented, change the following to use gfc_notify_std F2003.
3357 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
3358 "not allowed in Fortran 95") == FAILURE)
3359 return MATCH_ERROR; */
3360 if (dt
->sign
->expr_type
== EXPR_CONSTANT
)
3362 static const char * sign
[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3365 if (!compare_to_allowed_values ("SIGN", sign
, NULL
, NULL
,
3366 dt
->sign
->value
.character
.string
,
3367 io_kind_name (k
), warn
))
3370 io_constraint (unformatted
,
3371 "SIGN= specifier at %L must be with an "
3372 "explicit format expression", &dt
->sign
->where
);
3374 io_constraint (k
== M_READ
,
3375 "SIGN= specifier at %L not allowed in a "
3376 "READ statement", &dt
->sign
->where
);
3382 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: DELIM= at %C "
3383 "not allowed in Fortran 95") == FAILURE
)
3386 if (dt
->delim
->expr_type
== EXPR_CONSTANT
)
3388 static const char *delim
[] = { "APOSTROPHE", "QUOTE", "NONE", NULL
};
3390 if (!compare_to_allowed_values ("DELIM", delim
, NULL
, NULL
,
3391 dt
->delim
->value
.character
.string
,
3392 io_kind_name (k
), warn
))
3395 io_constraint (k
== M_READ
,
3396 "DELIM= specifier at %L not allowed in a "
3397 "READ statement", &dt
->delim
->where
);
3399 io_constraint (dt
->format_label
!= &format_asterisk
3400 && dt
->namelist
== NULL
,
3401 "DELIM= specifier at %L must have FMT=*",
3404 io_constraint (unformatted
&& dt
->namelist
== NULL
,
3405 "DELIM= specifier at %L must be with FMT=* or "
3406 "NML= specifier ", &dt
->delim
->where
);
3412 io_constraint (io_code
&& dt
->namelist
,
3413 "NAMELIST cannot be followed by IO-list at %L",
3416 io_constraint (dt
->format_expr
,
3417 "IO spec-list cannot contain both NAMELIST group name "
3418 "and format specification at %L",
3419 &dt
->format_expr
->where
);
3421 io_constraint (dt
->format_label
,
3422 "IO spec-list cannot contain both NAMELIST group name "
3423 "and format label at %L", spec_end
);
3425 io_constraint (dt
->rec
,
3426 "NAMELIST IO is not allowed with a REC= specifier "
3427 "at %L", &dt
->rec
->where
);
3429 io_constraint (dt
->advance
,
3430 "NAMELIST IO is not allowed with a ADVANCE= specifier "
3431 "at %L", &dt
->advance
->where
);
3436 io_constraint (dt
->end
,
3437 "An END tag is not allowed with a "
3438 "REC= specifier at %L", &dt
->end_where
);
3440 io_constraint (dt
->format_label
== &format_asterisk
,
3441 "FMT=* is not allowed with a REC= specifier "
3444 io_constraint (dt
->pos
,
3445 "POS= is not allowed with REC= specifier "
3446 "at %L", &dt
->pos
->where
);
3451 int not_yes
, not_no
;
3454 io_constraint (dt
->format_label
== &format_asterisk
,
3455 "List directed format(*) is not allowed with a "
3456 "ADVANCE= specifier at %L.", &expr
->where
);
3458 io_constraint (unformatted
,
3459 "the ADVANCE= specifier at %L must appear with an "
3460 "explicit format expression", &expr
->where
);
3462 if (expr
->expr_type
== EXPR_CONSTANT
&& expr
->ts
.type
== BT_CHARACTER
)
3464 const gfc_char_t
*advance
= expr
->value
.character
.string
;
3465 not_no
= gfc_wide_strlen (advance
) != 2
3466 || gfc_wide_strncasecmp (advance
, "no", 2) != 0;
3467 not_yes
= gfc_wide_strlen (advance
) != 3
3468 || gfc_wide_strncasecmp (advance
, "yes", 3) != 0;
3476 io_constraint (not_no
&& not_yes
,
3477 "ADVANCE= specifier at %L must have value = "
3478 "YES or NO.", &expr
->where
);
3480 io_constraint (dt
->size
&& not_no
&& k
== M_READ
,
3481 "SIZE tag at %L requires an ADVANCE = 'NO'",
3484 io_constraint (dt
->eor
&& not_no
&& k
== M_READ
,
3485 "EOR tag at %L requires an ADVANCE = 'NO'",
3489 expr
= dt
->format_expr
;
3490 if (gfc_simplify_expr (expr
, 0) == FAILURE
3491 || check_format_string (expr
, k
== M_READ
) == FAILURE
)
3496 #undef io_constraint
3499 /* Match a READ, WRITE or PRINT statement. */
3502 match_io (io_kind k
)
3504 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3513 where
= gfc_current_locus
;
3515 current_dt
= dt
= XCNEW (gfc_dt
);
3516 m
= gfc_match_char ('(');
3519 where
= gfc_current_locus
;
3522 else if (k
== M_PRINT
)
3524 /* Treat the non-standard case of PRINT namelist. */
3525 if ((gfc_current_form
== FORM_FIXED
|| gfc_peek_ascii_char () == ' ')
3526 && gfc_match_name (name
) == MATCH_YES
)
3528 gfc_find_symbol (name
, NULL
, 1, &sym
);
3529 if (sym
&& sym
->attr
.flavor
== FL_NAMELIST
)
3531 if (gfc_notify_std (GFC_STD_GNU
, "PRINT namelist at "
3532 "%C is an extension") == FAILURE
)
3538 dt
->io_unit
= default_unit (k
);
3543 gfc_current_locus
= where
;
3547 if (gfc_current_form
== FORM_FREE
)
3549 char c
= gfc_peek_ascii_char ();
3550 if (c
!= ' ' && c
!= '*' && c
!= '\'' && c
!= '"')
3557 m
= match_dt_format (dt
);
3558 if (m
== MATCH_ERROR
)
3564 dt
->io_unit
= default_unit (k
);
3569 /* Before issuing an error for a malformed 'print (1,*)' type of
3570 error, check for a default-char-expr of the form ('(I0)'). */
3571 if (k
== M_PRINT
&& m
== MATCH_YES
)
3573 /* Reset current locus to get the initial '(' in an expression. */
3574 gfc_current_locus
= where
;
3575 dt
->format_expr
= NULL
;
3576 m
= match_dt_format (dt
);
3578 if (m
== MATCH_ERROR
)
3580 if (m
== MATCH_NO
|| dt
->format_expr
== NULL
)
3584 dt
->io_unit
= default_unit (k
);
3589 /* Match a control list */
3590 if (match_dt_element (k
, dt
) == MATCH_YES
)
3592 if (match_dt_unit (k
, dt
) != MATCH_YES
)
3595 if (gfc_match_char (')') == MATCH_YES
)
3597 if (gfc_match_char (',') != MATCH_YES
)
3600 m
= match_dt_element (k
, dt
);
3603 if (m
== MATCH_ERROR
)
3606 m
= match_dt_format (dt
);
3609 if (m
== MATCH_ERROR
)
3612 where
= gfc_current_locus
;
3614 m
= gfc_match_name (name
);
3617 gfc_find_symbol (name
, NULL
, 1, &sym
);
3618 if (sym
&& sym
->attr
.flavor
== FL_NAMELIST
)
3621 if (k
== M_READ
&& check_namelist (sym
))
3630 gfc_current_locus
= where
;
3632 goto loop
; /* No matches, try regular elements */
3635 if (gfc_match_char (')') == MATCH_YES
)
3637 if (gfc_match_char (',') != MATCH_YES
)
3643 m
= match_dt_element (k
, dt
);
3646 if (m
== MATCH_ERROR
)
3649 if (gfc_match_char (')') == MATCH_YES
)
3651 if (gfc_match_char (',') != MATCH_YES
)
3657 /* Used in check_io_constraints, where no locus is available. */
3658 spec_end
= gfc_current_locus
;
3660 /* Optional leading comma (non-standard). We use a gfc_expr structure here
3661 to save the locus. This is used later when resolving transfer statements
3662 that might have a format expression without unit number. */
3663 if (!comma_flag
&& gfc_match_char (',') == MATCH_YES
)
3665 /* Save the iokind and locus for later use in resolution. */
3666 dt
->extra_comma
= gfc_get_iokind_expr (&gfc_current_locus
, k
);
3670 if (gfc_match_eos () != MATCH_YES
)
3672 if (comma_flag
&& gfc_match_char (',') != MATCH_YES
)
3674 gfc_error ("Expected comma in I/O list at %C");
3679 m
= match_io_list (k
, &io_code
);
3680 if (m
== MATCH_ERROR
)
3686 /* A full IO statement has been matched. Check the constraints. spec_end is
3687 supplied for cases where no locus is supplied. */
3688 m
= check_io_constraints (k
, dt
, io_code
, &spec_end
);
3690 if (m
== MATCH_ERROR
)
3693 new_st
.op
= (k
== M_READ
) ? EXEC_READ
: EXEC_WRITE
;
3695 new_st
.block
= gfc_get_code ();
3696 new_st
.block
->op
= new_st
.op
;
3697 new_st
.block
->next
= io_code
;
3699 terminate_io (io_code
);
3704 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
3714 gfc_match_read (void)
3716 return match_io (M_READ
);
3721 gfc_match_write (void)
3723 return match_io (M_WRITE
);
3728 gfc_match_print (void)
3732 m
= match_io (M_PRINT
);
3736 if (gfc_pure (NULL
))
3738 gfc_error ("PRINT statement at %C not allowed within PURE procedure");
3746 /* Free a gfc_inquire structure. */
3749 gfc_free_inquire (gfc_inquire
*inquire
)
3752 if (inquire
== NULL
)
3755 gfc_free_expr (inquire
->unit
);
3756 gfc_free_expr (inquire
->file
);
3757 gfc_free_expr (inquire
->iomsg
);
3758 gfc_free_expr (inquire
->iostat
);
3759 gfc_free_expr (inquire
->exist
);
3760 gfc_free_expr (inquire
->opened
);
3761 gfc_free_expr (inquire
->number
);
3762 gfc_free_expr (inquire
->named
);
3763 gfc_free_expr (inquire
->name
);
3764 gfc_free_expr (inquire
->access
);
3765 gfc_free_expr (inquire
->sequential
);
3766 gfc_free_expr (inquire
->direct
);
3767 gfc_free_expr (inquire
->form
);
3768 gfc_free_expr (inquire
->formatted
);
3769 gfc_free_expr (inquire
->unformatted
);
3770 gfc_free_expr (inquire
->recl
);
3771 gfc_free_expr (inquire
->nextrec
);
3772 gfc_free_expr (inquire
->blank
);
3773 gfc_free_expr (inquire
->position
);
3774 gfc_free_expr (inquire
->action
);
3775 gfc_free_expr (inquire
->read
);
3776 gfc_free_expr (inquire
->write
);
3777 gfc_free_expr (inquire
->readwrite
);
3778 gfc_free_expr (inquire
->delim
);
3779 gfc_free_expr (inquire
->encoding
);
3780 gfc_free_expr (inquire
->pad
);
3781 gfc_free_expr (inquire
->iolength
);
3782 gfc_free_expr (inquire
->convert
);
3783 gfc_free_expr (inquire
->strm_pos
);
3784 gfc_free_expr (inquire
->asynchronous
);
3785 gfc_free_expr (inquire
->decimal
);
3786 gfc_free_expr (inquire
->pending
);
3787 gfc_free_expr (inquire
->id
);
3788 gfc_free_expr (inquire
->sign
);
3789 gfc_free_expr (inquire
->size
);
3790 gfc_free_expr (inquire
->round
);
3795 /* Match an element of an INQUIRE statement. */
3797 #define RETM if (m != MATCH_NO) return m;
3800 match_inquire_element (gfc_inquire
*inquire
)
3804 m
= match_etag (&tag_unit
, &inquire
->unit
);
3805 RETM m
= match_etag (&tag_file
, &inquire
->file
);
3806 RETM m
= match_ltag (&tag_err
, &inquire
->err
);
3807 RETM m
= match_out_tag (&tag_iomsg
, &inquire
->iomsg
);
3808 RETM m
= match_out_tag (&tag_iostat
, &inquire
->iostat
);
3809 RETM m
= match_vtag (&tag_exist
, &inquire
->exist
);
3810 RETM m
= match_vtag (&tag_opened
, &inquire
->opened
);
3811 RETM m
= match_vtag (&tag_named
, &inquire
->named
);
3812 RETM m
= match_vtag (&tag_name
, &inquire
->name
);
3813 RETM m
= match_out_tag (&tag_number
, &inquire
->number
);
3814 RETM m
= match_vtag (&tag_s_access
, &inquire
->access
);
3815 RETM m
= match_vtag (&tag_sequential
, &inquire
->sequential
);
3816 RETM m
= match_vtag (&tag_direct
, &inquire
->direct
);
3817 RETM m
= match_vtag (&tag_s_form
, &inquire
->form
);
3818 RETM m
= match_vtag (&tag_formatted
, &inquire
->formatted
);
3819 RETM m
= match_vtag (&tag_unformatted
, &inquire
->unformatted
);
3820 RETM m
= match_out_tag (&tag_s_recl
, &inquire
->recl
);
3821 RETM m
= match_out_tag (&tag_nextrec
, &inquire
->nextrec
);
3822 RETM m
= match_vtag (&tag_s_blank
, &inquire
->blank
);
3823 RETM m
= match_vtag (&tag_s_position
, &inquire
->position
);
3824 RETM m
= match_vtag (&tag_s_action
, &inquire
->action
);
3825 RETM m
= match_vtag (&tag_read
, &inquire
->read
);
3826 RETM m
= match_vtag (&tag_write
, &inquire
->write
);
3827 RETM m
= match_vtag (&tag_readwrite
, &inquire
->readwrite
);
3828 RETM m
= match_vtag (&tag_s_async
, &inquire
->asynchronous
);
3829 RETM m
= match_vtag (&tag_s_delim
, &inquire
->delim
);
3830 RETM m
= match_vtag (&tag_s_decimal
, &inquire
->decimal
);
3831 RETM m
= match_vtag (&tag_size
, &inquire
->size
);
3832 RETM m
= match_vtag (&tag_s_encoding
, &inquire
->encoding
);
3833 RETM m
= match_vtag (&tag_s_round
, &inquire
->round
);
3834 RETM m
= match_vtag (&tag_s_sign
, &inquire
->sign
);
3835 RETM m
= match_vtag (&tag_s_pad
, &inquire
->pad
);
3836 RETM m
= match_vtag (&tag_iolength
, &inquire
->iolength
);
3837 RETM m
= match_vtag (&tag_convert
, &inquire
->convert
);
3838 RETM m
= match_out_tag (&tag_strm_out
, &inquire
->strm_pos
);
3839 RETM m
= match_vtag (&tag_pending
, &inquire
->pending
);
3840 RETM m
= match_vtag (&tag_id
, &inquire
->id
);
3841 RETM
return MATCH_NO
;
3848 gfc_match_inquire (void)
3850 gfc_inquire
*inquire
;
3855 m
= gfc_match_char ('(');
3859 inquire
= XCNEW (gfc_inquire
);
3861 loc
= gfc_current_locus
;
3863 m
= match_inquire_element (inquire
);
3864 if (m
== MATCH_ERROR
)
3868 m
= gfc_match_expr (&inquire
->unit
);
3869 if (m
== MATCH_ERROR
)
3875 /* See if we have the IOLENGTH form of the inquire statement. */
3876 if (inquire
->iolength
!= NULL
)
3878 if (gfc_match_char (')') != MATCH_YES
)
3881 m
= match_io_list (M_INQUIRE
, &code
);
3882 if (m
== MATCH_ERROR
)
3887 new_st
.op
= EXEC_IOLENGTH
;
3888 new_st
.expr1
= inquire
->iolength
;
3889 new_st
.ext
.inquire
= inquire
;
3891 if (gfc_pure (NULL
))
3893 gfc_free_statements (code
);
3894 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3898 new_st
.block
= gfc_get_code ();
3899 new_st
.block
->op
= EXEC_IOLENGTH
;
3900 terminate_io (code
);
3901 new_st
.block
->next
= code
;
3905 /* At this point, we have the non-IOLENGTH inquire statement. */
3908 if (gfc_match_char (')') == MATCH_YES
)
3910 if (gfc_match_char (',') != MATCH_YES
)
3913 m
= match_inquire_element (inquire
);
3914 if (m
== MATCH_ERROR
)
3919 if (inquire
->iolength
!= NULL
)
3921 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
3926 if (gfc_match_eos () != MATCH_YES
)
3929 if (inquire
->unit
!= NULL
&& inquire
->file
!= NULL
)
3931 gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
3932 "UNIT specifiers", &loc
);
3936 if (inquire
->unit
== NULL
&& inquire
->file
== NULL
)
3938 gfc_error ("INQUIRE statement at %L requires either FILE or "
3939 "UNIT specifier", &loc
);
3943 if (gfc_pure (NULL
))
3945 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3949 if (inquire
->id
!= NULL
&& inquire
->pending
== NULL
)
3951 gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
3952 "the ID= specifier", &loc
);
3956 new_st
.op
= EXEC_INQUIRE
;
3957 new_st
.ext
.inquire
= inquire
;
3961 gfc_syntax_error (ST_INQUIRE
);
3964 gfc_free_inquire (inquire
);
3969 /* Resolve everything in a gfc_inquire structure. */
3972 gfc_resolve_inquire (gfc_inquire
*inquire
)
3974 RESOLVE_TAG (&tag_unit
, inquire
->unit
);
3975 RESOLVE_TAG (&tag_file
, inquire
->file
);
3976 RESOLVE_TAG (&tag_iomsg
, inquire
->iomsg
);
3977 RESOLVE_TAG (&tag_iostat
, inquire
->iostat
);
3978 RESOLVE_TAG (&tag_exist
, inquire
->exist
);
3979 RESOLVE_TAG (&tag_opened
, inquire
->opened
);
3980 RESOLVE_TAG (&tag_number
, inquire
->number
);
3981 RESOLVE_TAG (&tag_named
, inquire
->named
);
3982 RESOLVE_TAG (&tag_name
, inquire
->name
);
3983 RESOLVE_TAG (&tag_s_access
, inquire
->access
);
3984 RESOLVE_TAG (&tag_sequential
, inquire
->sequential
);
3985 RESOLVE_TAG (&tag_direct
, inquire
->direct
);
3986 RESOLVE_TAG (&tag_s_form
, inquire
->form
);
3987 RESOLVE_TAG (&tag_formatted
, inquire
->formatted
);
3988 RESOLVE_TAG (&tag_unformatted
, inquire
->unformatted
);
3989 RESOLVE_TAG (&tag_s_recl
, inquire
->recl
);
3990 RESOLVE_TAG (&tag_nextrec
, inquire
->nextrec
);
3991 RESOLVE_TAG (&tag_s_blank
, inquire
->blank
);
3992 RESOLVE_TAG (&tag_s_position
, inquire
->position
);
3993 RESOLVE_TAG (&tag_s_action
, inquire
->action
);
3994 RESOLVE_TAG (&tag_read
, inquire
->read
);
3995 RESOLVE_TAG (&tag_write
, inquire
->write
);
3996 RESOLVE_TAG (&tag_readwrite
, inquire
->readwrite
);
3997 RESOLVE_TAG (&tag_s_delim
, inquire
->delim
);
3998 RESOLVE_TAG (&tag_s_pad
, inquire
->pad
);
3999 RESOLVE_TAG (&tag_s_encoding
, inquire
->encoding
);
4000 RESOLVE_TAG (&tag_s_round
, inquire
->round
);
4001 RESOLVE_TAG (&tag_iolength
, inquire
->iolength
);
4002 RESOLVE_TAG (&tag_convert
, inquire
->convert
);
4003 RESOLVE_TAG (&tag_strm_out
, inquire
->strm_pos
);
4004 RESOLVE_TAG (&tag_s_async
, inquire
->asynchronous
);
4005 RESOLVE_TAG (&tag_s_sign
, inquire
->sign
);
4006 RESOLVE_TAG (&tag_s_round
, inquire
->round
);
4007 RESOLVE_TAG (&tag_pending
, inquire
->pending
);
4008 RESOLVE_TAG (&tag_size
, inquire
->size
);
4009 RESOLVE_TAG (&tag_id
, inquire
->id
);
4011 if (gfc_reference_st_label (inquire
->err
, ST_LABEL_TARGET
) == FAILURE
)
4019 gfc_free_wait (gfc_wait
*wait
)
4024 gfc_free_expr (wait
->unit
);
4025 gfc_free_expr (wait
->iostat
);
4026 gfc_free_expr (wait
->iomsg
);
4027 gfc_free_expr (wait
->id
);
4032 gfc_resolve_wait (gfc_wait
*wait
)
4034 RESOLVE_TAG (&tag_unit
, wait
->unit
);
4035 RESOLVE_TAG (&tag_iomsg
, wait
->iomsg
);
4036 RESOLVE_TAG (&tag_iostat
, wait
->iostat
);
4037 RESOLVE_TAG (&tag_id
, wait
->id
);
4039 if (gfc_reference_st_label (wait
->err
, ST_LABEL_TARGET
) == FAILURE
)
4042 if (gfc_reference_st_label (wait
->end
, ST_LABEL_TARGET
) == FAILURE
)
4048 /* Match an element of a WAIT statement. */
4050 #define RETM if (m != MATCH_NO) return m;
4053 match_wait_element (gfc_wait
*wait
)
4057 m
= match_etag (&tag_unit
, &wait
->unit
);
4058 RETM m
= match_ltag (&tag_err
, &wait
->err
);
4059 RETM m
= match_ltag (&tag_end
, &wait
->eor
);
4060 RETM m
= match_ltag (&tag_eor
, &wait
->end
);
4061 RETM m
= match_out_tag (&tag_iomsg
, &wait
->iomsg
);
4062 RETM m
= match_out_tag (&tag_iostat
, &wait
->iostat
);
4063 RETM m
= match_etag (&tag_id
, &wait
->id
);
4064 RETM
return MATCH_NO
;
4071 gfc_match_wait (void)
4076 m
= gfc_match_char ('(');
4080 wait
= XCNEW (gfc_wait
);
4082 m
= match_wait_element (wait
);
4083 if (m
== MATCH_ERROR
)
4087 m
= gfc_match_expr (&wait
->unit
);
4088 if (m
== MATCH_ERROR
)
4096 if (gfc_match_char (')') == MATCH_YES
)
4098 if (gfc_match_char (',') != MATCH_YES
)
4101 m
= match_wait_element (wait
);
4102 if (m
== MATCH_ERROR
)
4108 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: WAIT at %C "
4109 "not allowed in Fortran 95") == FAILURE
)
4112 if (gfc_pure (NULL
))
4114 gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4118 new_st
.op
= EXEC_WAIT
;
4119 new_st
.ext
.wait
= wait
;
4124 gfc_syntax_error (ST_WAIT
);
4127 gfc_free_wait (wait
);