1 /* Deal with I/O statements & related stuff.
2 Copyright (C) 2000-2019 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"
28 #include "constructor.h"
31 format_asterisk
= {0, NULL
, NULL
, -1, ST_LABEL_FORMAT
, ST_LABEL_FORMAT
, NULL
,
32 0, {NULL
, NULL
}, NULL
};
36 const char *name
, *spec
, *value
;
42 tag_readonly
= {"READONLY", " readonly", NULL
, BT_UNKNOWN
},
43 tag_shared
= {"SHARE", " shared", NULL
, BT_UNKNOWN
},
44 tag_noshared
= {"SHARE", " noshared", NULL
, BT_UNKNOWN
},
45 tag_e_share
= {"SHARE", " share =", " %e", BT_CHARACTER
},
46 tag_v_share
= {"SHARE", " share =", " %v", BT_CHARACTER
},
47 tag_cc
= {"CARRIAGECONTROL", " carriagecontrol =", " %e",
49 tag_v_cc
= {"CARRIAGECONTROL", " carriagecontrol =", " %v",
51 tag_file
= {"FILE", " file =", " %e", BT_CHARACTER
},
52 tag_status
= {"STATUS", " status =", " %e", BT_CHARACTER
},
53 tag_e_access
= {"ACCESS", " access =", " %e", BT_CHARACTER
},
54 tag_e_form
= {"FORM", " form =", " %e", BT_CHARACTER
},
55 tag_e_recl
= {"RECL", " recl =", " %e", BT_INTEGER
},
56 tag_e_blank
= {"BLANK", " blank =", " %e", BT_CHARACTER
},
57 tag_e_position
= {"POSITION", " position =", " %e", BT_CHARACTER
},
58 tag_e_action
= {"ACTION", " action =", " %e", BT_CHARACTER
},
59 tag_e_delim
= {"DELIM", " delim =", " %e", BT_CHARACTER
},
60 tag_e_pad
= {"PAD", " pad =", " %e", BT_CHARACTER
},
61 tag_e_decimal
= {"DECIMAL", " decimal =", " %e", BT_CHARACTER
},
62 tag_e_encoding
= {"ENCODING", " encoding =", " %e", BT_CHARACTER
},
63 tag_e_async
= {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER
},
64 tag_e_round
= {"ROUND", " round =", " %e", BT_CHARACTER
},
65 tag_e_sign
= {"SIGN", " sign =", " %e", BT_CHARACTER
},
66 tag_unit
= {"UNIT", " unit =", " %e", BT_INTEGER
},
67 tag_advance
= {"ADVANCE", " advance =", " %e", BT_CHARACTER
},
68 tag_rec
= {"REC", " rec =", " %e", BT_INTEGER
},
69 tag_spos
= {"POSITION", " pos =", " %e", BT_INTEGER
},
70 tag_format
= {"FORMAT", NULL
, NULL
, BT_CHARACTER
},
71 tag_iomsg
= {"IOMSG", " iomsg =", " %e", BT_CHARACTER
},
72 tag_iostat
= {"IOSTAT", " iostat =", " %v", BT_INTEGER
},
73 tag_size
= {"SIZE", " size =", " %v", BT_INTEGER
},
74 tag_exist
= {"EXIST", " exist =", " %v", BT_LOGICAL
},
75 tag_opened
= {"OPENED", " opened =", " %v", BT_LOGICAL
},
76 tag_named
= {"NAMED", " named =", " %v", BT_LOGICAL
},
77 tag_name
= {"NAME", " name =", " %v", BT_CHARACTER
},
78 tag_number
= {"NUMBER", " number =", " %v", BT_INTEGER
},
79 tag_s_access
= {"ACCESS", " access =", " %v", BT_CHARACTER
},
80 tag_sequential
= {"SEQUENTIAL", " sequential =", " %v", BT_CHARACTER
},
81 tag_direct
= {"DIRECT", " direct =", " %v", BT_CHARACTER
},
82 tag_s_form
= {"FORM", " form =", " %v", BT_CHARACTER
},
83 tag_formatted
= {"FORMATTED", " formatted =", " %v", BT_CHARACTER
},
84 tag_unformatted
= {"UNFORMATTED", " unformatted =", " %v", BT_CHARACTER
},
85 tag_s_recl
= {"RECL", " recl =", " %v", BT_INTEGER
},
86 tag_nextrec
= {"NEXTREC", " nextrec =", " %v", BT_INTEGER
},
87 tag_s_blank
= {"BLANK", " blank =", " %v", BT_CHARACTER
},
88 tag_s_position
= {"POSITION", " position =", " %v", BT_CHARACTER
},
89 tag_s_action
= {"ACTION", " action =", " %v", BT_CHARACTER
},
90 tag_read
= {"READ", " read =", " %v", BT_CHARACTER
},
91 tag_write
= {"WRITE", " write =", " %v", BT_CHARACTER
},
92 tag_readwrite
= {"READWRITE", " readwrite =", " %v", BT_CHARACTER
},
93 tag_s_delim
= {"DELIM", " delim =", " %v", BT_CHARACTER
},
94 tag_s_pad
= {"PAD", " pad =", " %v", BT_CHARACTER
},
95 tag_s_decimal
= {"DECIMAL", " decimal =", " %v", BT_CHARACTER
},
96 tag_s_encoding
= {"ENCODING", " encoding =", " %v", BT_CHARACTER
},
97 tag_s_async
= {"ASYNCHRONOUS", " asynchronous =", " %v", BT_CHARACTER
},
98 tag_s_round
= {"ROUND", " round =", " %v", BT_CHARACTER
},
99 tag_s_sign
= {"SIGN", " sign =", " %v", BT_CHARACTER
},
100 tag_iolength
= {"IOLENGTH", " iolength =", " %v", BT_INTEGER
},
101 tag_convert
= {"CONVERT", " convert =", " %e", BT_CHARACTER
},
102 tag_strm_out
= {"POS", " pos =", " %v", BT_INTEGER
},
103 tag_err
= {"ERR", " err =", " %l", BT_UNKNOWN
},
104 tag_end
= {"END", " end =", " %l", BT_UNKNOWN
},
105 tag_eor
= {"EOR", " eor =", " %l", BT_UNKNOWN
},
106 tag_id
= {"ID", " id =", " %v", BT_INTEGER
},
107 tag_pending
= {"PENDING", " pending =", " %v", BT_LOGICAL
},
108 tag_newunit
= {"NEWUNIT", " newunit =", " %v", BT_INTEGER
},
109 tag_s_iqstream
= {"STREAM", " stream =", " %v", BT_CHARACTER
};
111 static gfc_dt
*current_dt
;
113 #define RESOLVE_TAG(x, y) if (!resolve_tag (x, y)) return false;
115 /* Are we currently processing an asynchronous I/O statement? */
119 /**************** Fortran 95 FORMAT parser *****************/
121 /* FORMAT tokens returned by format_lex(). */
124 FMT_NONE
, FMT_UNKNOWN
, FMT_SIGNED_INT
, FMT_ZERO
, FMT_POSINT
, FMT_PERIOD
,
125 FMT_COMMA
, FMT_COLON
, FMT_SLASH
, FMT_DOLLAR
, FMT_LPAREN
,
126 FMT_RPAREN
, FMT_X
, FMT_SIGN
, FMT_BLANK
, FMT_CHAR
, FMT_P
, FMT_IBOZ
, FMT_F
,
127 FMT_E
, FMT_EN
, FMT_ES
, FMT_G
, FMT_L
, FMT_A
, FMT_D
, FMT_H
, FMT_END
,
128 FMT_ERROR
, FMT_DC
, FMT_DP
, FMT_T
, FMT_TR
, FMT_TL
, FMT_STAR
, FMT_RC
,
129 FMT_RD
, FMT_RN
, FMT_RP
, FMT_RU
, FMT_RZ
, FMT_DT
132 /* Local variables for checking format strings. The saved_token is
133 used to back up by a single format token during the parsing
135 static gfc_char_t
*format_string
;
136 static int format_string_pos
;
137 static int format_length
, use_last_char
;
138 static char error_element
;
139 static locus format_locus
;
141 static format_token saved_token
;
144 { MODE_STRING
, MODE_FORMAT
, MODE_COPY
}
148 /* Return the next character in the format string. */
151 next_char (gfc_instring in_string
)
163 if (mode
== MODE_STRING
)
164 c
= *format_string
++;
167 c
= gfc_next_char_literal (in_string
);
172 if (flag_backslash
&& c
== '\\')
174 locus old_locus
= gfc_current_locus
;
176 if (gfc_match_special_char (&c
) == MATCH_NO
)
177 gfc_current_locus
= old_locus
;
179 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
180 gfc_warning (0, "Extension: backslash character at %C");
183 if (mode
== MODE_COPY
)
184 *format_string
++ = c
;
186 if (mode
!= MODE_STRING
)
187 format_locus
= gfc_current_locus
;
191 c
= gfc_wide_toupper (c
);
196 /* Back up one character position. Only works once. */
204 /* Eat up the spaces and return a character. */
207 next_char_not_space ()
212 error_element
= c
= next_char (NONSTRING
);
214 gfc_warning (OPT_Wtabs
, "Nonconforming tab character in format at %C");
216 while (gfc_is_whitespace (c
));
220 static int value
= 0;
222 /* Simple lexical analyzer for getting the next token in a FORMAT
233 if (saved_token
!= FMT_NONE
)
236 saved_token
= FMT_NONE
;
240 c
= next_char_not_space ();
250 c
= next_char_not_space ();
261 c
= next_char_not_space ();
263 value
= 10 * value
+ c
- '0';
272 token
= FMT_SIGNED_INT
;
291 c
= next_char_not_space ();
294 value
= 10 * value
+ c
- '0';
302 token
= zflag
? FMT_ZERO
: FMT_POSINT
;
326 c
= next_char_not_space ();
354 c
= next_char_not_space ();
355 if (c
!= 'P' && c
!= 'S')
362 c
= next_char_not_space ();
363 if (c
== 'N' || c
== 'Z')
381 c
= next_char (INSTRING_WARN
);
390 c
= next_char (NONSTRING
);
424 c
= next_char_not_space ();
454 c
= next_char_not_space ();
457 if (!gfc_notify_std (GFC_STD_F2003
, "DP format "
458 "specifier not allowed at %C"))
464 if (!gfc_notify_std (GFC_STD_F2003
, "DC format "
465 "specifier not allowed at %C"))
471 if (!gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: DT format "
472 "specifier not allowed at %C"))
475 c
= next_char_not_space ();
476 if (c
== '\'' || c
== '"')
483 c
= next_char (INSTRING_WARN
);
492 c
= next_char (NONSTRING
);
526 c
= next_char_not_space ();
572 token_to_string (format_token t
)
591 /* Check a format statement. The format string, either from a FORMAT
592 statement or a constant in an I/O statement has already been parsed
593 by itself, and we are checking it for validity. The dual origin
594 means that the warning message is a little less than great. */
597 check_format (bool is_input
)
599 const char *posint_required
600 = G_("Positive width required in format string at %L");
601 const char *nonneg_required
602 = G_("Nonnegative width required in format string at %L");
603 const char *unexpected_element
604 = G_("Unexpected element %qc in format string at %L");
605 const char *unexpected_end
606 = G_("Unexpected end of format string in format string at %L");
607 const char *zero_width
608 = G_("Zero width in format descriptor in format string at %L");
610 const char *error
= NULL
;
617 saved_token
= FMT_NONE
;
621 format_string_pos
= 0;
628 error
= G_("Missing leading left parenthesis in format string at %L");
636 goto finished
; /* Empty format is legal */
640 /* In this state, the next thing has to be a format item. */
657 error
= G_("Left parenthesis required after %<*%> in format string "
683 /* Signed integer can only precede a P format. */
689 error
= G_("Expected P edit descriptor in format string at %L");
696 /* P requires a prior number. */
697 error
= G_("P descriptor requires leading scale factor in format "
702 /* X requires a prior number if we're being pedantic. */
703 if (mode
!= MODE_FORMAT
)
704 format_locus
.nextc
+= format_string_pos
;
705 if (!gfc_notify_std (GFC_STD_GNU
, "X descriptor requires leading "
706 "space count at %L", &format_locus
))
723 goto extension_optional_comma
;
734 if (!gfc_notify_std (GFC_STD_GNU
, "$ descriptor at %L", &format_locus
))
736 if (t
!= FMT_RPAREN
|| level
> 0)
738 gfc_warning (0, "$ should be the last specifier in format at %L",
740 goto optional_comma_1
;
762 error
= unexpected_end
;
766 if (flag_dec_blank_format_item
)
770 error
= G_("Missing item in format string at %L");
775 error
= unexpected_element
;
780 /* In this state, t must currently be a data descriptor.
781 Deal with things that can/must follow the descriptor. */
792 /* No comma after P allowed only for F, E, EN, ES, D, or G.
797 if (!(gfc_option
.allow_std
& GFC_STD_F2003
) && t
!= FMT_COMMA
798 && t
!= FMT_F
&& t
!= FMT_E
&& t
!= FMT_EN
&& t
!= FMT_ES
799 && t
!= FMT_D
&& t
!= FMT_G
&& t
!= FMT_RPAREN
&& t
!= FMT_SLASH
)
801 error
= G_("Comma required after P descriptor in format string "
813 if (t
!= FMT_F
&& t
!= FMT_E
&& t
!= FMT_EN
&& t
!= FMT_ES
814 && t
!= FMT_D
&& t
!= FMT_G
&& t
!= FMT_RPAREN
&& t
!= FMT_SLASH
)
816 error
= G_("Comma required after P descriptor in format string "
831 error
= G_("Positive width required with T descriptor in format "
843 if (mode
!= MODE_FORMAT
)
844 format_locus
.nextc
+= format_string_pos
;
847 switch (gfc_notification_std (GFC_STD_GNU
))
850 gfc_warning (0, "Extension: Zero width after L "
851 "descriptor at %L", &format_locus
);
854 gfc_error ("Extension: Zero width after L "
855 "descriptor at %L", &format_locus
);
866 gfc_notify_std (GFC_STD_GNU
, "Missing positive width after "
867 "L descriptor at %L", &format_locus
);
890 if (t
== FMT_G
&& u
== FMT_ZERO
)
897 if (!gfc_notify_std (GFC_STD_F2008
, "%<G0%> in format at %L",
909 error
= posint_required
;
915 error
= G_("E specifier not allowed with g0 descriptor in "
916 "format string at %L");
925 if (flag_dec_format_defaults
)
927 /* Assume a default width based on the variable size. */
932 format_locus
.nextc
+= format_string_pos
;
933 gfc_error ("Positive width required in format "
934 "specifier %s at %L", token_to_string (t
),
945 /* Warn if -std=legacy, otherwise error. */
946 format_locus
.nextc
+= format_string_pos
;
947 if (gfc_option
.warn_std
!= 0)
949 gfc_error ("Period required in format "
950 "specifier %s at %L", token_to_string (t
),
956 gfc_warning (0, "Period required in format "
957 "specifier %s at %L", token_to_string (t
),
959 /* If we go to finished, we need to unwind this
960 before the next round. */
961 format_locus
.nextc
-= format_string_pos
;
969 if (u
!= FMT_ZERO
&& u
!= FMT_POSINT
)
971 error
= nonneg_required
;
978 /* Look for optional exponent. */
991 error
= G_("Positive exponent width required in format string "
1024 if (t
!= FMT_POSINT
)
1026 error
= posint_required
;
1036 if (t
!= FMT_RPAREN
)
1038 error
= G_("Right parenthesis expected at %C in format string "
1045 error
= unexpected_element
;
1054 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
1056 if (flag_dec_format_defaults
)
1058 /* Assume the default width is expected here and continue lexing. */
1059 value
= 0; /* It doesn't matter what we set the value to here. */
1063 error
= nonneg_required
;
1066 else if (is_input
&& t
== FMT_ZERO
)
1068 error
= posint_required
;
1075 if (t
!= FMT_PERIOD
)
1077 /* Warn if -std=legacy, otherwise error. */
1078 if (gfc_option
.warn_std
!= 0)
1080 error
= G_("Period required in format specifier in format "
1084 if (mode
!= MODE_FORMAT
)
1085 format_locus
.nextc
+= format_string_pos
;
1086 gfc_warning (0, "Period required in format specifier at %L",
1095 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
1097 error
= nonneg_required
;
1104 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
1106 if (mode
!= MODE_FORMAT
)
1107 format_locus
.nextc
+= format_string_pos
;
1108 gfc_warning (0, "The H format specifier at %L is"
1109 " a Fortran 95 deleted feature", &format_locus
);
1111 if (mode
== MODE_STRING
)
1113 format_string
+= value
;
1114 format_length
-= value
;
1115 format_string_pos
+= repeat
;
1121 next_char (INSTRING_WARN
);
1131 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
1133 if (flag_dec_format_defaults
)
1135 /* Assume the default width is expected here and continue lexing. */
1136 value
= 0; /* It doesn't matter what we set the value to here. */
1141 error
= nonneg_required
;
1145 else if (is_input
&& t
== FMT_ZERO
)
1147 error
= posint_required
;
1154 if (t
!= FMT_PERIOD
)
1161 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
1163 error
= nonneg_required
;
1171 error
= unexpected_element
;
1176 /* Between a descriptor and what comes next. */
1194 goto optional_comma
;
1197 error
= unexpected_end
;
1201 if (mode
!= MODE_FORMAT
)
1202 format_locus
.nextc
+= format_string_pos
- 1;
1203 if (!gfc_notify_std (GFC_STD_GNU
, "Missing comma at %L", &format_locus
))
1205 /* If we do not actually return a failure, we need to unwind this
1206 before the next round. */
1207 if (mode
!= MODE_FORMAT
)
1208 format_locus
.nextc
-= format_string_pos
;
1213 /* Optional comma is a weird between state where we've just finished
1214 reading a colon, slash, dollar or P descriptor. */
1231 /* Assume that we have another format item. */
1238 extension_optional_comma
:
1239 /* As a GNU extension, permit a missing comma after a string literal. */
1256 goto optional_comma
;
1259 error
= unexpected_end
;
1263 if (mode
!= MODE_FORMAT
)
1264 format_locus
.nextc
+= format_string_pos
;
1265 if (!gfc_notify_std (GFC_STD_GNU
, "Missing comma at %L", &format_locus
))
1267 /* If we do not actually return a failure, we need to unwind this
1268 before the next round. */
1269 if (mode
!= MODE_FORMAT
)
1270 format_locus
.nextc
-= format_string_pos
;
1278 if (mode
!= MODE_FORMAT
)
1279 format_locus
.nextc
+= format_string_pos
;
1280 if (error
== unexpected_element
)
1281 gfc_error (error
, error_element
, &format_locus
);
1283 gfc_error (error
, &format_locus
);
1292 /* Given an expression node that is a constant string, see if it looks
1293 like a format string. */
1296 check_format_string (gfc_expr
*e
, bool is_input
)
1300 if (!e
|| e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1304 format_string
= e
->value
.character
.string
;
1306 /* More elaborate measures are needed to show where a problem is within a
1307 format string that has been calculated, but that's probably not worth the
1309 format_locus
= e
->where
;
1310 rv
= check_format (is_input
);
1311 /* check for extraneous characters at the end of an otherwise valid format
1312 string, like '(A10,I3)F5'
1313 start at the end and move back to the last character processed,
1315 if (rv
&& e
->value
.character
.length
> format_string_pos
)
1316 for (i
=e
->value
.character
.length
-1;i
>format_string_pos
-1;i
--)
1317 if (e
->value
.character
.string
[i
] != ' ')
1319 format_locus
.nextc
+= format_length
+ 1;
1321 "Extraneous characters in format at %L", &format_locus
);
1328 /************ Fortran I/O statement matchers *************/
1330 /* Match a FORMAT statement. This amounts to actually parsing the
1331 format descriptors in order to correctly locate the end of the
1335 gfc_match_format (void)
1340 if (gfc_current_ns
->proc_name
1341 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1343 gfc_error ("Format statement in module main block at %C");
1347 /* Before parsing the rest of a FORMAT statement, check F2008:c1206. */
1348 if ((gfc_current_state () == COMP_FUNCTION
1349 || gfc_current_state () == COMP_SUBROUTINE
)
1350 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
1352 gfc_error ("FORMAT statement at %C cannot appear within an INTERFACE");
1356 if (gfc_statement_label
== NULL
)
1358 gfc_error ("Missing format label at %C");
1361 gfc_gobble_whitespace ();
1366 start
= gfc_current_locus
;
1368 if (!check_format (false))
1371 if (gfc_match_eos () != MATCH_YES
)
1373 gfc_syntax_error (ST_FORMAT
);
1377 /* The label doesn't get created until after the statement is done
1378 being matched, so we have to leave the string for later. */
1380 gfc_current_locus
= start
; /* Back to the beginning */
1383 new_st
.op
= EXEC_NOP
;
1385 e
= gfc_get_character_expr (gfc_default_character_kind
, &start
,
1386 NULL
, format_length
);
1387 format_string
= e
->value
.character
.string
;
1388 gfc_statement_label
->format
= e
;
1391 check_format (false); /* Guaranteed to succeed */
1392 gfc_match_eos (); /* Guaranteed to succeed */
1398 /* Check for a CHARACTER variable. The check for scalar is done in
1402 check_char_variable (gfc_expr
*e
)
1404 if (e
->expr_type
!= EXPR_VARIABLE
|| e
->ts
.type
!= BT_CHARACTER
)
1406 gfc_error("IOMSG must be a scalar-default-char-variable at %L", &e
->where
);
1414 is_char_type (const char *name
, gfc_expr
*e
)
1416 gfc_resolve_expr (e
);
1418 if (e
->ts
.type
!= BT_CHARACTER
)
1420 gfc_error ("%s requires a scalar-default-char-expr at %L",
1428 /* Match an expression I/O tag of some sort. */
1431 match_etag (const io_tag
*tag
, gfc_expr
**v
)
1436 m
= gfc_match (tag
->spec
);
1440 m
= gfc_match (tag
->value
, &result
);
1443 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1449 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1450 gfc_free_expr (result
);
1459 /* Match a variable I/O tag of some sort. */
1462 match_vtag (const io_tag
*tag
, gfc_expr
**v
)
1467 m
= gfc_match (tag
->spec
);
1471 m
= gfc_match (tag
->value
, &result
);
1474 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1480 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1481 gfc_free_expr (result
);
1485 if (result
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1487 gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag
->name
);
1488 gfc_free_expr (result
);
1492 bool impure
= gfc_impure_variable (result
->symtree
->n
.sym
);
1493 if (impure
&& gfc_pure (NULL
))
1495 gfc_error ("Variable %s cannot be assigned in PURE procedure at %C",
1497 gfc_free_expr (result
);
1502 gfc_unset_implicit_pure (NULL
);
1509 /* Match I/O tags that cause variables to become redefined. */
1512 match_out_tag (const io_tag
*tag
, gfc_expr
**result
)
1516 m
= match_vtag (tag
, result
);
1518 gfc_check_do_variable ((*result
)->symtree
);
1524 /* Match a label I/O tag. */
1527 match_ltag (const io_tag
*tag
, gfc_st_label
** label
)
1533 m
= gfc_match (tag
->spec
);
1537 m
= gfc_match (tag
->value
, label
);
1540 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1546 gfc_error ("Duplicate %s label specification at %C", tag
->name
);
1550 if (!gfc_reference_st_label (*label
, ST_LABEL_TARGET
))
1557 /* Match a tag using match_etag, but only if -fdec is enabled. */
1559 match_dec_etag (const io_tag
*tag
, gfc_expr
**e
)
1561 match m
= match_etag (tag
, e
);
1562 if (flag_dec
&& m
!= MATCH_NO
)
1564 else if (m
!= MATCH_NO
)
1566 gfc_error ("%s at %C is a DEC extension, enable with "
1567 "%<-fdec%>", tag
->name
);
1574 /* Match a tag using match_vtag, but only if -fdec is enabled. */
1576 match_dec_vtag (const io_tag
*tag
, gfc_expr
**e
)
1578 match m
= match_vtag(tag
, e
);
1579 if (flag_dec
&& m
!= MATCH_NO
)
1581 else if (m
!= MATCH_NO
)
1583 gfc_error ("%s at %C is a DEC extension, enable with "
1584 "%<-fdec%>", tag
->name
);
1591 /* Match a DEC I/O flag tag - a tag with no expression such as READONLY. */
1594 match_dec_ftag (const io_tag
*tag
, gfc_open
*o
)
1598 m
= gfc_match (tag
->spec
);
1604 gfc_error ("%s at %C is a DEC extension, enable with "
1605 "%<-fdec%>", tag
->name
);
1609 /* Just set the READONLY flag, which we use at runtime to avoid delete on
1611 if (tag
== &tag_readonly
)
1617 /* Interpret SHARED as SHARE='DENYNONE' (read lock). */
1618 else if (tag
== &tag_shared
)
1620 if (o
->share
!= NULL
)
1622 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1625 o
->share
= gfc_get_character_expr (gfc_default_character_kind
,
1626 &gfc_current_locus
, "denynone", 8);
1630 /* Interpret NOSHARED as SHARE='DENYRW' (exclusive lock). */
1631 else if (tag
== &tag_noshared
)
1633 if (o
->share
!= NULL
)
1635 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1638 o
->share
= gfc_get_character_expr (gfc_default_character_kind
,
1639 &gfc_current_locus
, "denyrw", 6);
1643 /* We handle all DEC tags above. */
1648 /* Resolution of the FORMAT tag, to be called from resolve_tag. */
1651 resolve_tag_format (gfc_expr
*e
)
1653 if (e
->expr_type
== EXPR_CONSTANT
1654 && (e
->ts
.type
!= BT_CHARACTER
1655 || e
->ts
.kind
!= gfc_default_character_kind
))
1657 gfc_error ("Constant expression in FORMAT tag at %L must be "
1658 "of type default CHARACTER", &e
->where
);
1662 /* Concatenate a constant character array into a single character
1665 if ((e
->expr_type
== EXPR_ARRAY
|| e
->rank
> 0)
1666 && e
->ts
.type
== BT_CHARACTER
1667 && gfc_is_constant_expr (e
))
1669 if (e
->expr_type
== EXPR_VARIABLE
1670 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1671 gfc_simplify_expr (e
, 1);
1673 if (e
->expr_type
== EXPR_ARRAY
)
1676 gfc_charlen_t n
, len
;
1678 gfc_char_t
*dest
, *src
;
1680 if (e
->value
.constructor
== NULL
)
1682 gfc_error ("FORMAT tag at %C cannot be a zero-sized array");
1687 c
= gfc_constructor_first (e
->value
.constructor
);
1688 len
= c
->expr
->value
.character
.length
;
1690 for ( ; c
; c
= gfc_constructor_next (c
))
1693 r
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, n
);
1694 dest
= r
->value
.character
.string
;
1696 for (c
= gfc_constructor_first (e
->value
.constructor
);
1697 c
; c
= gfc_constructor_next (c
))
1699 src
= c
->expr
->value
.character
.string
;
1700 for (gfc_charlen_t i
= 0 ; i
< len
; i
++)
1704 gfc_replace_expr (e
, r
);
1709 /* If e's rank is zero and e is not an element of an array, it should be
1710 of integer or character type. The integer variable should be
1713 && (e
->expr_type
!= EXPR_VARIABLE
1714 || e
->symtree
== NULL
1715 || e
->symtree
->n
.sym
->as
== NULL
1716 || e
->symtree
->n
.sym
->as
->rank
== 0))
1718 if ((e
->ts
.type
!= BT_CHARACTER
1719 || e
->ts
.kind
!= gfc_default_character_kind
)
1720 && e
->ts
.type
!= BT_INTEGER
)
1722 gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER "
1723 "or of INTEGER", &e
->where
);
1726 else if (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_VARIABLE
)
1728 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGNED variable in "
1729 "FORMAT tag at %L", &e
->where
))
1731 if (e
->symtree
->n
.sym
->attr
.assign
!= 1)
1733 gfc_error ("Variable %qs at %L has not been assigned a "
1734 "format label", e
->symtree
->n
.sym
->name
, &e
->where
);
1738 else if (e
->ts
.type
== BT_INTEGER
)
1740 gfc_error ("Scalar %qs in FORMAT tag at %L is not an ASSIGNED "
1741 "variable", gfc_basic_typename (e
->ts
.type
), &e
->where
);
1748 /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
1749 It may be assigned an Hollerith constant. */
1750 if (e
->ts
.type
!= BT_CHARACTER
)
1752 if (!gfc_notify_std (GFC_STD_LEGACY
, "Non-character in FORMAT tag "
1753 "at %L", &e
->where
))
1756 if (e
->rank
== 0 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
)
1758 gfc_error ("Non-character assumed shape array element in FORMAT"
1759 " tag at %L", &e
->where
);
1763 if (e
->rank
== 0 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
)
1765 gfc_error ("Non-character assumed size array element in FORMAT"
1766 " tag at %L", &e
->where
);
1770 if (e
->rank
== 0 && e
->symtree
->n
.sym
->attr
.pointer
)
1772 gfc_error ("Non-character pointer array element in FORMAT tag at %L",
1782 /* Do expression resolution and type-checking on an expression tag. */
1785 resolve_tag (const io_tag
*tag
, gfc_expr
*e
)
1790 if (!gfc_resolve_expr (e
))
1793 if (tag
== &tag_format
)
1794 return resolve_tag_format (e
);
1796 if (e
->ts
.type
!= tag
->type
)
1798 gfc_error ("%s tag at %L must be of type %s", tag
->name
,
1799 &e
->where
, gfc_basic_typename (tag
->type
));
1803 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= gfc_default_character_kind
)
1805 gfc_error ("%s tag at %L must be a character string of default kind",
1806 tag
->name
, &e
->where
);
1812 gfc_error ("%s tag at %L must be scalar", tag
->name
, &e
->where
);
1816 if (tag
== &tag_iomsg
)
1818 if (!gfc_notify_std (GFC_STD_F2003
, "IOMSG tag at %L", &e
->where
))
1822 if ((tag
== &tag_iostat
|| tag
== &tag_size
|| tag
== &tag_iolength
1823 || tag
== &tag_number
|| tag
== &tag_nextrec
|| tag
== &tag_s_recl
)
1824 && e
->ts
.kind
!= gfc_default_integer_kind
)
1826 if (!gfc_notify_std (GFC_STD_F2003
, "Fortran 95 requires default "
1827 "INTEGER in %s tag at %L", tag
->name
, &e
->where
))
1831 if (e
->ts
.kind
!= gfc_default_logical_kind
&&
1832 (tag
== &tag_exist
|| tag
== &tag_named
|| tag
== &tag_opened
1833 || tag
== &tag_pending
))
1835 if (!gfc_notify_std (GFC_STD_F2008
, "Non-default LOGICAL kind "
1836 "in %s tag at %L", tag
->name
, &e
->where
))
1840 if (tag
== &tag_newunit
)
1842 if (!gfc_notify_std (GFC_STD_F2008
, "NEWUNIT specifier at %L",
1847 /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */
1848 if (tag
== &tag_newunit
|| tag
== &tag_iostat
1849 || tag
== &tag_size
|| tag
== &tag_iomsg
)
1853 sprintf (context
, _("%s tag"), tag
->name
);
1854 if (!gfc_check_vardef_context (e
, false, false, false, context
))
1858 if (tag
== &tag_convert
)
1860 if (!gfc_notify_std (GFC_STD_GNU
, "CONVERT tag at %L", &e
->where
))
1868 /* Match a single tag of an OPEN statement. */
1871 match_open_element (gfc_open
*open
)
1875 m
= match_etag (&tag_e_async
, &open
->asynchronous
);
1876 if (m
== MATCH_YES
&& !is_char_type ("ASYNCHRONOUS", open
->asynchronous
))
1880 m
= match_etag (&tag_unit
, &open
->unit
);
1883 m
= match_etag (&tag_iomsg
, &open
->iomsg
);
1884 if (m
== MATCH_YES
&& !check_char_variable (open
->iomsg
))
1888 m
= match_out_tag (&tag_iostat
, &open
->iostat
);
1891 m
= match_etag (&tag_file
, &open
->file
);
1894 m
= match_etag (&tag_status
, &open
->status
);
1897 m
= match_etag (&tag_e_access
, &open
->access
);
1900 m
= match_etag (&tag_e_form
, &open
->form
);
1903 m
= match_etag (&tag_e_recl
, &open
->recl
);
1906 m
= match_etag (&tag_e_blank
, &open
->blank
);
1909 m
= match_etag (&tag_e_position
, &open
->position
);
1912 m
= match_etag (&tag_e_action
, &open
->action
);
1915 m
= match_etag (&tag_e_delim
, &open
->delim
);
1918 m
= match_etag (&tag_e_pad
, &open
->pad
);
1921 m
= match_etag (&tag_e_decimal
, &open
->decimal
);
1924 m
= match_etag (&tag_e_encoding
, &open
->encoding
);
1927 m
= match_etag (&tag_e_round
, &open
->round
);
1930 m
= match_etag (&tag_e_sign
, &open
->sign
);
1933 m
= match_ltag (&tag_err
, &open
->err
);
1936 m
= match_etag (&tag_convert
, &open
->convert
);
1939 m
= match_out_tag (&tag_newunit
, &open
->newunit
);
1943 /* The following are extensions enabled with -fdec. */
1944 m
= match_dec_etag (&tag_e_share
, &open
->share
);
1947 m
= match_dec_etag (&tag_cc
, &open
->cc
);
1950 m
= match_dec_ftag (&tag_readonly
, open
);
1953 m
= match_dec_ftag (&tag_shared
, open
);
1956 m
= match_dec_ftag (&tag_noshared
, open
);
1964 /* Free the gfc_open structure and all the expressions it contains. */
1967 gfc_free_open (gfc_open
*open
)
1972 gfc_free_expr (open
->unit
);
1973 gfc_free_expr (open
->iomsg
);
1974 gfc_free_expr (open
->iostat
);
1975 gfc_free_expr (open
->file
);
1976 gfc_free_expr (open
->status
);
1977 gfc_free_expr (open
->access
);
1978 gfc_free_expr (open
->form
);
1979 gfc_free_expr (open
->recl
);
1980 gfc_free_expr (open
->blank
);
1981 gfc_free_expr (open
->position
);
1982 gfc_free_expr (open
->action
);
1983 gfc_free_expr (open
->delim
);
1984 gfc_free_expr (open
->pad
);
1985 gfc_free_expr (open
->decimal
);
1986 gfc_free_expr (open
->encoding
);
1987 gfc_free_expr (open
->round
);
1988 gfc_free_expr (open
->sign
);
1989 gfc_free_expr (open
->convert
);
1990 gfc_free_expr (open
->asynchronous
);
1991 gfc_free_expr (open
->newunit
);
1992 gfc_free_expr (open
->share
);
1993 gfc_free_expr (open
->cc
);
1998 /* Resolve everything in a gfc_open structure. */
2001 gfc_resolve_open (gfc_open
*open
)
2004 RESOLVE_TAG (&tag_unit
, open
->unit
);
2005 RESOLVE_TAG (&tag_iomsg
, open
->iomsg
);
2006 RESOLVE_TAG (&tag_iostat
, open
->iostat
);
2007 RESOLVE_TAG (&tag_file
, open
->file
);
2008 RESOLVE_TAG (&tag_status
, open
->status
);
2009 RESOLVE_TAG (&tag_e_access
, open
->access
);
2010 RESOLVE_TAG (&tag_e_form
, open
->form
);
2011 RESOLVE_TAG (&tag_e_recl
, open
->recl
);
2012 RESOLVE_TAG (&tag_e_blank
, open
->blank
);
2013 RESOLVE_TAG (&tag_e_position
, open
->position
);
2014 RESOLVE_TAG (&tag_e_action
, open
->action
);
2015 RESOLVE_TAG (&tag_e_delim
, open
->delim
);
2016 RESOLVE_TAG (&tag_e_pad
, open
->pad
);
2017 RESOLVE_TAG (&tag_e_decimal
, open
->decimal
);
2018 RESOLVE_TAG (&tag_e_encoding
, open
->encoding
);
2019 RESOLVE_TAG (&tag_e_async
, open
->asynchronous
);
2020 RESOLVE_TAG (&tag_e_round
, open
->round
);
2021 RESOLVE_TAG (&tag_e_sign
, open
->sign
);
2022 RESOLVE_TAG (&tag_convert
, open
->convert
);
2023 RESOLVE_TAG (&tag_newunit
, open
->newunit
);
2024 RESOLVE_TAG (&tag_e_share
, open
->share
);
2025 RESOLVE_TAG (&tag_cc
, open
->cc
);
2027 if (!gfc_reference_st_label (open
->err
, ST_LABEL_TARGET
))
2034 /* Check if a given value for a SPECIFIER is either in the list of values
2035 allowed in F95 or F2003, issuing an error message and returning a zero
2036 value if it is not allowed. */
2039 compare_to_allowed_values (const char *specifier
, const char *allowed
[],
2040 const char *allowed_f2003
[],
2041 const char *allowed_gnu
[], gfc_char_t
*value
,
2042 const char *statement
, bool warn
,
2047 compare_to_allowed_values (const char *specifier
, const char *allowed
[],
2048 const char *allowed_f2003
[],
2049 const char *allowed_gnu
[], gfc_char_t
*value
,
2050 const char *statement
, bool warn
, int *num
)
2055 len
= gfc_wide_strlen (value
);
2058 for (len
--; len
> 0; len
--)
2059 if (value
[len
] != ' ')
2064 for (i
= 0; allowed
[i
]; i
++)
2065 if (len
== strlen (allowed
[i
])
2066 && gfc_wide_strncasecmp (value
, allowed
[i
], strlen (allowed
[i
])) == 0)
2073 for (i
= 0; allowed_f2003
&& allowed_f2003
[i
]; i
++)
2074 if (len
== strlen (allowed_f2003
[i
])
2075 && gfc_wide_strncasecmp (value
, allowed_f2003
[i
],
2076 strlen (allowed_f2003
[i
])) == 0)
2078 notification n
= gfc_notification_std (GFC_STD_F2003
);
2080 if (n
== WARNING
|| (warn
&& n
== ERROR
))
2082 gfc_warning (0, "Fortran 2003: %s specifier in %s statement at %C "
2083 "has value %qs", specifier
, statement
,
2090 gfc_notify_std (GFC_STD_F2003
, "%s specifier in "
2091 "%s statement at %C has value %qs", specifier
,
2092 statement
, allowed_f2003
[i
]);
2100 for (i
= 0; allowed_gnu
&& allowed_gnu
[i
]; i
++)
2101 if (len
== strlen (allowed_gnu
[i
])
2102 && gfc_wide_strncasecmp (value
, allowed_gnu
[i
],
2103 strlen (allowed_gnu
[i
])) == 0)
2105 notification n
= gfc_notification_std (GFC_STD_GNU
);
2107 if (n
== WARNING
|| (warn
&& n
== ERROR
))
2109 gfc_warning (0, "Extension: %s specifier in %s statement at %C "
2110 "has value %qs", specifier
, statement
,
2117 gfc_notify_std (GFC_STD_GNU
, "%s specifier in "
2118 "%s statement at %C has value %qs", specifier
,
2119 statement
, allowed_gnu
[i
]);
2129 char *s
= gfc_widechar_to_char (value
, -1);
2131 "%s specifier in %s statement at %C has invalid value %qs",
2132 specifier
, statement
, s
);
2138 char *s
= gfc_widechar_to_char (value
, -1);
2139 gfc_error ("%s specifier in %s statement at %C has invalid value %qs",
2140 specifier
, statement
, s
);
2147 /* Match an OPEN statement. */
2150 gfc_match_open (void)
2156 m
= gfc_match_char ('(');
2160 open
= XCNEW (gfc_open
);
2162 m
= match_open_element (open
);
2164 if (m
== MATCH_ERROR
)
2168 m
= gfc_match_expr (&open
->unit
);
2169 if (m
== MATCH_ERROR
)
2175 if (gfc_match_char (')') == MATCH_YES
)
2177 if (gfc_match_char (',') != MATCH_YES
)
2180 m
= match_open_element (open
);
2181 if (m
== MATCH_ERROR
)
2187 if (gfc_match_eos () == MATCH_NO
)
2190 if (gfc_pure (NULL
))
2192 gfc_error ("OPEN statement not allowed in PURE procedure at %C");
2196 gfc_unset_implicit_pure (NULL
);
2198 warn
= (open
->err
|| open
->iostat
) ? true : false;
2200 /* Checks on the ACCESS specifier. */
2201 if (open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
)
2203 static const char *access_f95
[] = { "SEQUENTIAL", "DIRECT", NULL
};
2204 static const char *access_f2003
[] = { "STREAM", NULL
};
2205 static const char *access_gnu
[] = { "APPEND", NULL
};
2207 if (!is_char_type ("ACCESS", open
->access
))
2210 if (!compare_to_allowed_values ("ACCESS", access_f95
, access_f2003
,
2212 open
->access
->value
.character
.string
,
2217 /* Checks on the ACTION specifier. */
2218 if (open
->action
&& open
->action
->expr_type
== EXPR_CONSTANT
)
2220 gfc_char_t
*str
= open
->action
->value
.character
.string
;
2221 static const char *action
[] = { "READ", "WRITE", "READWRITE", NULL
};
2223 if (!is_char_type ("ACTION", open
->action
))
2226 if (!compare_to_allowed_values ("ACTION", action
, NULL
, NULL
,
2230 /* With READONLY, only allow ACTION='READ'. */
2231 if (open
->readonly
&& (gfc_wide_strlen (str
) != 4
2232 || gfc_wide_strncasecmp (str
, "READ", 4) != 0))
2234 gfc_error ("ACTION type conflicts with READONLY specifier at %C");
2238 /* If we see READONLY and no ACTION, set ACTION='READ'. */
2239 else if (open
->readonly
&& open
->action
== NULL
)
2241 open
->action
= gfc_get_character_expr (gfc_default_character_kind
,
2242 &gfc_current_locus
, "read", 4);
2245 /* Checks on the ASYNCHRONOUS specifier. */
2246 if (open
->asynchronous
)
2248 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS= at %C "
2249 "not allowed in Fortran 95"))
2252 if (!is_char_type ("ASYNCHRONOUS", open
->asynchronous
))
2255 if (open
->asynchronous
->ts
.kind
!= 1)
2257 gfc_error ("ASYNCHRONOUS= specifier at %L must be of default "
2258 "CHARACTER kind", &open
->asynchronous
->where
);
2262 if (open
->asynchronous
->expr_type
== EXPR_ARRAY
2263 || open
->asynchronous
->expr_type
== EXPR_STRUCTURE
)
2265 gfc_error ("ASYNCHRONOUS= specifier at %L must be scalar",
2266 &open
->asynchronous
->where
);
2270 if (open
->asynchronous
->expr_type
== EXPR_CONSTANT
)
2272 static const char * asynchronous
[] = { "YES", "NO", NULL
};
2274 if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous
,
2275 NULL
, NULL
, open
->asynchronous
->value
.character
.string
,
2281 /* Checks on the BLANK specifier. */
2284 if (!gfc_notify_std (GFC_STD_F2003
, "BLANK= at %C "
2285 "not allowed in Fortran 95"))
2288 if (!is_char_type ("BLANK", open
->blank
))
2291 if (open
->blank
->expr_type
== EXPR_CONSTANT
)
2293 static const char *blank
[] = { "ZERO", "NULL", NULL
};
2295 if (!compare_to_allowed_values ("BLANK", blank
, NULL
, NULL
,
2296 open
->blank
->value
.character
.string
,
2302 /* Checks on the CARRIAGECONTROL specifier. */
2305 if (!is_char_type ("CARRIAGECONTROL", open
->cc
))
2308 if (open
->cc
->expr_type
== EXPR_CONSTANT
)
2310 static const char *cc
[] = { "LIST", "FORTRAN", "NONE", NULL
};
2311 if (!compare_to_allowed_values ("CARRIAGECONTROL", cc
, NULL
, NULL
,
2312 open
->cc
->value
.character
.string
,
2318 /* Checks on the DECIMAL specifier. */
2321 if (!gfc_notify_std (GFC_STD_F2003
, "DECIMAL= at %C "
2322 "not allowed in Fortran 95"))
2325 if (!is_char_type ("DECIMAL", open
->decimal
))
2328 if (open
->decimal
->expr_type
== EXPR_CONSTANT
)
2330 static const char * decimal
[] = { "COMMA", "POINT", NULL
};
2332 if (!compare_to_allowed_values ("DECIMAL", decimal
, NULL
, NULL
,
2333 open
->decimal
->value
.character
.string
,
2339 /* Checks on the DELIM specifier. */
2342 if (open
->delim
->expr_type
== EXPR_CONSTANT
)
2344 static const char *delim
[] = { "APOSTROPHE", "QUOTE", "NONE", NULL
};
2346 if (!is_char_type ("DELIM", open
->delim
))
2349 if (!compare_to_allowed_values ("DELIM", delim
, NULL
, NULL
,
2350 open
->delim
->value
.character
.string
,
2356 /* Checks on the ENCODING specifier. */
2359 if (!gfc_notify_std (GFC_STD_F2003
, "ENCODING= at %C "
2360 "not allowed in Fortran 95"))
2363 if (!is_char_type ("ENCODING", open
->encoding
))
2366 if (open
->encoding
->expr_type
== EXPR_CONSTANT
)
2368 static const char * encoding
[] = { "DEFAULT", "UTF-8", NULL
};
2370 if (!compare_to_allowed_values ("ENCODING", encoding
, NULL
, NULL
,
2371 open
->encoding
->value
.character
.string
,
2377 /* Checks on the FORM specifier. */
2378 if (open
->form
&& open
->form
->expr_type
== EXPR_CONSTANT
)
2380 static const char *form
[] = { "FORMATTED", "UNFORMATTED", NULL
};
2382 if (!is_char_type ("FORM", open
->form
))
2385 if (!compare_to_allowed_values ("FORM", form
, NULL
, NULL
,
2386 open
->form
->value
.character
.string
,
2391 /* Checks on the PAD specifier. */
2392 if (open
->pad
&& open
->pad
->expr_type
== EXPR_CONSTANT
)
2394 static const char *pad
[] = { "YES", "NO", NULL
};
2396 if (!is_char_type ("PAD", open
->pad
))
2399 if (!compare_to_allowed_values ("PAD", pad
, NULL
, NULL
,
2400 open
->pad
->value
.character
.string
,
2405 /* Checks on the POSITION specifier. */
2406 if (open
->position
&& open
->position
->expr_type
== EXPR_CONSTANT
)
2408 static const char *position
[] = { "ASIS", "REWIND", "APPEND", NULL
};
2410 if (!is_char_type ("POSITION", open
->position
))
2413 if (!compare_to_allowed_values ("POSITION", position
, NULL
, NULL
,
2414 open
->position
->value
.character
.string
,
2419 /* Checks on the ROUND specifier. */
2422 if (!gfc_notify_std (GFC_STD_F2003
, "ROUND= at %C "
2423 "not allowed in Fortran 95"))
2426 if (!is_char_type ("ROUND", open
->round
))
2429 if (open
->round
->expr_type
== EXPR_CONSTANT
)
2431 static const char * round
[] = { "UP", "DOWN", "ZERO", "NEAREST",
2432 "COMPATIBLE", "PROCESSOR_DEFINED",
2435 if (!compare_to_allowed_values ("ROUND", round
, NULL
, NULL
,
2436 open
->round
->value
.character
.string
,
2442 /* Checks on the SHARE specifier. */
2445 if (!is_char_type ("SHARE", open
->share
))
2448 if (open
->share
->expr_type
== EXPR_CONSTANT
)
2450 static const char *share
[] = { "DENYNONE", "DENYRW", NULL
};
2451 if (!compare_to_allowed_values ("SHARE", share
, NULL
, NULL
,
2452 open
->share
->value
.character
.string
,
2458 /* Checks on the SIGN specifier. */
2461 if (!gfc_notify_std (GFC_STD_F2003
, "SIGN= at %C "
2462 "not allowed in Fortran 95"))
2465 if (!is_char_type ("SIGN", open
->sign
))
2468 if (open
->sign
->expr_type
== EXPR_CONSTANT
)
2470 static const char * sign
[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
2473 if (!compare_to_allowed_values ("SIGN", sign
, NULL
, NULL
,
2474 open
->sign
->value
.character
.string
,
2480 #define warn_or_error(...) \
2483 gfc_warning (0, __VA_ARGS__); \
2486 gfc_error (__VA_ARGS__); \
2491 /* Checks on the RECL specifier. */
2492 if (open
->recl
&& open
->recl
->expr_type
== EXPR_CONSTANT
2493 && open
->recl
->ts
.type
== BT_INTEGER
2494 && mpz_sgn (open
->recl
->value
.integer
) != 1)
2496 warn_or_error ("RECL in OPEN statement at %C must be positive");
2499 /* Checks on the STATUS specifier. */
2500 if (open
->status
&& open
->status
->expr_type
== EXPR_CONSTANT
)
2502 static const char *status
[] = { "OLD", "NEW", "SCRATCH",
2503 "REPLACE", "UNKNOWN", NULL
};
2505 if (!is_char_type ("STATUS", open
->status
))
2508 if (!compare_to_allowed_values ("STATUS", status
, NULL
, NULL
,
2509 open
->status
->value
.character
.string
,
2513 /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2514 the FILE= specifier shall appear. */
2515 if (open
->file
== NULL
2516 && (gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2518 || gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2521 char *s
= gfc_widechar_to_char (open
->status
->value
.character
.string
,
2523 warn_or_error ("The STATUS specified in OPEN statement at %C is "
2524 "%qs and no FILE specifier is present", s
);
2528 /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2529 the FILE= specifier shall not appear. */
2530 if (gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2531 "scratch", 7) == 0 && open
->file
)
2533 warn_or_error ("The STATUS specified in OPEN statement at %C "
2534 "cannot have the value SCRATCH if a FILE specifier "
2539 /* Checks on NEWUNIT specifier. */
2544 gfc_error ("UNIT specifier not allowed with NEWUNIT at %C");
2550 (open
->status
->expr_type
== EXPR_CONSTANT
2551 && gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2552 "scratch", 7) != 0)))
2554 gfc_error ("NEWUNIT specifier must have FILE= "
2555 "or STATUS='scratch' at %C");
2559 else if (!open
->unit
)
2561 gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified");
2565 /* Things that are not allowed for unformatted I/O. */
2566 if (open
->form
&& open
->form
->expr_type
== EXPR_CONSTANT
2567 && (open
->delim
|| open
->decimal
|| open
->encoding
|| open
->round
2568 || open
->sign
|| open
->pad
|| open
->blank
)
2569 && gfc_wide_strncasecmp (open
->form
->value
.character
.string
,
2570 "unformatted", 11) == 0)
2572 const char *spec
= (open
->delim
? "DELIM "
2573 : (open
->pad
? "PAD " : open
->blank
2576 warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
2577 "unformatted I/O", spec
);
2580 if (open
->recl
&& open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
2581 && gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2584 warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
2589 && open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
2590 && !(gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2591 "sequential", 10) == 0
2592 || gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2594 || gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2597 warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
2598 "for stream or sequential ACCESS");
2601 #undef warn_or_error
2603 new_st
.op
= EXEC_OPEN
;
2604 new_st
.ext
.open
= open
;
2608 gfc_syntax_error (ST_OPEN
);
2611 gfc_free_open (open
);
2616 /* Free a gfc_close structure an all its expressions. */
2619 gfc_free_close (gfc_close
*close
)
2624 gfc_free_expr (close
->unit
);
2625 gfc_free_expr (close
->iomsg
);
2626 gfc_free_expr (close
->iostat
);
2627 gfc_free_expr (close
->status
);
2632 /* Match elements of a CLOSE statement. */
2635 match_close_element (gfc_close
*close
)
2639 m
= match_etag (&tag_unit
, &close
->unit
);
2642 m
= match_etag (&tag_status
, &close
->status
);
2645 m
= match_etag (&tag_iomsg
, &close
->iomsg
);
2646 if (m
== MATCH_YES
&& !check_char_variable (close
->iomsg
))
2650 m
= match_out_tag (&tag_iostat
, &close
->iostat
);
2653 m
= match_ltag (&tag_err
, &close
->err
);
2661 /* Match a CLOSE statement. */
2664 gfc_match_close (void)
2670 m
= gfc_match_char ('(');
2674 close
= XCNEW (gfc_close
);
2676 m
= match_close_element (close
);
2678 if (m
== MATCH_ERROR
)
2682 m
= gfc_match_expr (&close
->unit
);
2685 if (m
== MATCH_ERROR
)
2691 if (gfc_match_char (')') == MATCH_YES
)
2693 if (gfc_match_char (',') != MATCH_YES
)
2696 m
= match_close_element (close
);
2697 if (m
== MATCH_ERROR
)
2703 if (gfc_match_eos () == MATCH_NO
)
2706 if (gfc_pure (NULL
))
2708 gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2712 gfc_unset_implicit_pure (NULL
);
2714 warn
= (close
->iostat
|| close
->err
) ? true : false;
2716 /* Checks on the STATUS specifier. */
2717 if (close
->status
&& close
->status
->expr_type
== EXPR_CONSTANT
)
2719 static const char *status
[] = { "KEEP", "DELETE", NULL
};
2721 if (!is_char_type ("STATUS", close
->status
))
2724 if (!compare_to_allowed_values ("STATUS", status
, NULL
, NULL
,
2725 close
->status
->value
.character
.string
,
2730 new_st
.op
= EXEC_CLOSE
;
2731 new_st
.ext
.close
= close
;
2735 gfc_syntax_error (ST_CLOSE
);
2738 gfc_free_close (close
);
2743 /* Resolve everything in a gfc_close structure. */
2746 gfc_resolve_close (gfc_close
*close
)
2748 RESOLVE_TAG (&tag_unit
, close
->unit
);
2749 RESOLVE_TAG (&tag_iomsg
, close
->iomsg
);
2750 RESOLVE_TAG (&tag_iostat
, close
->iostat
);
2751 RESOLVE_TAG (&tag_status
, close
->status
);
2753 if (!gfc_reference_st_label (close
->err
, ST_LABEL_TARGET
))
2756 if (close
->unit
== NULL
)
2758 /* Find a locus from one of the arguments to close, when UNIT is
2760 locus loc
= gfc_current_locus
;
2762 loc
= close
->status
->where
;
2763 else if (close
->iostat
)
2764 loc
= close
->iostat
->where
;
2765 else if (close
->iomsg
)
2766 loc
= close
->iomsg
->where
;
2767 else if (close
->err
)
2768 loc
= close
->err
->where
;
2770 gfc_error ("CLOSE statement at %L requires a UNIT number", &loc
);
2774 if (close
->unit
->expr_type
== EXPR_CONSTANT
2775 && close
->unit
->ts
.type
== BT_INTEGER
2776 && mpz_sgn (close
->unit
->value
.integer
) < 0)
2778 gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2779 &close
->unit
->where
);
2786 /* Free a gfc_filepos structure. */
2789 gfc_free_filepos (gfc_filepos
*fp
)
2791 gfc_free_expr (fp
->unit
);
2792 gfc_free_expr (fp
->iomsg
);
2793 gfc_free_expr (fp
->iostat
);
2798 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
2801 match_file_element (gfc_filepos
*fp
)
2805 m
= match_etag (&tag_unit
, &fp
->unit
);
2808 m
= match_etag (&tag_iomsg
, &fp
->iomsg
);
2809 if (m
== MATCH_YES
&& !check_char_variable (fp
->iomsg
))
2813 m
= match_out_tag (&tag_iostat
, &fp
->iostat
);
2816 m
= match_ltag (&tag_err
, &fp
->err
);
2824 /* Match the second half of the file-positioning statements, REWIND,
2825 BACKSPACE, ENDFILE, or the FLUSH statement. */
2828 match_filepos (gfc_statement st
, gfc_exec_op op
)
2833 fp
= XCNEW (gfc_filepos
);
2835 if (gfc_match_char ('(') == MATCH_NO
)
2837 m
= gfc_match_expr (&fp
->unit
);
2838 if (m
== MATCH_ERROR
)
2846 m
= match_file_element (fp
);
2847 if (m
== MATCH_ERROR
)
2851 m
= gfc_match_expr (&fp
->unit
);
2852 if (m
== MATCH_ERROR
|| m
== MATCH_NO
)
2858 if (gfc_match_char (')') == MATCH_YES
)
2860 if (gfc_match_char (',') != MATCH_YES
)
2863 m
= match_file_element (fp
);
2864 if (m
== MATCH_ERROR
)
2871 if (gfc_match_eos () != MATCH_YES
)
2874 if (gfc_pure (NULL
))
2876 gfc_error ("%s statement not allowed in PURE procedure at %C",
2877 gfc_ascii_statement (st
));
2882 gfc_unset_implicit_pure (NULL
);
2885 new_st
.ext
.filepos
= fp
;
2889 gfc_syntax_error (st
);
2892 gfc_free_filepos (fp
);
2898 gfc_resolve_filepos (gfc_filepos
*fp
, locus
*where
)
2900 RESOLVE_TAG (&tag_unit
, fp
->unit
);
2901 RESOLVE_TAG (&tag_iostat
, fp
->iostat
);
2902 RESOLVE_TAG (&tag_iomsg
, fp
->iomsg
);
2904 if (!fp
->unit
&& (fp
->iostat
|| fp
->iomsg
|| fp
->err
))
2906 gfc_error ("UNIT number missing in statement at %L", where
);
2910 if (!gfc_reference_st_label (fp
->err
, ST_LABEL_TARGET
))
2913 if (fp
->unit
->expr_type
== EXPR_CONSTANT
2914 && fp
->unit
->ts
.type
== BT_INTEGER
2915 && mpz_sgn (fp
->unit
->value
.integer
) < 0)
2917 gfc_error ("UNIT number in statement at %L must be non-negative",
2926 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2927 and the FLUSH statement. */
2930 gfc_match_endfile (void)
2932 return match_filepos (ST_END_FILE
, EXEC_ENDFILE
);
2936 gfc_match_backspace (void)
2938 return match_filepos (ST_BACKSPACE
, EXEC_BACKSPACE
);
2942 gfc_match_rewind (void)
2944 return match_filepos (ST_REWIND
, EXEC_REWIND
);
2948 gfc_match_flush (void)
2950 if (!gfc_notify_std (GFC_STD_F2003
, "FLUSH statement at %C"))
2953 return match_filepos (ST_FLUSH
, EXEC_FLUSH
);
2956 /******************** Data Transfer Statements *********************/
2958 /* Return a default unit number. */
2961 default_unit (io_kind k
)
2970 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, unit
);
2974 /* Match a unit specification for a data transfer statement. */
2977 match_dt_unit (io_kind k
, gfc_dt
*dt
)
2982 if (gfc_match_char ('*') == MATCH_YES
)
2984 if (dt
->io_unit
!= NULL
)
2987 dt
->io_unit
= default_unit (k
);
2989 c
= gfc_peek_ascii_char ();
2991 gfc_error_now ("Missing format with default unit at %C");
2996 if (gfc_match_expr (&e
) == MATCH_YES
)
2998 if (dt
->io_unit
!= NULL
)
3011 gfc_error ("Duplicate UNIT specification at %C");
3016 /* Match a format specification. */
3019 match_dt_format (gfc_dt
*dt
)
3023 gfc_st_label
*label
;
3026 where
= gfc_current_locus
;
3028 if (gfc_match_char ('*') == MATCH_YES
)
3030 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
3033 dt
->format_label
= &format_asterisk
;
3037 if ((m
= gfc_match_st_label (&label
)) == MATCH_YES
)
3041 /* Need to check if the format label is actually either an operand
3042 to a user-defined operator or is a kind type parameter. That is,
3043 print 2.ip.8 ! .ip. is a user-defined operator return CHARACTER.
3044 print 1_'(I0)', i ! 1_'(I0)' is a default character string. */
3046 gfc_gobble_whitespace ();
3047 c
= gfc_peek_ascii_char ();
3048 if (c
== '.' || c
== '_')
3049 gfc_current_locus
= where
;
3052 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
3054 gfc_free_st_label (label
);
3058 if (!gfc_reference_st_label (label
, ST_LABEL_FORMAT
))
3061 dt
->format_label
= label
;
3065 else if (m
== MATCH_ERROR
)
3066 /* The label was zero or too large. Emit the correct diagnosis. */
3069 if (gfc_match_expr (&e
) == MATCH_YES
)
3071 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
3076 dt
->format_expr
= e
;
3080 gfc_current_locus
= where
; /* The only case where we have to restore */
3085 gfc_error ("Duplicate format specification at %C");
3089 /* Check for formatted read and write DTIO procedures. */
3092 dtio_procs_present (gfc_symbol
*sym
, io_kind k
)
3094 gfc_symbol
*derived
;
3096 if (sym
&& sym
->ts
.u
.derived
)
3098 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
3099 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
3100 else if (sym
->ts
.type
== BT_DERIVED
)
3101 derived
= sym
->ts
.u
.derived
;
3104 if ((k
== M_WRITE
|| k
== M_PRINT
) &&
3105 (gfc_find_specific_dtio_proc (derived
, true, true) != NULL
))
3107 if ((k
== M_READ
) &&
3108 (gfc_find_specific_dtio_proc (derived
, false, true) != NULL
))
3114 /* Traverse a namelist that is part of a READ statement to make sure
3115 that none of the variables in the namelist are INTENT(IN). Returns
3116 nonzero if we find such a variable. */
3119 check_namelist (gfc_symbol
*sym
)
3123 for (p
= sym
->namelist
; p
; p
= p
->next
)
3124 if (p
->sym
->attr
.intent
== INTENT_IN
)
3126 gfc_error ("Symbol %qs in namelist %qs is INTENT(IN) at %C",
3127 p
->sym
->name
, sym
->name
);
3135 /* Match a single data transfer element. */
3138 match_dt_element (io_kind k
, gfc_dt
*dt
)
3140 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3144 if (gfc_match (" unit =") == MATCH_YES
)
3146 m
= match_dt_unit (k
, dt
);
3151 if (gfc_match (" fmt =") == MATCH_YES
)
3153 m
= match_dt_format (dt
);
3158 if (gfc_match (" nml = %n", name
) == MATCH_YES
)
3160 if (dt
->namelist
!= NULL
)
3162 gfc_error ("Duplicate NML specification at %C");
3166 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
3169 if (sym
== NULL
|| sym
->attr
.flavor
!= FL_NAMELIST
)
3171 gfc_error ("Symbol %qs at %C must be a NAMELIST group name",
3172 sym
!= NULL
? sym
->name
: name
);
3177 if (k
== M_READ
&& check_namelist (sym
))
3183 m
= match_etag (&tag_e_async
, &dt
->asynchronous
);
3184 if (m
== MATCH_YES
&& !is_char_type ("ASYNCHRONOUS", dt
->asynchronous
))
3188 m
= match_etag (&tag_e_blank
, &dt
->blank
);
3191 m
= match_etag (&tag_e_delim
, &dt
->delim
);
3194 m
= match_etag (&tag_e_pad
, &dt
->pad
);
3197 m
= match_etag (&tag_e_sign
, &dt
->sign
);
3200 m
= match_etag (&tag_e_round
, &dt
->round
);
3203 m
= match_out_tag (&tag_id
, &dt
->id
);
3206 m
= match_etag (&tag_e_decimal
, &dt
->decimal
);
3209 m
= match_etag (&tag_rec
, &dt
->rec
);
3212 m
= match_etag (&tag_spos
, &dt
->pos
);
3215 m
= match_etag (&tag_iomsg
, &dt
->iomsg
);
3216 if (m
== MATCH_YES
&& !check_char_variable (dt
->iomsg
))
3221 m
= match_out_tag (&tag_iostat
, &dt
->iostat
);
3224 m
= match_ltag (&tag_err
, &dt
->err
);
3226 dt
->err_where
= gfc_current_locus
;
3229 m
= match_etag (&tag_advance
, &dt
->advance
);
3232 m
= match_out_tag (&tag_size
, &dt
->size
);
3236 m
= match_ltag (&tag_end
, &dt
->end
);
3241 gfc_error ("END tag at %C not allowed in output statement");
3244 dt
->end_where
= gfc_current_locus
;
3249 m
= match_ltag (&tag_eor
, &dt
->eor
);
3251 dt
->eor_where
= gfc_current_locus
;
3259 /* Free a data transfer structure and everything below it. */
3262 gfc_free_dt (gfc_dt
*dt
)
3267 gfc_free_expr (dt
->io_unit
);
3268 gfc_free_expr (dt
->format_expr
);
3269 gfc_free_expr (dt
->rec
);
3270 gfc_free_expr (dt
->advance
);
3271 gfc_free_expr (dt
->iomsg
);
3272 gfc_free_expr (dt
->iostat
);
3273 gfc_free_expr (dt
->size
);
3274 gfc_free_expr (dt
->pad
);
3275 gfc_free_expr (dt
->delim
);
3276 gfc_free_expr (dt
->sign
);
3277 gfc_free_expr (dt
->round
);
3278 gfc_free_expr (dt
->blank
);
3279 gfc_free_expr (dt
->decimal
);
3280 gfc_free_expr (dt
->pos
);
3281 gfc_free_expr (dt
->dt_io_kind
);
3282 /* dt->extra_comma is a link to dt_io_kind if it is set. */
3287 /* Resolve everything in a gfc_dt structure. */
3290 gfc_resolve_dt (gfc_dt
*dt
, locus
*loc
)
3296 /* This is set in any case. */
3297 gcc_assert (dt
->dt_io_kind
);
3298 k
= dt
->dt_io_kind
->value
.iokind
;
3300 tmp
= gfc_current_locus
;
3301 gfc_current_locus
= *loc
;
3302 if (!resolve_tag (&tag_format
, dt
->format_expr
))
3304 gfc_current_locus
= tmp
;
3307 gfc_current_locus
= tmp
;
3309 RESOLVE_TAG (&tag_rec
, dt
->rec
);
3310 RESOLVE_TAG (&tag_spos
, dt
->pos
);
3311 RESOLVE_TAG (&tag_advance
, dt
->advance
);
3312 RESOLVE_TAG (&tag_id
, dt
->id
);
3313 RESOLVE_TAG (&tag_iomsg
, dt
->iomsg
);
3314 RESOLVE_TAG (&tag_iostat
, dt
->iostat
);
3315 RESOLVE_TAG (&tag_size
, dt
->size
);
3316 RESOLVE_TAG (&tag_e_pad
, dt
->pad
);
3317 RESOLVE_TAG (&tag_e_delim
, dt
->delim
);
3318 RESOLVE_TAG (&tag_e_sign
, dt
->sign
);
3319 RESOLVE_TAG (&tag_e_round
, dt
->round
);
3320 RESOLVE_TAG (&tag_e_blank
, dt
->blank
);
3321 RESOLVE_TAG (&tag_e_decimal
, dt
->decimal
);
3322 RESOLVE_TAG (&tag_e_async
, dt
->asynchronous
);
3327 gfc_error ("UNIT not specified at %L", loc
);
3331 if (e
->symtree
&& e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
3332 && e
->ts
.type
== BT_CHARACTER
)
3334 gfc_error ("UNIT specification at %L must "
3335 "not be a character PARAMETER", &e
->where
);
3339 if (gfc_resolve_expr (e
)
3340 && (e
->ts
.type
!= BT_INTEGER
3341 && (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_VARIABLE
)))
3343 /* If there is no extra comma signifying the "format" form of the IO
3344 statement, then this must be an error. */
3345 if (!dt
->extra_comma
)
3347 gfc_error ("UNIT specification at %L must be an INTEGER expression "
3348 "or a CHARACTER variable", &e
->where
);
3353 /* At this point, we have an extra comma. If io_unit has arrived as
3354 type character, we assume its really the "format" form of the I/O
3355 statement. We set the io_unit to the default unit and format to
3356 the character expression. See F95 Standard section 9.4. */
3357 if (e
->ts
.type
== BT_CHARACTER
&& (k
== M_READ
|| k
== M_PRINT
))
3359 dt
->format_expr
= dt
->io_unit
;
3360 dt
->io_unit
= default_unit (k
);
3362 /* Nullify this pointer now so that a warning/error is not
3363 triggered below for the "Extension". */
3364 dt
->extra_comma
= NULL
;
3369 gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
3370 &dt
->extra_comma
->where
);
3376 if (e
->ts
.type
== BT_CHARACTER
)
3378 if (gfc_has_vector_index (e
))
3380 gfc_error ("Internal unit with vector subscript at %L", &e
->where
);
3384 /* If we are writing, make sure the internal unit can be changed. */
3385 gcc_assert (k
!= M_PRINT
);
3387 && !gfc_check_vardef_context (e
, false, false, false,
3388 _("internal unit in WRITE")))
3392 if (e
->rank
&& e
->ts
.type
!= BT_CHARACTER
)
3394 gfc_error ("External IO UNIT cannot be an array at %L", &e
->where
);
3398 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_INTEGER
3399 && mpz_sgn (e
->value
.integer
) < 0)
3401 gfc_error ("UNIT number in statement at %L must be non-negative",
3406 /* If we are reading and have a namelist, check that all namelist symbols
3407 can appear in a variable definition context. */
3411 for (n
= dt
->namelist
->namelist
; n
; n
= n
->next
)
3418 e
= gfc_get_variable_expr (gfc_find_sym_in_symtree (n
->sym
));
3419 t
= gfc_check_vardef_context (e
, false, false, false, NULL
);
3424 gfc_error ("NAMELIST %qs in READ statement at %L contains"
3425 " the symbol %qs which may not appear in a"
3426 " variable definition context",
3427 dt
->namelist
->name
, loc
, n
->sym
->name
);
3432 t
= dtio_procs_present (n
->sym
, k
);
3434 if (n
->sym
->ts
.type
== BT_CLASS
&& !t
)
3436 gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
3437 "polymorphic and requires a defined input/output "
3438 "procedure", n
->sym
->name
, dt
->namelist
->name
, loc
);
3442 if ((n
->sym
->ts
.type
== BT_DERIVED
)
3443 && (n
->sym
->ts
.u
.derived
->attr
.alloc_comp
3444 || n
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
3446 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
3447 "namelist %qs at %L with ALLOCATABLE "
3448 "or POINTER components", n
->sym
->name
,
3449 dt
->namelist
->name
, loc
))
3454 gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
3455 "ALLOCATABLE or POINTER components and thus requires "
3456 "a defined input/output procedure", n
->sym
->name
,
3457 dt
->namelist
->name
, loc
);
3465 && !gfc_notify_std (GFC_STD_LEGACY
, "Comma before i/o item list at %L",
3466 &dt
->extra_comma
->where
))
3471 if (!gfc_reference_st_label (dt
->err
, ST_LABEL_TARGET
))
3473 if (dt
->err
->defined
== ST_LABEL_UNKNOWN
)
3475 gfc_error ("ERR tag label %d at %L not defined",
3476 dt
->err
->value
, &dt
->err_where
);
3483 if (!gfc_reference_st_label (dt
->end
, ST_LABEL_TARGET
))
3485 if (dt
->end
->defined
== ST_LABEL_UNKNOWN
)
3487 gfc_error ("END tag label %d at %L not defined",
3488 dt
->end
->value
, &dt
->end_where
);
3495 if (!gfc_reference_st_label (dt
->eor
, ST_LABEL_TARGET
))
3497 if (dt
->eor
->defined
== ST_LABEL_UNKNOWN
)
3499 gfc_error ("EOR tag label %d at %L not defined",
3500 dt
->eor
->value
, &dt
->eor_where
);
3505 /* Check the format label actually exists. */
3506 if (dt
->format_label
&& dt
->format_label
!= &format_asterisk
3507 && dt
->format_label
->defined
== ST_LABEL_UNKNOWN
)
3509 gfc_error ("FORMAT label %d at %L not defined", dt
->format_label
->value
,
3518 /* Given an io_kind, return its name. */
3521 io_kind_name (io_kind k
)
3540 gfc_internal_error ("io_kind_name(): bad I/O-kind");
3547 /* Match an IO iteration statement of the form:
3549 ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
3551 which is equivalent to a single IO element. This function is
3552 mutually recursive with match_io_element(). */
3554 static match
match_io_element (io_kind
, gfc_code
**);
3557 match_io_iterator (io_kind k
, gfc_code
**result
)
3559 gfc_code
*head
, *tail
, *new_code
;
3567 old_loc
= gfc_current_locus
;
3569 if (gfc_match_char ('(') != MATCH_YES
)
3572 m
= match_io_element (k
, &head
);
3575 if (m
!= MATCH_YES
|| gfc_match_char (',') != MATCH_YES
)
3581 /* Can't be anything but an IO iterator. Build a list. */
3582 iter
= gfc_get_iterator ();
3586 m
= gfc_match_iterator (iter
, 0);
3587 if (m
== MATCH_ERROR
)
3591 gfc_check_do_variable (iter
->var
->symtree
);
3595 m
= match_io_element (k
, &new_code
);
3596 if (m
== MATCH_ERROR
)
3605 tail
= gfc_append_code (tail
, new_code
);
3607 if (gfc_match_char (',') != MATCH_YES
)
3616 if (gfc_match_char (')') != MATCH_YES
)
3619 new_code
= gfc_get_code (EXEC_DO
);
3620 new_code
->ext
.iterator
= iter
;
3622 new_code
->block
= gfc_get_code (EXEC_DO
);
3623 new_code
->block
->next
= head
;
3629 gfc_error ("Syntax error in I/O iterator at %C");
3633 gfc_free_iterator (iter
, 1);
3634 gfc_free_statements (head
);
3635 gfc_current_locus
= old_loc
;
3640 /* Match a single element of an IO list, which is either a single
3641 expression or an IO Iterator. */
3644 match_io_element (io_kind k
, gfc_code
**cpp
)
3652 m
= match_io_iterator (k
, cpp
);
3658 m
= gfc_match_variable (&expr
, 0);
3660 gfc_error ("Expected variable in READ statement at %C");
3663 && expr
->expr_type
== EXPR_VARIABLE
3664 && expr
->symtree
->n
.sym
->attr
.external
)
3666 gfc_error ("Expecting variable or io-implied-do at %L",
3674 m
= gfc_match_expr (&expr
);
3676 gfc_error ("Expected expression in %s statement at %C",
3679 if (m
== MATCH_YES
&& expr
->ts
.type
== BT_BOZ
)
3681 if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in "
3682 "an output IO list", &gfc_current_locus
))
3684 if (!gfc_boz2int (expr
, gfc_max_integer_kind
))
3689 if (m
== MATCH_YES
&& k
== M_READ
&& gfc_check_do_variable (expr
->symtree
))
3694 gfc_free_expr (expr
);
3698 cp
= gfc_get_code (EXEC_TRANSFER
);
3701 cp
->ext
.dt
= current_dt
;
3708 /* Match an I/O list, building gfc_code structures as we go. */
3711 match_io_list (io_kind k
, gfc_code
**head_p
)
3713 gfc_code
*head
, *tail
, *new_code
;
3716 *head_p
= head
= tail
= NULL
;
3717 if (gfc_match_eos () == MATCH_YES
)
3722 m
= match_io_element (k
, &new_code
);
3723 if (m
== MATCH_ERROR
)
3728 tail
= gfc_append_code (tail
, new_code
);
3732 if (gfc_match_eos () == MATCH_YES
)
3734 if (gfc_match_char (',') != MATCH_YES
)
3742 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
3745 gfc_free_statements (head
);
3750 /* Attach the data transfer end node. */
3753 terminate_io (gfc_code
*io_code
)
3757 if (io_code
== NULL
)
3758 io_code
= new_st
.block
;
3760 c
= gfc_get_code (EXEC_DT_END
);
3762 /* Point to structure that is already there */
3763 c
->ext
.dt
= new_st
.ext
.dt
;
3764 gfc_append_code (io_code
, c
);
3768 /* Check the constraints for a data transfer statement. The majority of the
3769 constraints appearing in 9.4 of the standard appear here. Some are handled
3770 in resolve_tag and others in gfc_resolve_dt. Also set the async_io_dt flag
3771 and, if necessary, the asynchronous flag on the SIZE argument. */
3774 check_io_constraints (io_kind k
, gfc_dt
*dt
, gfc_code
*io_code
,
3777 #define io_constraint(condition, msg, arg)\
3780 if ((arg)->lb != NULL)\
3781 gfc_error ((msg), (arg));\
3783 gfc_error ((msg), &gfc_current_locus);\
3789 gfc_symbol
*sym
= NULL
;
3790 bool warn
, unformatted
;
3792 warn
= (dt
->err
|| dt
->iostat
) ? true : false;
3793 unformatted
= dt
->format_expr
== NULL
&& dt
->format_label
== NULL
3794 && dt
->namelist
== NULL
;
3799 if (expr
&& expr
->expr_type
== EXPR_VARIABLE
3800 && expr
->ts
.type
== BT_CHARACTER
)
3802 sym
= expr
->symtree
->n
.sym
;
3804 io_constraint (k
== M_WRITE
&& sym
->attr
.intent
== INTENT_IN
,
3805 "Internal file at %L must not be INTENT(IN)",
3808 io_constraint (gfc_has_vector_index (dt
->io_unit
),
3809 "Internal file incompatible with vector subscript at %L",
3812 io_constraint (dt
->rec
!= NULL
,
3813 "REC tag at %L is incompatible with internal file",
3816 io_constraint (dt
->pos
!= NULL
,
3817 "POS tag at %L is incompatible with internal file",
3820 io_constraint (unformatted
,
3821 "Unformatted I/O not allowed with internal unit at %L",
3822 &dt
->io_unit
->where
);
3824 io_constraint (dt
->asynchronous
!= NULL
,
3825 "ASYNCHRONOUS tag at %L not allowed with internal file",
3826 &dt
->asynchronous
->where
);
3828 if (dt
->namelist
!= NULL
)
3830 if (!gfc_notify_std (GFC_STD_F2003
, "Internal file at %L with "
3831 "namelist", &expr
->where
))
3835 io_constraint (dt
->advance
!= NULL
,
3836 "ADVANCE tag at %L is incompatible with internal file",
3837 &dt
->advance
->where
);
3840 if (expr
&& expr
->ts
.type
!= BT_CHARACTER
)
3843 if (gfc_pure (NULL
) && (k
== M_READ
|| k
== M_WRITE
))
3845 gfc_error ("IO UNIT in %s statement at %C must be "
3846 "an internal file in a PURE procedure",
3851 if (k
== M_READ
|| k
== M_WRITE
)
3852 gfc_unset_implicit_pure (NULL
);
3857 io_constraint (dt
->end
, "END tag not allowed with output at %L",
3860 io_constraint (dt
->eor
, "EOR tag not allowed with output at %L",
3863 io_constraint (dt
->blank
, "BLANK= specifier not allowed with output at %L",
3866 io_constraint (dt
->pad
, "PAD= specifier not allowed with output at %L",
3869 io_constraint (dt
->size
, "SIZE= specifier not allowed with output at %L",
3874 io_constraint (dt
->size
&& dt
->advance
== NULL
,
3875 "SIZE tag at %L requires an ADVANCE tag",
3878 io_constraint (dt
->eor
&& dt
->advance
== NULL
,
3879 "EOR tag at %L requires an ADVANCE tag",
3883 if (dt
->asynchronous
)
3886 static const char * asynchronous
[] = { "YES", "NO", NULL
};
3888 if (!gfc_reduce_init_expr (dt
->asynchronous
))
3890 gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3891 "expression", &dt
->asynchronous
->where
);
3895 if (!is_char_type ("ASYNCHRONOUS", dt
->asynchronous
))
3898 if (dt
->asynchronous
->ts
.kind
!= 1)
3900 gfc_error ("ASYNCHRONOUS= specifier at %L must be of default "
3901 "CHARACTER kind", &dt
->asynchronous
->where
);
3905 if (dt
->asynchronous
->expr_type
== EXPR_ARRAY
3906 || dt
->asynchronous
->expr_type
== EXPR_STRUCTURE
)
3908 gfc_error ("ASYNCHRONOUS= specifier at %L must be scalar",
3909 &dt
->asynchronous
->where
);
3913 if (!compare_to_allowed_values
3914 ("ASYNCHRONOUS", asynchronous
, NULL
, NULL
,
3915 dt
->asynchronous
->value
.character
.string
,
3916 io_kind_name (k
), warn
, &num
))
3919 /* Best to put this here because the yes/no info is still around. */
3920 async_io_dt
= num
== 0;
3921 if (async_io_dt
&& dt
->size
)
3922 dt
->size
->symtree
->n
.sym
->attr
.asynchronous
= 1;
3925 async_io_dt
= false;
3931 || gfc_wide_strlen (dt
->asynchronous
->value
.character
.string
) != 3
3932 || gfc_wide_strncasecmp (dt
->asynchronous
->value
.character
.string
,
3934 io_constraint (not_yes
,
3935 "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3936 "specifier", &dt
->id
->where
);
3941 if (!gfc_notify_std (GFC_STD_F2003
, "DECIMAL= at %C "
3942 "not allowed in Fortran 95"))
3945 if (dt
->decimal
->expr_type
== EXPR_CONSTANT
)
3947 static const char * decimal
[] = { "COMMA", "POINT", NULL
};
3949 if (!is_char_type ("DECIMAL", dt
->decimal
))
3952 if (!compare_to_allowed_values ("DECIMAL", decimal
, NULL
, NULL
,
3953 dt
->decimal
->value
.character
.string
,
3954 io_kind_name (k
), warn
))
3957 io_constraint (unformatted
,
3958 "the DECIMAL= specifier at %L must be with an "
3959 "explicit format expression", &dt
->decimal
->where
);
3965 if (!gfc_notify_std (GFC_STD_F2003
, "BLANK= at %C "
3966 "not allowed in Fortran 95"))
3969 if (!is_char_type ("BLANK", dt
->blank
))
3972 if (dt
->blank
->expr_type
== EXPR_CONSTANT
)
3974 static const char * blank
[] = { "NULL", "ZERO", NULL
};
3977 if (!compare_to_allowed_values ("BLANK", blank
, NULL
, NULL
,
3978 dt
->blank
->value
.character
.string
,
3979 io_kind_name (k
), warn
))
3982 io_constraint (unformatted
,
3983 "the BLANK= specifier at %L must be with an "
3984 "explicit format expression", &dt
->blank
->where
);
3990 if (!gfc_notify_std (GFC_STD_F2003
, "PAD= at %C "
3991 "not allowed in Fortran 95"))
3994 if (!is_char_type ("PAD", dt
->pad
))
3997 if (dt
->pad
->expr_type
== EXPR_CONSTANT
)
3999 static const char * pad
[] = { "YES", "NO", NULL
};
4001 if (!compare_to_allowed_values ("PAD", pad
, NULL
, NULL
,
4002 dt
->pad
->value
.character
.string
,
4003 io_kind_name (k
), warn
))
4006 io_constraint (unformatted
,
4007 "the PAD= specifier at %L must be with an "
4008 "explicit format expression", &dt
->pad
->where
);
4014 if (!gfc_notify_std (GFC_STD_F2003
, "ROUND= at %C "
4015 "not allowed in Fortran 95"))
4018 if (!is_char_type ("ROUND", dt
->round
))
4021 if (dt
->round
->expr_type
== EXPR_CONSTANT
)
4023 static const char * round
[] = { "UP", "DOWN", "ZERO", "NEAREST",
4024 "COMPATIBLE", "PROCESSOR_DEFINED",
4027 if (!compare_to_allowed_values ("ROUND", round
, NULL
, NULL
,
4028 dt
->round
->value
.character
.string
,
4029 io_kind_name (k
), warn
))
4036 /* When implemented, change the following to use gfc_notify_std F2003.
4037 if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C "
4038 "not allowed in Fortran 95") == false)
4039 return MATCH_ERROR; */
4041 if (!is_char_type ("SIGN", dt
->sign
))
4044 if (dt
->sign
->expr_type
== EXPR_CONSTANT
)
4046 static const char * sign
[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
4049 if (!compare_to_allowed_values ("SIGN", sign
, NULL
, NULL
,
4050 dt
->sign
->value
.character
.string
,
4051 io_kind_name (k
), warn
))
4054 io_constraint (unformatted
,
4055 "SIGN= specifier at %L must be with an "
4056 "explicit format expression", &dt
->sign
->where
);
4058 io_constraint (k
== M_READ
,
4059 "SIGN= specifier at %L not allowed in a "
4060 "READ statement", &dt
->sign
->where
);
4066 if (!gfc_notify_std (GFC_STD_F2003
, "DELIM= at %C "
4067 "not allowed in Fortran 95"))
4070 if (!is_char_type ("DELIM", dt
->delim
))
4073 if (dt
->delim
->expr_type
== EXPR_CONSTANT
)
4075 static const char *delim
[] = { "APOSTROPHE", "QUOTE", "NONE", NULL
};
4077 if (!compare_to_allowed_values ("DELIM", delim
, NULL
, NULL
,
4078 dt
->delim
->value
.character
.string
,
4079 io_kind_name (k
), warn
))
4082 io_constraint (k
== M_READ
,
4083 "DELIM= specifier at %L not allowed in a "
4084 "READ statement", &dt
->delim
->where
);
4086 io_constraint (dt
->format_label
!= &format_asterisk
4087 && dt
->namelist
== NULL
,
4088 "DELIM= specifier at %L must have FMT=*",
4091 io_constraint (unformatted
&& dt
->namelist
== NULL
,
4092 "DELIM= specifier at %L must be with FMT=* or "
4093 "NML= specifier", &dt
->delim
->where
);
4099 io_constraint (io_code
&& dt
->namelist
,
4100 "NAMELIST cannot be followed by IO-list at %L",
4103 io_constraint (dt
->format_expr
,
4104 "IO spec-list cannot contain both NAMELIST group name "
4105 "and format specification at %L",
4106 &dt
->format_expr
->where
);
4108 io_constraint (dt
->format_label
,
4109 "IO spec-list cannot contain both NAMELIST group name "
4110 "and format label at %L", spec_end
);
4112 io_constraint (dt
->rec
,
4113 "NAMELIST IO is not allowed with a REC= specifier "
4114 "at %L", &dt
->rec
->where
);
4116 io_constraint (dt
->advance
,
4117 "NAMELIST IO is not allowed with a ADVANCE= specifier "
4118 "at %L", &dt
->advance
->where
);
4123 io_constraint (dt
->end
,
4124 "An END tag is not allowed with a "
4125 "REC= specifier at %L", &dt
->end_where
);
4127 io_constraint (dt
->format_label
== &format_asterisk
,
4128 "FMT=* is not allowed with a REC= specifier "
4131 io_constraint (dt
->pos
,
4132 "POS= is not allowed with REC= specifier "
4133 "at %L", &dt
->pos
->where
);
4138 int not_yes
, not_no
;
4141 io_constraint (dt
->format_label
== &format_asterisk
,
4142 "List directed format(*) is not allowed with a "
4143 "ADVANCE= specifier at %L.", &expr
->where
);
4145 io_constraint (unformatted
,
4146 "the ADVANCE= specifier at %L must appear with an "
4147 "explicit format expression", &expr
->where
);
4149 if (expr
->expr_type
== EXPR_CONSTANT
&& expr
->ts
.type
== BT_CHARACTER
)
4151 const gfc_char_t
*advance
= expr
->value
.character
.string
;
4152 not_no
= gfc_wide_strlen (advance
) != 2
4153 || gfc_wide_strncasecmp (advance
, "no", 2) != 0;
4154 not_yes
= gfc_wide_strlen (advance
) != 3
4155 || gfc_wide_strncasecmp (advance
, "yes", 3) != 0;
4163 io_constraint (not_no
&& not_yes
,
4164 "ADVANCE= specifier at %L must have value = "
4165 "YES or NO.", &expr
->where
);
4167 io_constraint (dt
->size
&& not_no
&& k
== M_READ
,
4168 "SIZE tag at %L requires an ADVANCE = %<NO%>",
4171 io_constraint (dt
->eor
&& not_no
&& k
== M_READ
,
4172 "EOR tag at %L requires an ADVANCE = %<NO%>",
4176 expr
= dt
->format_expr
;
4177 if (!gfc_simplify_expr (expr
, 0)
4178 || !check_format_string (expr
, k
== M_READ
))
4183 #undef io_constraint
4186 /* Match a READ, WRITE or PRINT statement. */
4189 match_io (io_kind k
)
4191 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4196 locus spec_end
, control
;
4200 where
= gfc_current_locus
;
4202 current_dt
= dt
= XCNEW (gfc_dt
);
4203 m
= gfc_match_char ('(');
4206 where
= gfc_current_locus
;
4209 else if (k
== M_PRINT
)
4211 /* Treat the non-standard case of PRINT namelist. */
4212 if ((gfc_current_form
== FORM_FIXED
|| gfc_peek_ascii_char () == ' ')
4213 && gfc_match_name (name
) == MATCH_YES
)
4215 gfc_find_symbol (name
, NULL
, 1, &sym
);
4216 if (sym
&& sym
->attr
.flavor
== FL_NAMELIST
)
4218 if (!gfc_notify_std (GFC_STD_GNU
, "PRINT namelist at "
4219 "%C is an extension"))
4225 dt
->io_unit
= default_unit (k
);
4230 gfc_current_locus
= where
;
4233 if (gfc_match_char ('*') == MATCH_YES
4234 && gfc_match_char(',') == MATCH_YES
)
4236 locus where2
= gfc_current_locus
;
4237 if (gfc_match_eos () == MATCH_YES
)
4239 gfc_current_locus
= where2
;
4240 gfc_error ("Comma after * at %C not allowed without I/O list");
4245 gfc_current_locus
= where
;
4248 gfc_current_locus
= where
;
4251 if (gfc_current_form
== FORM_FREE
)
4253 char c
= gfc_peek_ascii_char ();
4254 if (c
!= ' ' && c
!= '*' && c
!= '\'' && c
!= '"')
4261 m
= match_dt_format (dt
);
4262 if (m
== MATCH_ERROR
)
4268 dt
->io_unit
= default_unit (k
);
4273 /* Before issuing an error for a malformed 'print (1,*)' type of
4274 error, check for a default-char-expr of the form ('(I0)'). */
4277 control
= gfc_current_locus
;
4280 /* Reset current locus to get the initial '(' in an expression. */
4281 gfc_current_locus
= where
;
4282 dt
->format_expr
= NULL
;
4283 m
= match_dt_format (dt
);
4285 if (m
== MATCH_ERROR
)
4287 if (m
== MATCH_NO
|| dt
->format_expr
== NULL
)
4291 dt
->io_unit
= default_unit (k
);
4296 /* Commit any pending symbols now so that when we undo
4297 symbols later we wont lose them. */
4298 gfc_commit_symbols ();
4299 /* Reset current locus to get the initial '(' in an expression. */
4300 gfc_current_locus
= where
;
4301 dt
->format_expr
= NULL
;
4302 m
= gfc_match_expr (&dt
->format_expr
);
4306 && dt
->format_expr
->ts
.type
== BT_CHARACTER
)
4309 dt
->io_unit
= default_unit (k
);
4314 gfc_free_expr (dt
->format_expr
);
4315 dt
->format_expr
= NULL
;
4316 gfc_current_locus
= control
;
4322 gfc_undo_symbols ();
4323 gfc_free_expr (dt
->format_expr
);
4324 dt
->format_expr
= NULL
;
4325 gfc_current_locus
= control
;
4331 /* Match a control list */
4332 if (match_dt_element (k
, dt
) == MATCH_YES
)
4334 if (match_dt_unit (k
, dt
) != MATCH_YES
)
4337 if (gfc_match_char (')') == MATCH_YES
)
4339 if (gfc_match_char (',') != MATCH_YES
)
4342 m
= match_dt_element (k
, dt
);
4345 if (m
== MATCH_ERROR
)
4348 m
= match_dt_format (dt
);
4351 if (m
== MATCH_ERROR
)
4354 where
= gfc_current_locus
;
4356 m
= gfc_match_name (name
);
4359 gfc_find_symbol (name
, NULL
, 1, &sym
);
4360 if (sym
&& sym
->attr
.flavor
== FL_NAMELIST
)
4363 if (k
== M_READ
&& check_namelist (sym
))
4372 gfc_current_locus
= where
;
4374 goto loop
; /* No matches, try regular elements */
4377 if (gfc_match_char (')') == MATCH_YES
)
4379 if (gfc_match_char (',') != MATCH_YES
)
4385 m
= match_dt_element (k
, dt
);
4388 if (m
== MATCH_ERROR
)
4391 if (gfc_match_char (')') == MATCH_YES
)
4393 if (gfc_match_char (',') != MATCH_YES
)
4399 /* Used in check_io_constraints, where no locus is available. */
4400 spec_end
= gfc_current_locus
;
4402 /* Save the IO kind for later use. */
4403 dt
->dt_io_kind
= gfc_get_iokind_expr (&gfc_current_locus
, k
);
4405 /* Optional leading comma (non-standard). We use a gfc_expr structure here
4406 to save the locus. This is used later when resolving transfer statements
4407 that might have a format expression without unit number. */
4408 if (!comma_flag
&& gfc_match_char (',') == MATCH_YES
)
4409 dt
->extra_comma
= dt
->dt_io_kind
;
4412 if (gfc_match_eos () != MATCH_YES
)
4414 if (comma_flag
&& gfc_match_char (',') != MATCH_YES
)
4416 gfc_error ("Expected comma in I/O list at %C");
4421 m
= match_io_list (k
, &io_code
);
4422 if (m
== MATCH_ERROR
)
4428 /* See if we want to use defaults for missing exponents in real transfers
4429 and other DEC runtime extensions. */
4430 if (flag_dec_format_defaults
)
4433 /* A full IO statement has been matched. Check the constraints. spec_end is
4434 supplied for cases where no locus is supplied. */
4435 m
= check_io_constraints (k
, dt
, io_code
, &spec_end
);
4437 if (m
== MATCH_ERROR
)
4440 new_st
.op
= (k
== M_READ
) ? EXEC_READ
: EXEC_WRITE
;
4442 new_st
.block
= gfc_get_code (new_st
.op
);
4443 new_st
.block
->next
= io_code
;
4445 terminate_io (io_code
);
4450 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
4460 gfc_match_read (void)
4462 return match_io (M_READ
);
4467 gfc_match_write (void)
4469 return match_io (M_WRITE
);
4474 gfc_match_print (void)
4478 m
= match_io (M_PRINT
);
4482 if (gfc_pure (NULL
))
4484 gfc_error ("PRINT statement at %C not allowed within PURE procedure");
4488 gfc_unset_implicit_pure (NULL
);
4494 /* Free a gfc_inquire structure. */
4497 gfc_free_inquire (gfc_inquire
*inquire
)
4500 if (inquire
== NULL
)
4503 gfc_free_expr (inquire
->unit
);
4504 gfc_free_expr (inquire
->file
);
4505 gfc_free_expr (inquire
->iomsg
);
4506 gfc_free_expr (inquire
->iostat
);
4507 gfc_free_expr (inquire
->exist
);
4508 gfc_free_expr (inquire
->opened
);
4509 gfc_free_expr (inquire
->number
);
4510 gfc_free_expr (inquire
->named
);
4511 gfc_free_expr (inquire
->name
);
4512 gfc_free_expr (inquire
->access
);
4513 gfc_free_expr (inquire
->sequential
);
4514 gfc_free_expr (inquire
->direct
);
4515 gfc_free_expr (inquire
->form
);
4516 gfc_free_expr (inquire
->formatted
);
4517 gfc_free_expr (inquire
->unformatted
);
4518 gfc_free_expr (inquire
->recl
);
4519 gfc_free_expr (inquire
->nextrec
);
4520 gfc_free_expr (inquire
->blank
);
4521 gfc_free_expr (inquire
->position
);
4522 gfc_free_expr (inquire
->action
);
4523 gfc_free_expr (inquire
->read
);
4524 gfc_free_expr (inquire
->write
);
4525 gfc_free_expr (inquire
->readwrite
);
4526 gfc_free_expr (inquire
->delim
);
4527 gfc_free_expr (inquire
->encoding
);
4528 gfc_free_expr (inquire
->pad
);
4529 gfc_free_expr (inquire
->iolength
);
4530 gfc_free_expr (inquire
->convert
);
4531 gfc_free_expr (inquire
->strm_pos
);
4532 gfc_free_expr (inquire
->asynchronous
);
4533 gfc_free_expr (inquire
->decimal
);
4534 gfc_free_expr (inquire
->pending
);
4535 gfc_free_expr (inquire
->id
);
4536 gfc_free_expr (inquire
->sign
);
4537 gfc_free_expr (inquire
->size
);
4538 gfc_free_expr (inquire
->round
);
4539 gfc_free_expr (inquire
->share
);
4540 gfc_free_expr (inquire
->cc
);
4545 /* Match an element of an INQUIRE statement. */
4547 #define RETM if (m != MATCH_NO) return m;
4550 match_inquire_element (gfc_inquire
*inquire
)
4554 m
= match_etag (&tag_unit
, &inquire
->unit
);
4555 RETM m
= match_etag (&tag_file
, &inquire
->file
);
4556 RETM m
= match_ltag (&tag_err
, &inquire
->err
);
4557 RETM m
= match_etag (&tag_iomsg
, &inquire
->iomsg
);
4558 if (m
== MATCH_YES
&& !check_char_variable (inquire
->iomsg
))
4560 RETM m
= match_out_tag (&tag_iostat
, &inquire
->iostat
);
4561 RETM m
= match_vtag (&tag_exist
, &inquire
->exist
);
4562 RETM m
= match_vtag (&tag_opened
, &inquire
->opened
);
4563 RETM m
= match_vtag (&tag_named
, &inquire
->named
);
4564 RETM m
= match_vtag (&tag_name
, &inquire
->name
);
4565 RETM m
= match_out_tag (&tag_number
, &inquire
->number
);
4566 RETM m
= match_vtag (&tag_s_access
, &inquire
->access
);
4567 RETM m
= match_vtag (&tag_sequential
, &inquire
->sequential
);
4568 RETM m
= match_vtag (&tag_direct
, &inquire
->direct
);
4569 RETM m
= match_vtag (&tag_s_form
, &inquire
->form
);
4570 RETM m
= match_vtag (&tag_formatted
, &inquire
->formatted
);
4571 RETM m
= match_vtag (&tag_unformatted
, &inquire
->unformatted
);
4572 RETM m
= match_out_tag (&tag_s_recl
, &inquire
->recl
);
4573 RETM m
= match_out_tag (&tag_nextrec
, &inquire
->nextrec
);
4574 RETM m
= match_vtag (&tag_s_blank
, &inquire
->blank
);
4575 RETM m
= match_vtag (&tag_s_position
, &inquire
->position
);
4576 RETM m
= match_vtag (&tag_s_action
, &inquire
->action
);
4577 RETM m
= match_vtag (&tag_read
, &inquire
->read
);
4578 RETM m
= match_vtag (&tag_write
, &inquire
->write
);
4579 RETM m
= match_vtag (&tag_readwrite
, &inquire
->readwrite
);
4580 RETM m
= match_vtag (&tag_s_async
, &inquire
->asynchronous
);
4581 if (m
== MATCH_YES
&& !is_char_type ("ASYNCHRONOUS", inquire
->asynchronous
))
4583 RETM m
= match_vtag (&tag_s_delim
, &inquire
->delim
);
4584 RETM m
= match_vtag (&tag_s_decimal
, &inquire
->decimal
);
4585 RETM m
= match_out_tag (&tag_size
, &inquire
->size
);
4586 RETM m
= match_vtag (&tag_s_encoding
, &inquire
->encoding
);
4587 RETM m
= match_vtag (&tag_s_round
, &inquire
->round
);
4588 RETM m
= match_vtag (&tag_s_sign
, &inquire
->sign
);
4589 RETM m
= match_vtag (&tag_s_pad
, &inquire
->pad
);
4590 RETM m
= match_out_tag (&tag_iolength
, &inquire
->iolength
);
4591 RETM m
= match_vtag (&tag_convert
, &inquire
->convert
);
4592 RETM m
= match_out_tag (&tag_strm_out
, &inquire
->strm_pos
);
4593 RETM m
= match_vtag (&tag_pending
, &inquire
->pending
);
4594 RETM m
= match_vtag (&tag_id
, &inquire
->id
);
4595 RETM m
= match_vtag (&tag_s_iqstream
, &inquire
->iqstream
);
4596 RETM m
= match_dec_vtag (&tag_v_share
, &inquire
->share
);
4597 RETM m
= match_dec_vtag (&tag_v_cc
, &inquire
->cc
);
4598 RETM
return MATCH_NO
;
4605 gfc_match_inquire (void)
4607 gfc_inquire
*inquire
;
4612 m
= gfc_match_char ('(');
4616 inquire
= XCNEW (gfc_inquire
);
4618 loc
= gfc_current_locus
;
4620 m
= match_inquire_element (inquire
);
4621 if (m
== MATCH_ERROR
)
4625 m
= gfc_match_expr (&inquire
->unit
);
4626 if (m
== MATCH_ERROR
)
4632 /* See if we have the IOLENGTH form of the inquire statement. */
4633 if (inquire
->iolength
!= NULL
)
4635 if (gfc_match_char (')') != MATCH_YES
)
4638 m
= match_io_list (M_INQUIRE
, &code
);
4639 if (m
== MATCH_ERROR
)
4644 new_st
.op
= EXEC_IOLENGTH
;
4645 new_st
.expr1
= inquire
->iolength
;
4646 new_st
.ext
.inquire
= inquire
;
4648 if (gfc_pure (NULL
))
4650 gfc_free_statements (code
);
4651 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4655 gfc_unset_implicit_pure (NULL
);
4657 new_st
.block
= gfc_get_code (EXEC_IOLENGTH
);
4658 terminate_io (code
);
4659 new_st
.block
->next
= code
;
4663 /* At this point, we have the non-IOLENGTH inquire statement. */
4666 if (gfc_match_char (')') == MATCH_YES
)
4668 if (gfc_match_char (',') != MATCH_YES
)
4671 m
= match_inquire_element (inquire
);
4672 if (m
== MATCH_ERROR
)
4677 if (inquire
->iolength
!= NULL
)
4679 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
4684 if (gfc_match_eos () != MATCH_YES
)
4687 if (inquire
->unit
!= NULL
&& inquire
->file
!= NULL
)
4689 gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
4690 "UNIT specifiers", &loc
);
4694 if (inquire
->unit
== NULL
&& inquire
->file
== NULL
)
4696 gfc_error ("INQUIRE statement at %L requires either FILE or "
4697 "UNIT specifier", &loc
);
4701 if (inquire
->unit
!= NULL
&& inquire
->unit
->expr_type
== EXPR_CONSTANT
4702 && inquire
->unit
->ts
.type
== BT_INTEGER
4703 && ((mpz_get_si (inquire
->unit
->value
.integer
) == GFC_INTERNAL_UNIT4
)
4704 || (mpz_get_si (inquire
->unit
->value
.integer
) == GFC_INTERNAL_UNIT
)))
4706 gfc_error ("UNIT number in INQUIRE statement at %L cannot "
4707 "be %d", &loc
, (int) mpz_get_si (inquire
->unit
->value
.integer
));
4711 if (gfc_pure (NULL
))
4713 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4717 gfc_unset_implicit_pure (NULL
);
4719 if (inquire
->id
!= NULL
&& inquire
->pending
== NULL
)
4721 gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
4722 "the ID= specifier", &loc
);
4726 new_st
.op
= EXEC_INQUIRE
;
4727 new_st
.ext
.inquire
= inquire
;
4731 gfc_syntax_error (ST_INQUIRE
);
4734 gfc_free_inquire (inquire
);
4739 /* Resolve everything in a gfc_inquire structure. */
4742 gfc_resolve_inquire (gfc_inquire
*inquire
)
4744 RESOLVE_TAG (&tag_unit
, inquire
->unit
);
4745 RESOLVE_TAG (&tag_file
, inquire
->file
);
4746 RESOLVE_TAG (&tag_id
, inquire
->id
);
4748 /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4749 contexts. Thus, use an extended RESOLVE_TAG macro for that. */
4750 #define INQUIRE_RESOLVE_TAG(tag, expr) \
4751 RESOLVE_TAG (tag, expr); \
4755 sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
4756 if (gfc_check_vardef_context ((expr), false, false, false, \
4757 context) == false) \
4760 INQUIRE_RESOLVE_TAG (&tag_iomsg
, inquire
->iomsg
);
4761 INQUIRE_RESOLVE_TAG (&tag_iostat
, inquire
->iostat
);
4762 INQUIRE_RESOLVE_TAG (&tag_exist
, inquire
->exist
);
4763 INQUIRE_RESOLVE_TAG (&tag_opened
, inquire
->opened
);
4764 INQUIRE_RESOLVE_TAG (&tag_number
, inquire
->number
);
4765 INQUIRE_RESOLVE_TAG (&tag_named
, inquire
->named
);
4766 INQUIRE_RESOLVE_TAG (&tag_name
, inquire
->name
);
4767 INQUIRE_RESOLVE_TAG (&tag_s_access
, inquire
->access
);
4768 INQUIRE_RESOLVE_TAG (&tag_sequential
, inquire
->sequential
);
4769 INQUIRE_RESOLVE_TAG (&tag_direct
, inquire
->direct
);
4770 INQUIRE_RESOLVE_TAG (&tag_s_form
, inquire
->form
);
4771 INQUIRE_RESOLVE_TAG (&tag_formatted
, inquire
->formatted
);
4772 INQUIRE_RESOLVE_TAG (&tag_unformatted
, inquire
->unformatted
);
4773 INQUIRE_RESOLVE_TAG (&tag_s_recl
, inquire
->recl
);
4774 INQUIRE_RESOLVE_TAG (&tag_nextrec
, inquire
->nextrec
);
4775 INQUIRE_RESOLVE_TAG (&tag_s_blank
, inquire
->blank
);
4776 INQUIRE_RESOLVE_TAG (&tag_s_position
, inquire
->position
);
4777 INQUIRE_RESOLVE_TAG (&tag_s_action
, inquire
->action
);
4778 INQUIRE_RESOLVE_TAG (&tag_read
, inquire
->read
);
4779 INQUIRE_RESOLVE_TAG (&tag_write
, inquire
->write
);
4780 INQUIRE_RESOLVE_TAG (&tag_readwrite
, inquire
->readwrite
);
4781 INQUIRE_RESOLVE_TAG (&tag_s_delim
, inquire
->delim
);
4782 INQUIRE_RESOLVE_TAG (&tag_s_pad
, inquire
->pad
);
4783 INQUIRE_RESOLVE_TAG (&tag_s_encoding
, inquire
->encoding
);
4784 INQUIRE_RESOLVE_TAG (&tag_s_round
, inquire
->round
);
4785 INQUIRE_RESOLVE_TAG (&tag_iolength
, inquire
->iolength
);
4786 INQUIRE_RESOLVE_TAG (&tag_convert
, inquire
->convert
);
4787 INQUIRE_RESOLVE_TAG (&tag_strm_out
, inquire
->strm_pos
);
4788 INQUIRE_RESOLVE_TAG (&tag_s_async
, inquire
->asynchronous
);
4789 INQUIRE_RESOLVE_TAG (&tag_s_sign
, inquire
->sign
);
4790 INQUIRE_RESOLVE_TAG (&tag_s_round
, inquire
->round
);
4791 INQUIRE_RESOLVE_TAG (&tag_pending
, inquire
->pending
);
4792 INQUIRE_RESOLVE_TAG (&tag_size
, inquire
->size
);
4793 INQUIRE_RESOLVE_TAG (&tag_s_decimal
, inquire
->decimal
);
4794 INQUIRE_RESOLVE_TAG (&tag_s_iqstream
, inquire
->iqstream
);
4795 INQUIRE_RESOLVE_TAG (&tag_v_share
, inquire
->share
);
4796 INQUIRE_RESOLVE_TAG (&tag_v_cc
, inquire
->cc
);
4797 #undef INQUIRE_RESOLVE_TAG
4799 if (!gfc_reference_st_label (inquire
->err
, ST_LABEL_TARGET
))
4807 gfc_free_wait (gfc_wait
*wait
)
4812 gfc_free_expr (wait
->unit
);
4813 gfc_free_expr (wait
->iostat
);
4814 gfc_free_expr (wait
->iomsg
);
4815 gfc_free_expr (wait
->id
);
4821 gfc_resolve_wait (gfc_wait
*wait
)
4823 RESOLVE_TAG (&tag_unit
, wait
->unit
);
4824 RESOLVE_TAG (&tag_iomsg
, wait
->iomsg
);
4825 RESOLVE_TAG (&tag_iostat
, wait
->iostat
);
4826 RESOLVE_TAG (&tag_id
, wait
->id
);
4828 if (!gfc_reference_st_label (wait
->err
, ST_LABEL_TARGET
))
4831 if (!gfc_reference_st_label (wait
->end
, ST_LABEL_TARGET
))
4837 /* Match an element of a WAIT statement. */
4839 #define RETM if (m != MATCH_NO) return m;
4842 match_wait_element (gfc_wait
*wait
)
4846 m
= match_etag (&tag_unit
, &wait
->unit
);
4847 RETM m
= match_ltag (&tag_err
, &wait
->err
);
4848 RETM m
= match_ltag (&tag_end
, &wait
->end
);
4849 RETM m
= match_ltag (&tag_eor
, &wait
->eor
);
4850 RETM m
= match_etag (&tag_iomsg
, &wait
->iomsg
);
4851 if (m
== MATCH_YES
&& !check_char_variable (wait
->iomsg
))
4853 RETM m
= match_out_tag (&tag_iostat
, &wait
->iostat
);
4854 RETM m
= match_etag (&tag_id
, &wait
->id
);
4855 RETM
return MATCH_NO
;
4862 gfc_match_wait (void)
4867 m
= gfc_match_char ('(');
4871 wait
= XCNEW (gfc_wait
);
4873 m
= match_wait_element (wait
);
4874 if (m
== MATCH_ERROR
)
4878 m
= gfc_match_expr (&wait
->unit
);
4879 if (m
== MATCH_ERROR
)
4887 if (gfc_match_char (')') == MATCH_YES
)
4889 if (gfc_match_char (',') != MATCH_YES
)
4892 m
= match_wait_element (wait
);
4893 if (m
== MATCH_ERROR
)
4899 if (!gfc_notify_std (GFC_STD_F2003
, "WAIT at %C "
4900 "not allowed in Fortran 95"))
4903 if (gfc_pure (NULL
))
4905 gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4909 gfc_unset_implicit_pure (NULL
);
4911 new_st
.op
= EXEC_WAIT
;
4912 new_st
.ext
.wait
= wait
;
4917 gfc_syntax_error (ST_WAIT
);
4920 gfc_free_wait (wait
);