1 /* Deal with I/O statements & related stuff.
2 Copyright (C) 2000-2022 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 /**************** Fortran 95 FORMAT parser *****************/
117 /* FORMAT tokens returned by format_lex(). */
120 FMT_NONE
, FMT_UNKNOWN
, FMT_SIGNED_INT
, FMT_ZERO
, FMT_POSINT
, FMT_PERIOD
,
121 FMT_COMMA
, FMT_COLON
, FMT_SLASH
, FMT_DOLLAR
, FMT_LPAREN
,
122 FMT_RPAREN
, FMT_X
, FMT_SIGN
, FMT_BLANK
, FMT_CHAR
, FMT_P
, FMT_IBOZ
, FMT_F
,
123 FMT_E
, FMT_EN
, FMT_ES
, FMT_G
, FMT_L
, FMT_A
, FMT_D
, FMT_H
, FMT_END
,
124 FMT_ERROR
, FMT_DC
, FMT_DP
, FMT_T
, FMT_TR
, FMT_TL
, FMT_STAR
, FMT_RC
,
125 FMT_RD
, FMT_RN
, FMT_RP
, FMT_RU
, FMT_RZ
, FMT_DT
128 /* Local variables for checking format strings. The saved_token is
129 used to back up by a single format token during the parsing
131 static gfc_char_t
*format_string
;
132 static int format_string_pos
;
133 static int format_length
, use_last_char
;
134 static char error_element
;
135 static locus format_locus
;
137 static format_token saved_token
;
140 { MODE_STRING
, MODE_FORMAT
, MODE_COPY
}
144 /* Return the next character in the format string. */
147 next_char (gfc_instring in_string
)
159 if (mode
== MODE_STRING
)
160 c
= *format_string
++;
163 c
= gfc_next_char_literal (in_string
);
168 if (flag_backslash
&& c
== '\\')
170 locus old_locus
= gfc_current_locus
;
172 if (gfc_match_special_char (&c
) == MATCH_NO
)
173 gfc_current_locus
= old_locus
;
175 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
176 gfc_warning (0, "Extension: backslash character at %C");
179 if (mode
== MODE_COPY
)
180 *format_string
++ = c
;
182 if (mode
!= MODE_STRING
)
183 format_locus
= gfc_current_locus
;
187 c
= gfc_wide_toupper (c
);
192 /* Back up one character position. Only works once. */
200 /* Eat up the spaces and return a character. */
203 next_char_not_space ()
208 error_element
= c
= next_char (NONSTRING
);
210 gfc_warning (OPT_Wtabs
, "Nonconforming tab character in format at %C");
212 while (gfc_is_whitespace (c
));
216 static int value
= 0;
218 /* Simple lexical analyzer for getting the next token in a FORMAT
229 if (saved_token
!= FMT_NONE
)
232 saved_token
= FMT_NONE
;
236 c
= next_char_not_space ();
246 c
= next_char_not_space ();
257 c
= next_char_not_space ();
259 value
= 10 * value
+ c
- '0';
268 token
= FMT_SIGNED_INT
;
287 c
= next_char_not_space ();
290 value
= 10 * value
+ c
- '0';
298 token
= zflag
? FMT_ZERO
: FMT_POSINT
;
322 c
= next_char_not_space ();
350 c
= next_char_not_space ();
351 if (c
!= 'P' && c
!= 'S')
358 c
= next_char_not_space ();
359 if (c
== 'N' || c
== 'Z')
377 c
= next_char (INSTRING_WARN
);
386 c
= next_char (NONSTRING
);
420 c
= next_char_not_space ();
450 c
= next_char_not_space ();
453 if (!gfc_notify_std (GFC_STD_F2003
, "DP format "
454 "specifier not allowed at %C"))
460 if (!gfc_notify_std (GFC_STD_F2003
, "DC format "
461 "specifier not allowed at %C"))
467 if (!gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: DT format "
468 "specifier not allowed at %C"))
471 c
= next_char_not_space ();
472 if (c
== '\'' || c
== '"')
479 c
= next_char (INSTRING_WARN
);
488 c
= next_char (NONSTRING
);
522 c
= next_char_not_space ();
568 token_to_string (format_token t
)
587 /* Check a format statement. The format string, either from a FORMAT
588 statement or a constant in an I/O statement has already been parsed
589 by itself, and we are checking it for validity. The dual origin
590 means that the warning message is a little less than great. */
593 check_format (bool is_input
)
595 const char *posint_required
596 = G_("Positive width required in format string at %L");
597 const char *nonneg_required
598 = G_("Nonnegative width required in format string at %L");
599 const char *unexpected_element
600 = G_("Unexpected element %qc in format string at %L");
601 const char *unexpected_end
602 = G_("Unexpected end of format string in format string at %L");
603 const char *zero_width
604 = G_("Zero width in format descriptor in format string at %L");
606 const char *error
= NULL
;
613 saved_token
= FMT_NONE
;
617 format_string_pos
= 0;
624 error
= G_("Missing leading left parenthesis in format string at %L");
632 goto finished
; /* Empty format is legal */
636 /* In this state, the next thing has to be a format item. */
653 error
= G_("Left parenthesis required after %<*%> in format string "
679 /* Signed integer can only precede a P format. */
685 error
= G_("Expected P edit descriptor in format string at %L");
692 /* P requires a prior number. */
693 error
= G_("P descriptor requires leading scale factor in format "
698 /* X requires a prior number if we're being pedantic. */
699 if (mode
!= MODE_FORMAT
)
700 format_locus
.nextc
+= format_string_pos
;
701 if (!gfc_notify_std (GFC_STD_GNU
, "X descriptor requires leading "
702 "space count at %L", &format_locus
))
719 goto extension_optional_comma
;
730 if (!gfc_notify_std (GFC_STD_GNU
, "$ descriptor at %L", &format_locus
))
732 if (t
!= FMT_RPAREN
|| level
> 0)
734 gfc_warning (0, "$ should be the last specifier in format at %L",
736 goto optional_comma_1
;
758 error
= unexpected_end
;
762 if (flag_dec_blank_format_item
)
766 error
= G_("Missing item in format string at %L");
771 error
= unexpected_element
;
776 /* In this state, t must currently be a data descriptor.
777 Deal with things that can/must follow the descriptor. */
788 /* No comma after P allowed only for F, E, EN, ES, D, or G.
793 if (!(gfc_option
.allow_std
& GFC_STD_F2003
) && t
!= FMT_COMMA
794 && t
!= FMT_F
&& t
!= FMT_E
&& t
!= FMT_EN
&& t
!= FMT_ES
795 && t
!= FMT_D
&& t
!= FMT_G
&& t
!= FMT_RPAREN
&& t
!= FMT_SLASH
)
797 error
= G_("Comma required after P descriptor in format string "
809 if (t
!= FMT_F
&& t
!= FMT_E
&& t
!= FMT_EN
&& t
!= FMT_ES
810 && t
!= FMT_D
&& t
!= FMT_G
&& t
!= FMT_RPAREN
&& t
!= FMT_SLASH
)
812 error
= G_("Comma required after P descriptor in format string "
827 error
= G_("Positive width required with T descriptor in format "
839 if (mode
!= MODE_FORMAT
)
840 format_locus
.nextc
+= format_string_pos
;
843 switch (gfc_notification_std (GFC_STD_GNU
))
846 gfc_warning (0, "Extension: Zero width after L "
847 "descriptor at %L", &format_locus
);
850 gfc_error ("Extension: Zero width after L "
851 "descriptor at %L", &format_locus
);
862 gfc_notify_std (GFC_STD_GNU
, "Missing positive width after "
863 "L descriptor at %L", &format_locus
);
886 if (t
== FMT_G
&& u
== FMT_ZERO
)
893 if (!gfc_notify_std (GFC_STD_F2008
, "%<G0%> in format at %L",
905 error
= posint_required
;
911 error
= G_("E specifier not allowed with g0 descriptor in "
912 "format string at %L");
923 if (flag_dec_format_defaults
)
925 /* Assume a default width based on the variable size. */
931 gfc_error ("Positive width required in format "
932 "specifier %s at %L", token_to_string (t
),
939 format_locus
.nextc
+= format_string_pos
;
940 if (!gfc_notify_std (GFC_STD_F2018
,
941 "positive width required at %L",
947 if (flag_dec_format_defaults
)
949 /* Assume a default width based on the variable size. */
960 /* Warn if -std=legacy, otherwise error. */
961 format_locus
.nextc
+= format_string_pos
;
962 if (gfc_option
.warn_std
!= 0)
964 gfc_error ("Period required in format "
965 "specifier %s at %L", token_to_string (t
),
971 gfc_warning (0, "Period required in format "
972 "specifier %s at %L", token_to_string (t
),
974 /* If we go to finished, we need to unwind this
975 before the next round. */
976 format_locus
.nextc
-= format_string_pos
;
984 if (u
!= FMT_ZERO
&& u
!= FMT_POSINT
)
986 error
= nonneg_required
;
993 /* Look for optional exponent. */
1004 if (u
!= FMT_POSINT
)
1008 if (!gfc_notify_std (GFC_STD_F2018
,
1009 "Positive exponent width required in "
1010 "format string at %L", &format_locus
))
1018 error
= G_("Positive exponent width required in format "
1052 if (t
!= FMT_POSINT
)
1054 error
= posint_required
;
1064 if (t
!= FMT_RPAREN
)
1066 error
= G_("Right parenthesis expected at %C in format string "
1073 error
= unexpected_element
;
1082 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
1084 if (flag_dec_format_defaults
)
1086 /* Assume the default width is expected here and continue lexing. */
1087 value
= 0; /* It doesn't matter what we set the value to here. */
1091 error
= nonneg_required
;
1094 else if (is_input
&& t
== FMT_ZERO
)
1096 error
= posint_required
;
1103 if (t
!= FMT_PERIOD
)
1105 /* Warn if -std=legacy, otherwise error. */
1106 if (gfc_option
.warn_std
!= 0)
1108 error
= G_("Period required in format specifier in format "
1112 if (mode
!= MODE_FORMAT
)
1113 format_locus
.nextc
+= format_string_pos
;
1114 gfc_warning (0, "Period required in format specifier at %L",
1123 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
1125 error
= nonneg_required
;
1132 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
1134 if (mode
!= MODE_FORMAT
)
1135 format_locus
.nextc
+= format_string_pos
;
1136 gfc_warning (0, "The H format specifier at %L is"
1137 " a Fortran 95 deleted feature", &format_locus
);
1139 if (mode
== MODE_STRING
)
1141 format_string
+= value
;
1142 format_length
-= value
;
1143 format_string_pos
+= repeat
;
1149 next_char (INSTRING_WARN
);
1159 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
1161 if (flag_dec_format_defaults
)
1163 /* Assume the default width is expected here and continue lexing. */
1164 value
= 0; /* It doesn't matter what we set the value to here. */
1169 error
= nonneg_required
;
1173 else if (is_input
&& t
== FMT_ZERO
)
1175 error
= posint_required
;
1182 if (t
!= FMT_PERIOD
)
1189 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
1191 error
= nonneg_required
;
1199 error
= unexpected_element
;
1204 /* Between a descriptor and what comes next. */
1222 goto optional_comma
;
1225 error
= unexpected_end
;
1229 if (mode
!= MODE_FORMAT
)
1230 format_locus
.nextc
+= format_string_pos
- 1;
1231 if (!gfc_notify_std (GFC_STD_GNU
, "Missing comma at %L", &format_locus
))
1233 /* If we do not actually return a failure, we need to unwind this
1234 before the next round. */
1235 if (mode
!= MODE_FORMAT
)
1236 format_locus
.nextc
-= format_string_pos
;
1241 /* Optional comma is a weird between state where we've just finished
1242 reading a colon, slash, dollar or P descriptor. */
1259 /* Assume that we have another format item. */
1266 extension_optional_comma
:
1267 /* As a GNU extension, permit a missing comma after a string literal. */
1284 goto optional_comma
;
1287 error
= unexpected_end
;
1291 if (mode
!= MODE_FORMAT
)
1292 format_locus
.nextc
+= format_string_pos
;
1293 if (!gfc_notify_std (GFC_STD_GNU
, "Missing comma at %L", &format_locus
))
1295 /* If we do not actually return a failure, we need to unwind this
1296 before the next round. */
1297 if (mode
!= MODE_FORMAT
)
1298 format_locus
.nextc
-= format_string_pos
;
1306 if (mode
!= MODE_FORMAT
)
1307 format_locus
.nextc
+= format_string_pos
;
1308 if (error
== unexpected_element
)
1309 gfc_error (error
, error_element
, &format_locus
);
1311 gfc_error (error
, &format_locus
);
1320 /* Given an expression node that is a constant string, see if it looks
1321 like a format string. */
1324 check_format_string (gfc_expr
*e
, bool is_input
)
1328 if (!e
|| e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1332 format_string
= e
->value
.character
.string
;
1334 /* More elaborate measures are needed to show where a problem is within a
1335 format string that has been calculated, but that's probably not worth the
1337 format_locus
= e
->where
;
1338 rv
= check_format (is_input
);
1339 /* check for extraneous characters at the end of an otherwise valid format
1340 string, like '(A10,I3)F5'
1341 start at the end and move back to the last character processed,
1343 if (rv
&& e
->value
.character
.length
> format_string_pos
)
1344 for (i
=e
->value
.character
.length
-1;i
>format_string_pos
-1;i
--)
1345 if (e
->value
.character
.string
[i
] != ' ')
1347 format_locus
.nextc
+= format_length
+ 1;
1349 "Extraneous characters in format at %L", &format_locus
);
1356 /************ Fortran I/O statement matchers *************/
1358 /* Match a FORMAT statement. This amounts to actually parsing the
1359 format descriptors in order to correctly locate the end of the
1363 gfc_match_format (void)
1368 if (gfc_current_ns
->proc_name
1369 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1371 gfc_error ("Format statement in module main block at %C");
1375 /* Before parsing the rest of a FORMAT statement, check F2008:c1206. */
1376 if ((gfc_current_state () == COMP_FUNCTION
1377 || gfc_current_state () == COMP_SUBROUTINE
)
1378 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
1380 gfc_error ("FORMAT statement at %C cannot appear within an INTERFACE");
1384 if (gfc_statement_label
== NULL
)
1386 gfc_error ("Missing format label at %C");
1389 gfc_gobble_whitespace ();
1394 start
= gfc_current_locus
;
1396 if (!check_format (false))
1399 if (gfc_match_eos () != MATCH_YES
)
1401 gfc_syntax_error (ST_FORMAT
);
1405 /* The label doesn't get created until after the statement is done
1406 being matched, so we have to leave the string for later. */
1408 gfc_current_locus
= start
; /* Back to the beginning */
1411 new_st
.op
= EXEC_NOP
;
1413 e
= gfc_get_character_expr (gfc_default_character_kind
, &start
,
1414 NULL
, format_length
);
1415 format_string
= e
->value
.character
.string
;
1416 gfc_statement_label
->format
= e
;
1419 check_format (false); /* Guaranteed to succeed */
1420 gfc_match_eos (); /* Guaranteed to succeed */
1426 /* Match an expression I/O tag of some sort. */
1429 match_etag (const io_tag
*tag
, gfc_expr
**v
)
1434 m
= gfc_match (tag
->spec
);
1438 m
= gfc_match (tag
->value
, &result
);
1441 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1447 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1448 gfc_free_expr (result
);
1457 /* Match a variable I/O tag of some sort. */
1460 match_vtag (const io_tag
*tag
, gfc_expr
**v
)
1465 m
= gfc_match (tag
->spec
);
1469 m
= gfc_match (tag
->value
, &result
);
1472 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1478 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1479 gfc_free_expr (result
);
1483 if (result
->symtree
)
1487 if (result
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1489 gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag
->name
);
1490 gfc_free_expr (result
);
1494 impure
= gfc_impure_variable (result
->symtree
->n
.sym
);
1495 if (impure
&& gfc_pure (NULL
))
1497 gfc_error ("Variable %s cannot be assigned in PURE procedure at %C",
1499 gfc_free_expr (result
);
1504 gfc_unset_implicit_pure (NULL
);
1512 /* Match I/O tags that cause variables to become redefined. */
1515 match_out_tag (const io_tag
*tag
, gfc_expr
**result
)
1519 m
= match_vtag (tag
, result
);
1522 if ((*result
)->symtree
)
1523 gfc_check_do_variable ((*result
)->symtree
);
1525 if ((*result
)->expr_type
== EXPR_CONSTANT
)
1527 gfc_error ("Expecting a variable at %L", &(*result
)->where
);
1536 /* Match a label I/O tag. */
1539 match_ltag (const io_tag
*tag
, gfc_st_label
** label
)
1545 m
= gfc_match (tag
->spec
);
1549 m
= gfc_match (tag
->value
, label
);
1552 gfc_error ("Invalid value for %s specification at %C", tag
->name
);
1558 gfc_error ("Duplicate %s label specification at %C", tag
->name
);
1562 if (!gfc_reference_st_label (*label
, ST_LABEL_TARGET
))
1569 /* Match a tag using match_etag, but only if -fdec is enabled. */
1571 match_dec_etag (const io_tag
*tag
, gfc_expr
**e
)
1573 match m
= match_etag (tag
, e
);
1574 if (flag_dec
&& m
!= MATCH_NO
)
1576 else if (m
!= MATCH_NO
)
1578 gfc_error ("%s at %C is a DEC extension, enable with "
1579 "%<-fdec%>", tag
->name
);
1586 /* Match a tag using match_vtag, but only if -fdec is enabled. */
1588 match_dec_vtag (const io_tag
*tag
, gfc_expr
**e
)
1590 match m
= match_vtag(tag
, e
);
1591 if (flag_dec
&& m
!= MATCH_NO
)
1593 else if (m
!= MATCH_NO
)
1595 gfc_error ("%s at %C is a DEC extension, enable with "
1596 "%<-fdec%>", tag
->name
);
1603 /* Match a DEC I/O flag tag - a tag with no expression such as READONLY. */
1606 match_dec_ftag (const io_tag
*tag
, gfc_open
*o
)
1610 m
= gfc_match (tag
->spec
);
1616 gfc_error ("%s at %C is a DEC extension, enable with "
1617 "%<-fdec%>", tag
->name
);
1621 /* Just set the READONLY flag, which we use at runtime to avoid delete on
1623 if (tag
== &tag_readonly
)
1629 /* Interpret SHARED as SHARE='DENYNONE' (read lock). */
1630 else if (tag
== &tag_shared
)
1632 if (o
->share
!= NULL
)
1634 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1637 o
->share
= gfc_get_character_expr (gfc_default_character_kind
,
1638 &gfc_current_locus
, "denynone", 8);
1642 /* Interpret NOSHARED as SHARE='DENYRW' (exclusive lock). */
1643 else if (tag
== &tag_noshared
)
1645 if (o
->share
!= NULL
)
1647 gfc_error ("Duplicate %s specification at %C", tag
->name
);
1650 o
->share
= gfc_get_character_expr (gfc_default_character_kind
,
1651 &gfc_current_locus
, "denyrw", 6);
1655 /* We handle all DEC tags above. */
1660 /* Resolution of the FORMAT tag, to be called from resolve_tag. */
1663 resolve_tag_format (gfc_expr
*e
)
1665 if (e
->expr_type
== EXPR_CONSTANT
1666 && (e
->ts
.type
!= BT_CHARACTER
1667 || e
->ts
.kind
!= gfc_default_character_kind
))
1669 gfc_error ("Constant expression in FORMAT tag at %L must be "
1670 "of type default CHARACTER", &e
->where
);
1674 /* Concatenate a constant character array into a single character
1677 if ((e
->expr_type
== EXPR_ARRAY
|| e
->rank
> 0)
1678 && e
->ts
.type
== BT_CHARACTER
1679 && gfc_is_constant_expr (e
))
1681 if (e
->expr_type
== EXPR_VARIABLE
1682 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1683 gfc_simplify_expr (e
, 1);
1685 if (e
->expr_type
== EXPR_ARRAY
)
1688 gfc_charlen_t n
, len
;
1690 gfc_char_t
*dest
, *src
;
1692 if (e
->value
.constructor
== NULL
)
1694 gfc_error ("FORMAT tag at %L cannot be a zero-sized array",
1700 c
= gfc_constructor_first (e
->value
.constructor
);
1701 len
= c
->expr
->value
.character
.length
;
1703 for ( ; c
; c
= gfc_constructor_next (c
))
1706 r
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, n
);
1707 dest
= r
->value
.character
.string
;
1709 for (c
= gfc_constructor_first (e
->value
.constructor
);
1710 c
; c
= gfc_constructor_next (c
))
1712 src
= c
->expr
->value
.character
.string
;
1713 for (gfc_charlen_t i
= 0 ; i
< len
; i
++)
1717 gfc_replace_expr (e
, r
);
1722 /* If e's rank is zero and e is not an element of an array, it should be
1723 of integer or character type. The integer variable should be
1726 && (e
->expr_type
!= EXPR_VARIABLE
1727 || e
->symtree
== NULL
1728 || e
->symtree
->n
.sym
->as
== NULL
1729 || e
->symtree
->n
.sym
->as
->rank
== 0))
1731 if ((e
->ts
.type
!= BT_CHARACTER
1732 || e
->ts
.kind
!= gfc_default_character_kind
)
1733 && e
->ts
.type
!= BT_INTEGER
)
1735 gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER "
1736 "or of INTEGER", &e
->where
);
1739 else if (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_VARIABLE
)
1741 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGNED variable in "
1742 "FORMAT tag at %L", &e
->where
))
1744 if (e
->symtree
->n
.sym
->attr
.assign
!= 1)
1746 gfc_error ("Variable %qs at %L has not been assigned a "
1747 "format label", e
->symtree
->n
.sym
->name
, &e
->where
);
1751 else if (e
->ts
.type
== BT_INTEGER
)
1753 gfc_error ("Scalar %qs in FORMAT tag at %L is not an ASSIGNED "
1754 "variable", gfc_basic_typename (e
->ts
.type
), &e
->where
);
1761 /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
1762 It may be assigned an Hollerith constant. */
1763 if (e
->ts
.type
!= BT_CHARACTER
)
1765 if (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
1766 || e
->ts
.type
== BT_VOID
|| e
->ts
.type
== BT_UNKNOWN
)
1768 gfc_error ("Non-character non-Hollerith in FORMAT tag at %L",
1772 if (!gfc_notify_std (GFC_STD_LEGACY
, "Non-character in FORMAT tag "
1773 "at %L", &e
->where
))
1776 if (e
->rank
== 0 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
)
1778 gfc_error ("Non-character assumed shape array element in FORMAT"
1779 " tag at %L", &e
->where
);
1783 if (e
->rank
== 0 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
)
1785 gfc_error ("Non-character assumed size array element in FORMAT"
1786 " tag at %L", &e
->where
);
1790 if (e
->rank
== 0 && e
->symtree
->n
.sym
->attr
.pointer
)
1792 gfc_error ("Non-character pointer array element in FORMAT tag at %L",
1802 /* Do expression resolution and type-checking on an expression tag. */
1805 resolve_tag (const io_tag
*tag
, gfc_expr
*e
)
1810 if (!gfc_resolve_expr (e
))
1813 if (tag
== &tag_format
)
1814 return resolve_tag_format (e
);
1816 if (e
->ts
.type
!= tag
->type
)
1818 gfc_error ("%s tag at %L must be of type %s", tag
->name
,
1819 &e
->where
, gfc_basic_typename (tag
->type
));
1823 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= gfc_default_character_kind
)
1825 gfc_error ("%s tag at %L must be a character string of default kind",
1826 tag
->name
, &e
->where
);
1832 gfc_error ("%s tag at %L must be scalar", tag
->name
, &e
->where
);
1836 if (tag
== &tag_iomsg
)
1838 if (!gfc_notify_std (GFC_STD_F2003
, "IOMSG tag at %L", &e
->where
))
1842 if ((tag
== &tag_iostat
|| tag
== &tag_size
|| tag
== &tag_iolength
1843 || tag
== &tag_number
|| tag
== &tag_nextrec
|| tag
== &tag_s_recl
)
1844 && e
->ts
.kind
!= gfc_default_integer_kind
)
1846 if (!gfc_notify_std (GFC_STD_F2003
, "Fortran 95 requires default "
1847 "INTEGER in %s tag at %L", tag
->name
, &e
->where
))
1851 if (e
->ts
.kind
!= gfc_default_logical_kind
&&
1852 (tag
== &tag_exist
|| tag
== &tag_named
|| tag
== &tag_opened
1853 || tag
== &tag_pending
))
1855 if (!gfc_notify_std (GFC_STD_F2008
, "Non-default LOGICAL kind "
1856 "in %s tag at %L", tag
->name
, &e
->where
))
1860 if (tag
== &tag_newunit
)
1862 if (!gfc_notify_std (GFC_STD_F2008
, "NEWUNIT specifier at %L",
1867 /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */
1868 if (tag
== &tag_newunit
|| tag
== &tag_iostat
1869 || tag
== &tag_size
|| tag
== &tag_iomsg
)
1873 sprintf (context
, _("%s tag"), tag
->name
);
1874 if (!gfc_check_vardef_context (e
, false, false, false, context
))
1878 if (tag
== &tag_convert
)
1880 if (!gfc_notify_std (GFC_STD_GNU
, "CONVERT tag at %L", &e
->where
))
1888 /* Match a single tag of an OPEN statement. */
1891 match_open_element (gfc_open
*open
)
1895 m
= match_etag (&tag_e_async
, &open
->asynchronous
);
1898 m
= match_etag (&tag_unit
, &open
->unit
);
1901 m
= match_etag (&tag_iomsg
, &open
->iomsg
);
1904 m
= match_out_tag (&tag_iostat
, &open
->iostat
);
1907 m
= match_etag (&tag_file
, &open
->file
);
1910 m
= match_etag (&tag_status
, &open
->status
);
1913 m
= match_etag (&tag_e_access
, &open
->access
);
1916 m
= match_etag (&tag_e_form
, &open
->form
);
1919 m
= match_etag (&tag_e_recl
, &open
->recl
);
1922 m
= match_etag (&tag_e_blank
, &open
->blank
);
1925 m
= match_etag (&tag_e_position
, &open
->position
);
1928 m
= match_etag (&tag_e_action
, &open
->action
);
1931 m
= match_etag (&tag_e_delim
, &open
->delim
);
1934 m
= match_etag (&tag_e_pad
, &open
->pad
);
1937 m
= match_etag (&tag_e_decimal
, &open
->decimal
);
1940 m
= match_etag (&tag_e_encoding
, &open
->encoding
);
1943 m
= match_etag (&tag_e_round
, &open
->round
);
1946 m
= match_etag (&tag_e_sign
, &open
->sign
);
1949 m
= match_ltag (&tag_err
, &open
->err
);
1952 m
= match_etag (&tag_convert
, &open
->convert
);
1955 m
= match_out_tag (&tag_newunit
, &open
->newunit
);
1959 /* The following are extensions enabled with -fdec. */
1960 m
= match_dec_etag (&tag_e_share
, &open
->share
);
1963 m
= match_dec_etag (&tag_cc
, &open
->cc
);
1966 m
= match_dec_ftag (&tag_readonly
, open
);
1969 m
= match_dec_ftag (&tag_shared
, open
);
1972 m
= match_dec_ftag (&tag_noshared
, open
);
1980 /* Free the gfc_open structure and all the expressions it contains. */
1983 gfc_free_open (gfc_open
*open
)
1988 gfc_free_expr (open
->unit
);
1989 gfc_free_expr (open
->iomsg
);
1990 gfc_free_expr (open
->iostat
);
1991 gfc_free_expr (open
->file
);
1992 gfc_free_expr (open
->status
);
1993 gfc_free_expr (open
->access
);
1994 gfc_free_expr (open
->form
);
1995 gfc_free_expr (open
->recl
);
1996 gfc_free_expr (open
->blank
);
1997 gfc_free_expr (open
->position
);
1998 gfc_free_expr (open
->action
);
1999 gfc_free_expr (open
->delim
);
2000 gfc_free_expr (open
->pad
);
2001 gfc_free_expr (open
->decimal
);
2002 gfc_free_expr (open
->encoding
);
2003 gfc_free_expr (open
->round
);
2004 gfc_free_expr (open
->sign
);
2005 gfc_free_expr (open
->convert
);
2006 gfc_free_expr (open
->asynchronous
);
2007 gfc_free_expr (open
->newunit
);
2008 gfc_free_expr (open
->share
);
2009 gfc_free_expr (open
->cc
);
2015 compare_to_allowed_values (const char *specifier
, const char *allowed
[],
2016 const char *allowed_f2003
[],
2017 const char *allowed_gnu
[], gfc_char_t
*value
,
2018 const char *statement
, bool warn
, locus
*where
,
2023 check_open_constraints (gfc_open
*open
, locus
*where
);
2025 /* Resolve everything in a gfc_open structure. */
2028 gfc_resolve_open (gfc_open
*open
, locus
*where
)
2030 RESOLVE_TAG (&tag_unit
, open
->unit
);
2031 RESOLVE_TAG (&tag_iomsg
, open
->iomsg
);
2032 RESOLVE_TAG (&tag_iostat
, open
->iostat
);
2033 RESOLVE_TAG (&tag_file
, open
->file
);
2034 RESOLVE_TAG (&tag_status
, open
->status
);
2035 RESOLVE_TAG (&tag_e_access
, open
->access
);
2036 RESOLVE_TAG (&tag_e_form
, open
->form
);
2037 RESOLVE_TAG (&tag_e_recl
, open
->recl
);
2038 RESOLVE_TAG (&tag_e_blank
, open
->blank
);
2039 RESOLVE_TAG (&tag_e_position
, open
->position
);
2040 RESOLVE_TAG (&tag_e_action
, open
->action
);
2041 RESOLVE_TAG (&tag_e_delim
, open
->delim
);
2042 RESOLVE_TAG (&tag_e_pad
, open
->pad
);
2043 RESOLVE_TAG (&tag_e_decimal
, open
->decimal
);
2044 RESOLVE_TAG (&tag_e_encoding
, open
->encoding
);
2045 RESOLVE_TAG (&tag_e_async
, open
->asynchronous
);
2046 RESOLVE_TAG (&tag_e_round
, open
->round
);
2047 RESOLVE_TAG (&tag_e_sign
, open
->sign
);
2048 RESOLVE_TAG (&tag_convert
, open
->convert
);
2049 RESOLVE_TAG (&tag_newunit
, open
->newunit
);
2050 RESOLVE_TAG (&tag_e_share
, open
->share
);
2051 RESOLVE_TAG (&tag_cc
, open
->cc
);
2053 if (!gfc_reference_st_label (open
->err
, ST_LABEL_TARGET
))
2056 return check_open_constraints (open
, where
);
2060 /* Check if a given value for a SPECIFIER is either in the list of values
2061 allowed in F95 or F2003, issuing an error message and returning a zero
2062 value if it is not allowed. */
2066 compare_to_allowed_values (const char *specifier
, const char *allowed
[],
2067 const char *allowed_f2003
[],
2068 const char *allowed_gnu
[], gfc_char_t
*value
,
2069 const char *statement
, bool warn
, locus
*where
,
2075 len
= gfc_wide_strlen (value
);
2078 for (len
--; len
> 0; len
--)
2079 if (value
[len
] != ' ')
2084 for (i
= 0; allowed
[i
]; i
++)
2085 if (len
== strlen (allowed
[i
])
2086 && gfc_wide_strncasecmp (value
, allowed
[i
], strlen (allowed
[i
])) == 0)
2094 where
= &gfc_current_locus
;
2096 for (i
= 0; allowed_f2003
&& allowed_f2003
[i
]; i
++)
2097 if (len
== strlen (allowed_f2003
[i
])
2098 && gfc_wide_strncasecmp (value
, allowed_f2003
[i
],
2099 strlen (allowed_f2003
[i
])) == 0)
2101 notification n
= gfc_notification_std (GFC_STD_F2003
);
2103 if (n
== WARNING
|| (warn
&& n
== ERROR
))
2105 gfc_warning (0, "Fortran 2003: %s specifier in %s statement at %L "
2106 "has value %qs", specifier
, statement
, where
,
2113 gfc_notify_std (GFC_STD_F2003
, "%s specifier in "
2114 "%s statement at %L has value %qs", specifier
,
2115 statement
, where
, allowed_f2003
[i
]);
2123 for (i
= 0; allowed_gnu
&& allowed_gnu
[i
]; i
++)
2124 if (len
== strlen (allowed_gnu
[i
])
2125 && gfc_wide_strncasecmp (value
, allowed_gnu
[i
],
2126 strlen (allowed_gnu
[i
])) == 0)
2128 notification n
= gfc_notification_std (GFC_STD_GNU
);
2130 if (n
== WARNING
|| (warn
&& n
== ERROR
))
2132 gfc_warning (0, "Extension: %s specifier in %s statement at %L "
2133 "has value %qs", specifier
, statement
, where
,
2140 gfc_notify_std (GFC_STD_GNU
, "%s specifier in "
2141 "%s statement at %L has value %qs", specifier
,
2142 statement
, where
, allowed_gnu
[i
]);
2152 char *s
= gfc_widechar_to_char (value
, -1);
2154 "%s specifier in %s statement at %L has invalid value %qs",
2155 specifier
, statement
, where
, s
);
2161 char *s
= gfc_widechar_to_char (value
, -1);
2162 gfc_error ("%s specifier in %s statement at %L has invalid value %qs",
2163 specifier
, statement
, where
, s
);
2170 /* Check constraints on the OPEN statement.
2171 Similar to check_io_constraints for data transfer statements.
2172 At this point all tags have already been resolved via resolve_tag, which,
2173 among other things, verifies that BT_CHARACTER tags are of default kind. */
2176 check_open_constraints (gfc_open
*open
, locus
*where
)
2178 #define warn_or_error(...) \
2181 gfc_warning (0, __VA_ARGS__); \
2184 gfc_error (__VA_ARGS__); \
2189 bool warn
= (open
->err
|| open
->iostat
) ? true : false;
2191 /* Checks on the ACCESS specifier. */
2192 if (open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
)
2194 static const char *access_f95
[] = { "SEQUENTIAL", "DIRECT", NULL
};
2195 static const char *access_f2003
[] = { "STREAM", NULL
};
2196 static const char *access_gnu
[] = { "APPEND", NULL
};
2198 if (!compare_to_allowed_values ("ACCESS", access_f95
, access_f2003
,
2200 open
->access
->value
.character
.string
,
2201 "OPEN", warn
, &open
->access
->where
))
2205 /* Checks on the ACTION specifier. */
2206 if (open
->action
&& open
->action
->expr_type
== EXPR_CONSTANT
)
2208 gfc_char_t
*str
= open
->action
->value
.character
.string
;
2209 static const char *action
[] = { "READ", "WRITE", "READWRITE", NULL
};
2211 if (!compare_to_allowed_values ("ACTION", action
, NULL
, NULL
,
2212 str
, "OPEN", warn
, &open
->action
->where
))
2215 /* With READONLY, only allow ACTION='READ'. */
2216 if (open
->readonly
&& (gfc_wide_strlen (str
) != 4
2217 || gfc_wide_strncasecmp (str
, "READ", 4) != 0))
2219 gfc_error ("ACTION type conflicts with READONLY specifier at %L",
2220 &open
->action
->where
);
2225 /* If we see READONLY and no ACTION, set ACTION='READ'. */
2226 else if (open
->readonly
&& open
->action
== NULL
)
2228 open
->action
= gfc_get_character_expr (gfc_default_character_kind
,
2229 &gfc_current_locus
, "read", 4);
2232 /* Checks on the ASYNCHRONOUS specifier. */
2233 if (open
->asynchronous
)
2235 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS= at %L "
2236 "not allowed in Fortran 95",
2237 &open
->asynchronous
->where
))
2240 if (open
->asynchronous
->expr_type
== EXPR_CONSTANT
)
2242 static const char * asynchronous
[] = { "YES", "NO", NULL
};
2244 if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous
,
2245 NULL
, NULL
, open
->asynchronous
->value
.character
.string
,
2246 "OPEN", warn
, &open
->asynchronous
->where
))
2251 /* Checks on the BLANK specifier. */
2254 if (!gfc_notify_std (GFC_STD_F2003
, "BLANK= at %L "
2255 "not allowed in Fortran 95", &open
->blank
->where
))
2258 if (open
->blank
->expr_type
== EXPR_CONSTANT
)
2260 static const char *blank
[] = { "ZERO", "NULL", NULL
};
2262 if (!compare_to_allowed_values ("BLANK", blank
, NULL
, NULL
,
2263 open
->blank
->value
.character
.string
,
2264 "OPEN", warn
, &open
->blank
->where
))
2269 /* Checks on the CARRIAGECONTROL specifier. */
2270 if (open
->cc
&& open
->cc
->expr_type
== EXPR_CONSTANT
)
2272 static const char *cc
[] = { "LIST", "FORTRAN", "NONE", NULL
};
2273 if (!compare_to_allowed_values ("CARRIAGECONTROL", cc
, NULL
, NULL
,
2274 open
->cc
->value
.character
.string
,
2275 "OPEN", warn
, &open
->cc
->where
))
2279 /* Checks on the DECIMAL specifier. */
2282 if (!gfc_notify_std (GFC_STD_F2003
, "DECIMAL= at %L "
2283 "not allowed in Fortran 95", &open
->decimal
->where
))
2286 if (open
->decimal
->expr_type
== EXPR_CONSTANT
)
2288 static const char * decimal
[] = { "COMMA", "POINT", NULL
};
2290 if (!compare_to_allowed_values ("DECIMAL", decimal
, NULL
, NULL
,
2291 open
->decimal
->value
.character
.string
,
2292 "OPEN", warn
, &open
->decimal
->where
))
2297 /* Checks on the DELIM specifier. */
2300 if (open
->delim
->expr_type
== EXPR_CONSTANT
)
2302 static const char *delim
[] = { "APOSTROPHE", "QUOTE", "NONE", NULL
};
2304 if (!compare_to_allowed_values ("DELIM", delim
, NULL
, NULL
,
2305 open
->delim
->value
.character
.string
,
2306 "OPEN", warn
, &open
->delim
->where
))
2311 /* Checks on the ENCODING specifier. */
2314 if (!gfc_notify_std (GFC_STD_F2003
, "ENCODING= at %L "
2315 "not allowed in Fortran 95", &open
->encoding
->where
))
2318 if (open
->encoding
->expr_type
== EXPR_CONSTANT
)
2320 static const char * encoding
[] = { "DEFAULT", "UTF-8", NULL
};
2322 if (!compare_to_allowed_values ("ENCODING", encoding
, NULL
, NULL
,
2323 open
->encoding
->value
.character
.string
,
2324 "OPEN", warn
, &open
->encoding
->where
))
2329 /* Checks on the FORM specifier. */
2330 if (open
->form
&& open
->form
->expr_type
== EXPR_CONSTANT
)
2332 static const char *form
[] = { "FORMATTED", "UNFORMATTED", NULL
};
2334 if (!compare_to_allowed_values ("FORM", form
, NULL
, NULL
,
2335 open
->form
->value
.character
.string
,
2336 "OPEN", warn
, &open
->form
->where
))
2340 /* Checks on the PAD specifier. */
2341 if (open
->pad
&& open
->pad
->expr_type
== EXPR_CONSTANT
)
2343 static const char *pad
[] = { "YES", "NO", NULL
};
2345 if (!compare_to_allowed_values ("PAD", pad
, NULL
, NULL
,
2346 open
->pad
->value
.character
.string
,
2347 "OPEN", warn
, &open
->pad
->where
))
2351 /* Checks on the POSITION specifier. */
2352 if (open
->position
&& open
->position
->expr_type
== EXPR_CONSTANT
)
2354 static const char *position
[] = { "ASIS", "REWIND", "APPEND", NULL
};
2356 if (!compare_to_allowed_values ("POSITION", position
, NULL
, NULL
,
2357 open
->position
->value
.character
.string
,
2358 "OPEN", warn
, &open
->position
->where
))
2362 /* Checks on the ROUND specifier. */
2365 if (!gfc_notify_std (GFC_STD_F2003
, "ROUND= at %L "
2366 "not allowed in Fortran 95", &open
->round
->where
))
2369 if (open
->round
->expr_type
== EXPR_CONSTANT
)
2371 static const char * round
[] = { "UP", "DOWN", "ZERO", "NEAREST",
2372 "COMPATIBLE", "PROCESSOR_DEFINED",
2375 if (!compare_to_allowed_values ("ROUND", round
, NULL
, NULL
,
2376 open
->round
->value
.character
.string
,
2377 "OPEN", warn
, &open
->round
->where
))
2382 /* Checks on the SHARE specifier. */
2383 if (open
->share
&& open
->share
->expr_type
== EXPR_CONSTANT
)
2385 static const char *share
[] = { "DENYNONE", "DENYRW", NULL
};
2386 if (!compare_to_allowed_values ("SHARE", share
, NULL
, NULL
,
2387 open
->share
->value
.character
.string
,
2388 "OPEN", warn
, &open
->share
->where
))
2392 /* Checks on the SIGN specifier. */
2395 if (!gfc_notify_std (GFC_STD_F2003
, "SIGN= at %L "
2396 "not allowed in Fortran 95", &open
->sign
->where
))
2399 if (open
->sign
->expr_type
== EXPR_CONSTANT
)
2401 static const char * sign
[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
2404 if (!compare_to_allowed_values ("SIGN", sign
, NULL
, NULL
,
2405 open
->sign
->value
.character
.string
,
2406 "OPEN", warn
, &open
->sign
->where
))
2411 /* Checks on the RECL specifier. */
2412 if (open
->recl
&& open
->recl
->expr_type
== EXPR_CONSTANT
2413 && open
->recl
->ts
.type
== BT_INTEGER
2414 && mpz_sgn (open
->recl
->value
.integer
) != 1)
2416 warn_or_error (G_("RECL in OPEN statement at %L must be positive"),
2417 &open
->recl
->where
);
2420 /* Checks on the STATUS specifier. */
2421 if (open
->status
&& open
->status
->expr_type
== EXPR_CONSTANT
)
2423 static const char *status
[] = { "OLD", "NEW", "SCRATCH",
2424 "REPLACE", "UNKNOWN", NULL
};
2426 if (!compare_to_allowed_values ("STATUS", status
, NULL
, NULL
,
2427 open
->status
->value
.character
.string
,
2428 "OPEN", warn
, &open
->status
->where
))
2431 /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2432 the FILE= specifier shall appear. */
2433 if (open
->file
== NULL
2434 && (gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2436 || gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2439 char *s
= gfc_widechar_to_char (open
->status
->value
.character
.string
,
2441 warn_or_error (G_("The STATUS specified in OPEN statement at %L is "
2442 "%qs and no FILE specifier is present"),
2443 &open
->status
->where
, s
);
2447 /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2448 the FILE= specifier shall not appear. */
2449 if (gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2450 "scratch", 7) == 0 && open
->file
)
2452 warn_or_error (G_("The STATUS specified in OPEN statement at %L "
2453 "cannot have the value SCRATCH if a FILE specifier "
2454 "is present"), &open
->status
->where
);
2458 /* Checks on NEWUNIT specifier. */
2463 gfc_error ("UNIT specifier not allowed with NEWUNIT at %L",
2464 &open
->newunit
->where
);
2470 (open
->status
->expr_type
== EXPR_CONSTANT
2471 && gfc_wide_strncasecmp (open
->status
->value
.character
.string
,
2472 "scratch", 7) != 0)))
2474 gfc_error ("NEWUNIT specifier must have FILE= "
2475 "or STATUS='scratch' at %L", &open
->newunit
->where
);
2479 else if (!open
->unit
)
2481 gfc_error ("OPEN statement at %L must have UNIT or NEWUNIT specified",
2486 /* Things that are not allowed for unformatted I/O. */
2487 if (open
->form
&& open
->form
->expr_type
== EXPR_CONSTANT
2488 && (open
->delim
|| open
->decimal
|| open
->encoding
|| open
->round
2489 || open
->sign
|| open
->pad
|| open
->blank
)
2490 && gfc_wide_strncasecmp (open
->form
->value
.character
.string
,
2491 "unformatted", 11) == 0)
2497 loc
= &open
->delim
->where
;
2502 loc
= &open
->pad
->where
;
2505 else if (open
->blank
)
2507 loc
= &open
->blank
->where
;
2516 warn_or_error (G_("%s specifier at %L not allowed in OPEN statement for "
2517 "unformatted I/O"), spec
, loc
);
2520 if (open
->recl
&& open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
2521 && gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2524 warn_or_error (G_("RECL specifier not allowed in OPEN statement at %L for "
2525 "stream I/O"), &open
->recl
->where
);
2529 && open
->access
&& open
->access
->expr_type
== EXPR_CONSTANT
2530 && !(gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2531 "sequential", 10) == 0
2532 || gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2534 || gfc_wide_strncasecmp (open
->access
->value
.character
.string
,
2537 warn_or_error (G_("POSITION specifier in OPEN statement at %L only allowed "
2538 "for stream or sequential ACCESS"), &open
->position
->where
);
2542 #undef warn_or_error
2546 /* Match an OPEN statement. */
2549 gfc_match_open (void)
2554 m
= gfc_match_char ('(');
2558 open
= XCNEW (gfc_open
);
2560 m
= match_open_element (open
);
2562 if (m
== MATCH_ERROR
)
2566 m
= gfc_match_expr (&open
->unit
);
2567 if (m
== MATCH_ERROR
)
2573 if (gfc_match_char (')') == MATCH_YES
)
2575 if (gfc_match_char (',') != MATCH_YES
)
2578 m
= match_open_element (open
);
2579 if (m
== MATCH_ERROR
)
2585 if (gfc_match_eos () == MATCH_NO
)
2588 if (gfc_pure (NULL
))
2590 gfc_error ("OPEN statement not allowed in PURE procedure at %C");
2594 gfc_unset_implicit_pure (NULL
);
2596 new_st
.op
= EXEC_OPEN
;
2597 new_st
.ext
.open
= open
;
2601 gfc_syntax_error (ST_OPEN
);
2604 gfc_free_open (open
);
2609 /* Free a gfc_close structure an all its expressions. */
2612 gfc_free_close (gfc_close
*close
)
2617 gfc_free_expr (close
->unit
);
2618 gfc_free_expr (close
->iomsg
);
2619 gfc_free_expr (close
->iostat
);
2620 gfc_free_expr (close
->status
);
2625 /* Match elements of a CLOSE statement. */
2628 match_close_element (gfc_close
*close
)
2632 m
= match_etag (&tag_unit
, &close
->unit
);
2635 m
= match_etag (&tag_status
, &close
->status
);
2638 m
= match_etag (&tag_iomsg
, &close
->iomsg
);
2641 m
= match_out_tag (&tag_iostat
, &close
->iostat
);
2644 m
= match_ltag (&tag_err
, &close
->err
);
2652 /* Match a CLOSE statement. */
2655 gfc_match_close (void)
2660 m
= gfc_match_char ('(');
2664 close
= XCNEW (gfc_close
);
2666 m
= match_close_element (close
);
2668 if (m
== MATCH_ERROR
)
2672 m
= gfc_match_expr (&close
->unit
);
2675 if (m
== MATCH_ERROR
)
2681 if (gfc_match_char (')') == MATCH_YES
)
2683 if (gfc_match_char (',') != MATCH_YES
)
2686 m
= match_close_element (close
);
2687 if (m
== MATCH_ERROR
)
2693 if (gfc_match_eos () == MATCH_NO
)
2696 if (gfc_pure (NULL
))
2698 gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2702 gfc_unset_implicit_pure (NULL
);
2704 new_st
.op
= EXEC_CLOSE
;
2705 new_st
.ext
.close
= close
;
2709 gfc_syntax_error (ST_CLOSE
);
2712 gfc_free_close (close
);
2718 check_close_constraints (gfc_close
*close
, locus
*where
)
2720 bool warn
= (close
->iostat
|| close
->err
) ? true : false;
2722 if (close
->unit
== NULL
)
2724 gfc_error ("CLOSE statement at %L requires a UNIT number", where
);
2728 if (close
->unit
->expr_type
== EXPR_CONSTANT
2729 && close
->unit
->ts
.type
== BT_INTEGER
2730 && mpz_sgn (close
->unit
->value
.integer
) < 0)
2732 gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2733 &close
->unit
->where
);
2736 /* Checks on the STATUS specifier. */
2737 if (close
->status
&& close
->status
->expr_type
== EXPR_CONSTANT
)
2739 static const char *status
[] = { "KEEP", "DELETE", NULL
};
2741 if (!compare_to_allowed_values ("STATUS", status
, NULL
, NULL
,
2742 close
->status
->value
.character
.string
,
2743 "CLOSE", warn
, &close
->status
->where
))
2750 /* Resolve everything in a gfc_close structure. */
2753 gfc_resolve_close (gfc_close
*close
, locus
*where
)
2755 RESOLVE_TAG (&tag_unit
, close
->unit
);
2756 RESOLVE_TAG (&tag_iomsg
, close
->iomsg
);
2757 RESOLVE_TAG (&tag_iostat
, close
->iostat
);
2758 RESOLVE_TAG (&tag_status
, close
->status
);
2760 if (!gfc_reference_st_label (close
->err
, ST_LABEL_TARGET
))
2763 return check_close_constraints (close
, where
);
2767 /* Free a gfc_filepos structure. */
2770 gfc_free_filepos (gfc_filepos
*fp
)
2772 gfc_free_expr (fp
->unit
);
2773 gfc_free_expr (fp
->iomsg
);
2774 gfc_free_expr (fp
->iostat
);
2779 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
2782 match_file_element (gfc_filepos
*fp
)
2786 m
= match_etag (&tag_unit
, &fp
->unit
);
2789 m
= match_etag (&tag_iomsg
, &fp
->iomsg
);
2792 m
= match_out_tag (&tag_iostat
, &fp
->iostat
);
2795 m
= match_ltag (&tag_err
, &fp
->err
);
2803 /* Match the second half of the file-positioning statements, REWIND,
2804 BACKSPACE, ENDFILE, or the FLUSH statement. */
2807 match_filepos (gfc_statement st
, gfc_exec_op op
)
2812 fp
= XCNEW (gfc_filepos
);
2814 if (gfc_match_char ('(') == MATCH_NO
)
2816 m
= gfc_match_expr (&fp
->unit
);
2817 if (m
== MATCH_ERROR
)
2825 m
= match_file_element (fp
);
2826 if (m
== MATCH_ERROR
)
2830 m
= gfc_match_expr (&fp
->unit
);
2831 if (m
== MATCH_ERROR
|| m
== MATCH_NO
)
2837 if (gfc_match_char (')') == MATCH_YES
)
2839 if (gfc_match_char (',') != MATCH_YES
)
2842 m
= match_file_element (fp
);
2843 if (m
== MATCH_ERROR
)
2850 if (gfc_match_eos () != MATCH_YES
)
2853 if (gfc_pure (NULL
))
2855 gfc_error ("%s statement not allowed in PURE procedure at %C",
2856 gfc_ascii_statement (st
));
2861 gfc_unset_implicit_pure (NULL
);
2864 new_st
.ext
.filepos
= fp
;
2868 gfc_syntax_error (st
);
2871 gfc_free_filepos (fp
);
2877 gfc_resolve_filepos (gfc_filepos
*fp
, locus
*where
)
2879 RESOLVE_TAG (&tag_unit
, fp
->unit
);
2880 RESOLVE_TAG (&tag_iostat
, fp
->iostat
);
2881 RESOLVE_TAG (&tag_iomsg
, fp
->iomsg
);
2883 if (!fp
->unit
&& (fp
->iostat
|| fp
->iomsg
|| fp
->err
))
2885 gfc_error ("UNIT number missing in statement at %L", where
);
2889 if (!gfc_reference_st_label (fp
->err
, ST_LABEL_TARGET
))
2892 if (fp
->unit
->expr_type
== EXPR_CONSTANT
2893 && fp
->unit
->ts
.type
== BT_INTEGER
2894 && mpz_sgn (fp
->unit
->value
.integer
) < 0)
2896 gfc_error ("UNIT number in statement at %L must be non-negative",
2905 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2906 and the FLUSH statement. */
2909 gfc_match_endfile (void)
2911 return match_filepos (ST_END_FILE
, EXEC_ENDFILE
);
2915 gfc_match_backspace (void)
2917 return match_filepos (ST_BACKSPACE
, EXEC_BACKSPACE
);
2921 gfc_match_rewind (void)
2923 return match_filepos (ST_REWIND
, EXEC_REWIND
);
2927 gfc_match_flush (void)
2929 if (!gfc_notify_std (GFC_STD_F2003
, "FLUSH statement at %C"))
2932 return match_filepos (ST_FLUSH
, EXEC_FLUSH
);
2935 /******************** Data Transfer Statements *********************/
2937 /* Return a default unit number. */
2940 default_unit (io_kind k
)
2949 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, unit
);
2953 /* Match a unit specification for a data transfer statement. */
2956 match_dt_unit (io_kind k
, gfc_dt
*dt
)
2961 if (gfc_match_char ('*') == MATCH_YES
)
2963 if (dt
->io_unit
!= NULL
)
2966 dt
->io_unit
= default_unit (k
);
2968 c
= gfc_peek_ascii_char ();
2970 gfc_error_now ("Missing format with default unit at %C");
2975 if (gfc_match_expr (&e
) == MATCH_YES
)
2977 if (dt
->io_unit
!= NULL
)
2990 gfc_error ("Duplicate UNIT specification at %C");
2995 /* Match a format specification. */
2998 match_dt_format (gfc_dt
*dt
)
3002 gfc_st_label
*label
;
3005 where
= gfc_current_locus
;
3007 if (gfc_match_char ('*') == MATCH_YES
)
3009 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
3012 dt
->format_label
= &format_asterisk
;
3016 if ((m
= gfc_match_st_label (&label
)) == MATCH_YES
)
3020 /* Need to check if the format label is actually either an operand
3021 to a user-defined operator or is a kind type parameter. That is,
3022 print 2.ip.8 ! .ip. is a user-defined operator return CHARACTER.
3023 print 1_'(I0)', i ! 1_'(I0)' is a default character string. */
3025 gfc_gobble_whitespace ();
3026 c
= gfc_peek_ascii_char ();
3027 if (c
== '.' || c
== '_')
3028 gfc_current_locus
= where
;
3031 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
3033 gfc_free_st_label (label
);
3037 if (!gfc_reference_st_label (label
, ST_LABEL_FORMAT
))
3040 dt
->format_label
= label
;
3044 else if (m
== MATCH_ERROR
)
3045 /* The label was zero or too large. Emit the correct diagnosis. */
3048 if (gfc_match_expr (&e
) == MATCH_YES
)
3050 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
3055 dt
->format_expr
= e
;
3059 gfc_current_locus
= where
; /* The only case where we have to restore */
3064 gfc_error ("Duplicate format specification at %C");
3068 /* Check for formatted read and write DTIO procedures. */
3071 dtio_procs_present (gfc_symbol
*sym
, io_kind k
)
3073 gfc_symbol
*derived
;
3075 if (sym
&& sym
->ts
.u
.derived
)
3077 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
3078 derived
= CLASS_DATA (sym
)->ts
.u
.derived
;
3079 else if (sym
->ts
.type
== BT_DERIVED
)
3080 derived
= sym
->ts
.u
.derived
;
3083 if ((k
== M_WRITE
|| k
== M_PRINT
) &&
3084 (gfc_find_specific_dtio_proc (derived
, true, true) != NULL
))
3086 if ((k
== M_READ
) &&
3087 (gfc_find_specific_dtio_proc (derived
, false, true) != NULL
))
3093 /* Traverse a namelist that is part of a READ statement to make sure
3094 that none of the variables in the namelist are INTENT(IN). Returns
3095 nonzero if we find such a variable. */
3098 check_namelist (gfc_symbol
*sym
)
3102 for (p
= sym
->namelist
; p
; p
= p
->next
)
3103 if (p
->sym
->attr
.intent
== INTENT_IN
)
3105 gfc_error ("Symbol %qs in namelist %qs is INTENT(IN) at %C",
3106 p
->sym
->name
, sym
->name
);
3114 /* Match a single data transfer element. */
3117 match_dt_element (io_kind k
, gfc_dt
*dt
)
3119 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3123 if (gfc_match (" unit =") == MATCH_YES
)
3125 m
= match_dt_unit (k
, dt
);
3130 if (gfc_match (" fmt =") == MATCH_YES
)
3132 m
= match_dt_format (dt
);
3137 if (gfc_match (" nml = %n", name
) == MATCH_YES
)
3139 if (dt
->namelist
!= NULL
)
3141 gfc_error ("Duplicate NML specification at %C");
3145 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
3148 if (sym
== NULL
|| sym
->attr
.flavor
!= FL_NAMELIST
)
3150 gfc_error ("Symbol %qs at %C must be a NAMELIST group name",
3151 sym
!= NULL
? sym
->name
: name
);
3156 if (k
== M_READ
&& check_namelist (sym
))
3162 m
= match_etag (&tag_e_async
, &dt
->asynchronous
);
3165 m
= match_etag (&tag_e_blank
, &dt
->blank
);
3168 m
= match_etag (&tag_e_delim
, &dt
->delim
);
3171 m
= match_etag (&tag_e_pad
, &dt
->pad
);
3174 m
= match_etag (&tag_e_sign
, &dt
->sign
);
3177 m
= match_etag (&tag_e_round
, &dt
->round
);
3180 m
= match_out_tag (&tag_id
, &dt
->id
);
3183 m
= match_etag (&tag_e_decimal
, &dt
->decimal
);
3186 m
= match_etag (&tag_rec
, &dt
->rec
);
3189 m
= match_etag (&tag_spos
, &dt
->pos
);
3192 m
= match_etag (&tag_iomsg
, &dt
->iomsg
);
3196 m
= match_out_tag (&tag_iostat
, &dt
->iostat
);
3199 m
= match_ltag (&tag_err
, &dt
->err
);
3201 dt
->err_where
= gfc_current_locus
;
3204 m
= match_etag (&tag_advance
, &dt
->advance
);
3207 m
= match_out_tag (&tag_size
, &dt
->size
);
3211 m
= match_ltag (&tag_end
, &dt
->end
);
3216 gfc_error ("END tag at %C not allowed in output statement");
3219 dt
->end_where
= gfc_current_locus
;
3224 m
= match_ltag (&tag_eor
, &dt
->eor
);
3226 dt
->eor_where
= gfc_current_locus
;
3234 /* Free a data transfer structure and everything below it. */
3237 gfc_free_dt (gfc_dt
*dt
)
3242 gfc_free_expr (dt
->io_unit
);
3243 gfc_free_expr (dt
->format_expr
);
3244 gfc_free_expr (dt
->rec
);
3245 gfc_free_expr (dt
->advance
);
3246 gfc_free_expr (dt
->iomsg
);
3247 gfc_free_expr (dt
->iostat
);
3248 gfc_free_expr (dt
->size
);
3249 gfc_free_expr (dt
->pad
);
3250 gfc_free_expr (dt
->delim
);
3251 gfc_free_expr (dt
->sign
);
3252 gfc_free_expr (dt
->round
);
3253 gfc_free_expr (dt
->blank
);
3254 gfc_free_expr (dt
->decimal
);
3255 gfc_free_expr (dt
->pos
);
3256 gfc_free_expr (dt
->dt_io_kind
);
3257 /* dt->extra_comma is a link to dt_io_kind if it is set. */
3263 io_kind_name (io_kind k
);
3266 check_io_constraints (io_kind k
, gfc_dt
*dt
, gfc_code
*io_code
,
3269 /* Resolve everything in a gfc_dt structure. */
3272 gfc_resolve_dt (gfc_code
*dt_code
, gfc_dt
*dt
, locus
*loc
)
3277 /* This is set in any case. */
3278 gcc_assert (dt
->dt_io_kind
);
3279 k
= dt
->dt_io_kind
->value
.iokind
;
3281 RESOLVE_TAG (&tag_format
, dt
->format_expr
);
3282 RESOLVE_TAG (&tag_rec
, dt
->rec
);
3283 RESOLVE_TAG (&tag_spos
, dt
->pos
);
3284 RESOLVE_TAG (&tag_advance
, dt
->advance
);
3285 RESOLVE_TAG (&tag_id
, dt
->id
);
3286 RESOLVE_TAG (&tag_iomsg
, dt
->iomsg
);
3287 RESOLVE_TAG (&tag_iostat
, dt
->iostat
);
3288 RESOLVE_TAG (&tag_size
, dt
->size
);
3289 RESOLVE_TAG (&tag_e_pad
, dt
->pad
);
3290 RESOLVE_TAG (&tag_e_delim
, dt
->delim
);
3291 RESOLVE_TAG (&tag_e_sign
, dt
->sign
);
3292 RESOLVE_TAG (&tag_e_round
, dt
->round
);
3293 RESOLVE_TAG (&tag_e_blank
, dt
->blank
);
3294 RESOLVE_TAG (&tag_e_decimal
, dt
->decimal
);
3295 RESOLVE_TAG (&tag_e_async
, dt
->asynchronous
);
3297 /* Check I/O constraints.
3298 To validate NAMELIST we need to check if we were also given an I/O list,
3299 which is stored in code->block->next with op EXEC_TRANSFER.
3300 Note that the I/O list was already resolved from resolve_transfer. */
3301 gfc_code
*io_code
= NULL
;
3302 if (dt_code
&& dt_code
->block
&& dt_code
->block
->next
3303 && dt_code
->block
->next
->op
== EXEC_TRANSFER
)
3304 io_code
= dt_code
->block
->next
;
3306 if (!check_io_constraints (k
, dt
, io_code
, loc
))
3312 gfc_error ("UNIT not specified at %L", loc
);
3316 if (e
->symtree
&& e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
3317 && e
->ts
.type
== BT_CHARACTER
)
3319 gfc_error ("UNIT specification at %L must "
3320 "not be a character PARAMETER", &e
->where
);
3324 if (gfc_resolve_expr (e
)
3325 && (e
->ts
.type
!= BT_INTEGER
3326 && (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_VARIABLE
)))
3328 /* If there is no extra comma signifying the "format" form of the IO
3329 statement, then this must be an error. */
3330 if (!dt
->extra_comma
)
3332 gfc_error ("UNIT specification at %L must be an INTEGER expression "
3333 "or a CHARACTER variable", &e
->where
);
3338 /* At this point, we have an extra comma. If io_unit has arrived as
3339 type character, we assume its really the "format" form of the I/O
3340 statement. We set the io_unit to the default unit and format to
3341 the character expression. See F95 Standard section 9.4. */
3342 if (e
->ts
.type
== BT_CHARACTER
&& (k
== M_READ
|| k
== M_PRINT
))
3344 dt
->format_expr
= dt
->io_unit
;
3345 dt
->io_unit
= default_unit (k
);
3347 /* Nullify this pointer now so that a warning/error is not
3348 triggered below for the "Extension". */
3349 dt
->extra_comma
= NULL
;
3354 gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
3355 &dt
->extra_comma
->where
);
3361 if (e
->ts
.type
== BT_CHARACTER
)
3363 if (gfc_has_vector_index (e
))
3365 gfc_error ("Internal unit with vector subscript at %L", &e
->where
);
3369 /* If we are writing, make sure the internal unit can be changed. */
3370 gcc_assert (k
!= M_PRINT
);
3372 && !gfc_check_vardef_context (e
, false, false, false,
3373 _("internal unit in WRITE")))
3377 if (e
->rank
&& e
->ts
.type
!= BT_CHARACTER
)
3379 gfc_error ("External IO UNIT cannot be an array at %L", &e
->where
);
3383 if (e
->expr_type
== EXPR_CONSTANT
&& e
->ts
.type
== BT_INTEGER
3384 && mpz_sgn (e
->value
.integer
) < 0)
3386 gfc_error ("UNIT number in statement at %L must be non-negative",
3391 /* If we are reading and have a namelist, check that all namelist symbols
3392 can appear in a variable definition context. */
3396 for (n
= dt
->namelist
->namelist
; n
; n
= n
->next
)
3403 e
= gfc_get_variable_expr (gfc_find_sym_in_symtree (n
->sym
));
3404 t
= gfc_check_vardef_context (e
, false, false, false, NULL
);
3409 gfc_error ("NAMELIST %qs in READ statement at %L contains"
3410 " the symbol %qs which may not appear in a"
3411 " variable definition context",
3412 dt
->namelist
->name
, loc
, n
->sym
->name
);
3417 t
= dtio_procs_present (n
->sym
, k
);
3419 if (n
->sym
->ts
.type
== BT_CLASS
&& !t
)
3421 gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
3422 "polymorphic and requires a defined input/output "
3423 "procedure", n
->sym
->name
, dt
->namelist
->name
, loc
);
3427 if ((n
->sym
->ts
.type
== BT_DERIVED
)
3428 && (n
->sym
->ts
.u
.derived
->attr
.alloc_comp
3429 || n
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
3431 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
3432 "namelist %qs at %L with ALLOCATABLE "
3433 "or POINTER components", n
->sym
->name
,
3434 dt
->namelist
->name
, loc
))
3439 gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
3440 "ALLOCATABLE or POINTER components and thus requires "
3441 "a defined input/output procedure", n
->sym
->name
,
3442 dt
->namelist
->name
, loc
);
3450 && !gfc_notify_std (GFC_STD_LEGACY
, "Comma before i/o item list at %L",
3451 &dt
->extra_comma
->where
))
3456 if (!gfc_reference_st_label (dt
->err
, ST_LABEL_TARGET
))
3458 if (dt
->err
->defined
== ST_LABEL_UNKNOWN
)
3460 gfc_error ("ERR tag label %d at %L not defined",
3461 dt
->err
->value
, &dt
->err_where
);
3468 if (!gfc_reference_st_label (dt
->end
, ST_LABEL_TARGET
))
3470 if (dt
->end
->defined
== ST_LABEL_UNKNOWN
)
3472 gfc_error ("END tag label %d at %L not defined",
3473 dt
->end
->value
, &dt
->end_where
);
3480 if (!gfc_reference_st_label (dt
->eor
, ST_LABEL_TARGET
))
3482 if (dt
->eor
->defined
== ST_LABEL_UNKNOWN
)
3484 gfc_error ("EOR tag label %d at %L not defined",
3485 dt
->eor
->value
, &dt
->eor_where
);
3490 /* Check the format label actually exists. */
3491 if (dt
->format_label
&& dt
->format_label
!= &format_asterisk
3492 && dt
->format_label
->defined
== ST_LABEL_UNKNOWN
)
3494 gfc_error ("FORMAT label %d at %L not defined", dt
->format_label
->value
,
3503 /* Given an io_kind, return its name. */
3506 io_kind_name (io_kind k
)
3525 gfc_internal_error ("io_kind_name(): bad I/O-kind");
3532 /* Match an IO iteration statement of the form:
3534 ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
3536 which is equivalent to a single IO element. This function is
3537 mutually recursive with match_io_element(). */
3539 static match
match_io_element (io_kind
, gfc_code
**);
3542 match_io_iterator (io_kind k
, gfc_code
**result
)
3544 gfc_code
*head
, *tail
, *new_code
;
3552 old_loc
= gfc_current_locus
;
3554 if (gfc_match_char ('(') != MATCH_YES
)
3557 m
= match_io_element (k
, &head
);
3560 if (m
!= MATCH_YES
|| gfc_match_char (',') != MATCH_YES
)
3566 /* Can't be anything but an IO iterator. Build a list. */
3567 iter
= gfc_get_iterator ();
3571 m
= gfc_match_iterator (iter
, 0);
3572 if (m
== MATCH_ERROR
)
3576 gfc_check_do_variable (iter
->var
->symtree
);
3580 m
= match_io_element (k
, &new_code
);
3581 if (m
== MATCH_ERROR
)
3590 tail
= gfc_append_code (tail
, new_code
);
3592 if (gfc_match_char (',') != MATCH_YES
)
3601 if (gfc_match_char (')') != MATCH_YES
)
3604 new_code
= gfc_get_code (EXEC_DO
);
3605 new_code
->ext
.iterator
= iter
;
3607 new_code
->block
= gfc_get_code (EXEC_DO
);
3608 new_code
->block
->next
= head
;
3614 gfc_error ("Syntax error in I/O iterator at %C");
3618 gfc_free_iterator (iter
, 1);
3619 gfc_free_statements (head
);
3620 gfc_current_locus
= old_loc
;
3625 /* Match a single element of an IO list, which is either a single
3626 expression or an IO Iterator. */
3629 match_io_element (io_kind k
, gfc_code
**cpp
)
3637 m
= match_io_iterator (k
, cpp
);
3643 m
= gfc_match_variable (&expr
, 0);
3646 gfc_error ("Expecting variable in READ statement at %C");
3650 if (m
== MATCH_YES
&& expr
->expr_type
== EXPR_CONSTANT
)
3652 gfc_error ("Expecting variable or io-implied-do in READ statement "
3653 "at %L", &expr
->where
);
3658 && expr
->expr_type
== EXPR_VARIABLE
3659 && expr
->symtree
->n
.sym
->attr
.external
)
3661 gfc_error ("Expecting variable or io-implied-do at %L",
3668 m
= gfc_match_expr (&expr
);
3670 gfc_error ("Expected expression in %s statement at %C",
3673 if (m
== MATCH_YES
&& expr
->ts
.type
== BT_BOZ
)
3675 if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in"
3676 " an output IO list"), &gfc_current_locus
))
3678 if (!gfc_boz2int (expr
, gfc_max_integer_kind
))
3683 if (m
== MATCH_YES
&& k
== M_READ
&& gfc_check_do_variable (expr
->symtree
))
3688 gfc_free_expr (expr
);
3692 cp
= gfc_get_code (EXEC_TRANSFER
);
3695 cp
->ext
.dt
= current_dt
;
3702 /* Match an I/O list, building gfc_code structures as we go. */
3705 match_io_list (io_kind k
, gfc_code
**head_p
)
3707 gfc_code
*head
, *tail
, *new_code
;
3710 *head_p
= head
= tail
= NULL
;
3711 if (gfc_match_eos () == MATCH_YES
)
3716 m
= match_io_element (k
, &new_code
);
3717 if (m
== MATCH_ERROR
)
3722 tail
= gfc_append_code (tail
, new_code
);
3726 if (gfc_match_eos () == MATCH_YES
)
3728 if (gfc_match_char (',') != MATCH_YES
)
3736 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
3739 gfc_free_statements (head
);
3744 /* Attach the data transfer end node. */
3747 terminate_io (gfc_code
*io_code
)
3751 if (io_code
== NULL
)
3752 io_code
= new_st
.block
;
3754 c
= gfc_get_code (EXEC_DT_END
);
3756 /* Point to structure that is already there */
3757 c
->ext
.dt
= new_st
.ext
.dt
;
3758 gfc_append_code (io_code
, c
);
3762 /* Check the constraints for a data transfer statement. The majority of the
3763 constraints appearing in 9.4 of the standard appear here.
3765 Tag expressions are already resolved by resolve_tag, which includes
3766 verifying the type, that they are scalar, and verifying that BT_CHARACTER
3767 tags are of default kind. */
3770 check_io_constraints (io_kind k
, gfc_dt
*dt
, gfc_code
*io_code
,
3773 #define io_constraint(condition, msg, arg)\
3776 if ((arg)->lb != NULL)\
3777 gfc_error ((msg), (arg));\
3779 gfc_error ((msg), spec_end);\
3784 gfc_symbol
*sym
= NULL
;
3785 bool warn
, unformatted
;
3787 warn
= (dt
->err
|| dt
->iostat
) ? true : false;
3788 unformatted
= dt
->format_expr
== NULL
&& dt
->format_label
== NULL
3789 && dt
->namelist
== NULL
;
3792 if (expr
&& expr
->expr_type
== EXPR_VARIABLE
3793 && expr
->ts
.type
== BT_CHARACTER
)
3795 sym
= expr
->symtree
->n
.sym
;
3797 io_constraint (k
== M_WRITE
&& sym
->attr
.intent
== INTENT_IN
,
3798 "Internal file at %L must not be INTENT(IN)",
3801 io_constraint (gfc_has_vector_index (dt
->io_unit
),
3802 "Internal file incompatible with vector subscript at %L",
3805 io_constraint (dt
->rec
!= NULL
,
3806 "REC tag at %L is incompatible with internal file",
3809 io_constraint (dt
->pos
!= NULL
,
3810 "POS tag at %L is incompatible with internal file",
3813 io_constraint (unformatted
,
3814 "Unformatted I/O not allowed with internal unit at %L",
3815 &dt
->io_unit
->where
);
3817 io_constraint (dt
->asynchronous
!= NULL
,
3818 "ASYNCHRONOUS tag at %L not allowed with internal file",
3819 &dt
->asynchronous
->where
);
3821 if (dt
->namelist
!= NULL
)
3823 if (!gfc_notify_std (GFC_STD_F2003
, "Internal file at %L with "
3824 "namelist", &expr
->where
))
3828 io_constraint (dt
->advance
!= NULL
,
3829 "ADVANCE tag at %L is incompatible with internal file",
3830 &dt
->advance
->where
);
3833 if (expr
&& expr
->ts
.type
!= BT_CHARACTER
)
3836 if (gfc_pure (NULL
) && (k
== M_READ
|| k
== M_WRITE
))
3838 gfc_error ("IO UNIT in %s statement at %L must be "
3839 "an internal file in a PURE procedure",
3840 io_kind_name (k
), &expr
->where
);
3844 if (k
== M_READ
|| k
== M_WRITE
)
3845 gfc_unset_implicit_pure (NULL
);
3848 if (dt
->asynchronous
)
3851 static const char * asynchronous
[] = { "YES", "NO", NULL
};
3853 /* Note: gfc_reduce_init_expr reports an error if not init-expr. */
3854 if (!gfc_reduce_init_expr (dt
->asynchronous
))
3857 if (!compare_to_allowed_values
3858 ("ASYNCHRONOUS", asynchronous
, NULL
, NULL
,
3859 dt
->asynchronous
->value
.character
.string
,
3860 io_kind_name (k
), warn
, &dt
->asynchronous
->where
, &num
))
3863 gcc_checking_assert (num
!= -1);
3865 /* For "YES", mark related symbols as asynchronous. */
3868 /* SIZE variable. */
3870 dt
->size
->symtree
->n
.sym
->attr
.asynchronous
= 1;
3872 /* Variables in a NAMELIST. */
3874 for (gfc_namelist
*nl
= dt
->namelist
->namelist
; nl
; nl
= nl
->next
)
3875 nl
->sym
->attr
.asynchronous
= 1;
3877 /* Variables in an I/O list. */
3878 for (gfc_code
*xfer
= io_code
; xfer
&& xfer
->op
== EXEC_TRANSFER
;
3881 gfc_expr
*expr
= xfer
->expr1
;
3882 while (expr
!= NULL
&& expr
->expr_type
== EXPR_OP
3883 && expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3884 expr
= expr
->value
.op
.op1
;
3886 if (expr
&& expr
->expr_type
== EXPR_VARIABLE
)
3887 expr
->symtree
->n
.sym
->attr
.asynchronous
= 1;
3896 || gfc_wide_strlen (dt
->asynchronous
->value
.character
.string
) != 3
3897 || gfc_wide_strncasecmp (dt
->asynchronous
->value
.character
.string
,
3899 io_constraint (not_yes
,
3900 "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3901 "specifier", &dt
->id
->where
);
3906 if (!gfc_notify_std (GFC_STD_F2003
, "DECIMAL= at %L "
3907 "not allowed in Fortran 95", &dt
->decimal
->where
))
3910 if (dt
->decimal
->expr_type
== EXPR_CONSTANT
)
3912 static const char * decimal
[] = { "COMMA", "POINT", NULL
};
3914 if (!compare_to_allowed_values ("DECIMAL", decimal
, NULL
, NULL
,
3915 dt
->decimal
->value
.character
.string
,
3916 io_kind_name (k
), warn
,
3917 &dt
->decimal
->where
))
3920 io_constraint (unformatted
,
3921 "the DECIMAL= specifier at %L must be with an "
3922 "explicit format expression", &dt
->decimal
->where
);
3928 if (!gfc_notify_std (GFC_STD_F2003
, "BLANK= at %L "
3929 "not allowed in Fortran 95", &dt
->blank
->where
))
3932 if (dt
->blank
->expr_type
== EXPR_CONSTANT
)
3934 static const char * blank
[] = { "NULL", "ZERO", NULL
};
3937 if (!compare_to_allowed_values ("BLANK", blank
, NULL
, NULL
,
3938 dt
->blank
->value
.character
.string
,
3939 io_kind_name (k
), warn
,
3943 io_constraint (unformatted
,
3944 "the BLANK= specifier at %L must be with an "
3945 "explicit format expression", &dt
->blank
->where
);
3951 if (!gfc_notify_std (GFC_STD_F2003
, "PAD= at %L "
3952 "not allowed in Fortran 95", &dt
->pad
->where
))
3955 if (dt
->pad
->expr_type
== EXPR_CONSTANT
)
3957 static const char * pad
[] = { "YES", "NO", NULL
};
3959 if (!compare_to_allowed_values ("PAD", pad
, NULL
, NULL
,
3960 dt
->pad
->value
.character
.string
,
3961 io_kind_name (k
), warn
,
3965 io_constraint (unformatted
,
3966 "the PAD= specifier at %L must be with an "
3967 "explicit format expression", &dt
->pad
->where
);
3973 if (!gfc_notify_std (GFC_STD_F2003
, "ROUND= at %L "
3974 "not allowed in Fortran 95", &dt
->round
->where
))
3977 if (dt
->round
->expr_type
== EXPR_CONSTANT
)
3979 static const char * round
[] = { "UP", "DOWN", "ZERO", "NEAREST",
3980 "COMPATIBLE", "PROCESSOR_DEFINED",
3983 if (!compare_to_allowed_values ("ROUND", round
, NULL
, NULL
,
3984 dt
->round
->value
.character
.string
,
3985 io_kind_name (k
), warn
,
3993 /* When implemented, change the following to use gfc_notify_std F2003.
3994 if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %L "
3995 "not allowed in Fortran 95", &dt->sign->where) == false)
3998 if (dt
->sign
->expr_type
== EXPR_CONSTANT
)
4000 static const char * sign
[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
4003 if (!compare_to_allowed_values ("SIGN", sign
, NULL
, NULL
,
4004 dt
->sign
->value
.character
.string
,
4005 io_kind_name (k
), warn
, &dt
->sign
->where
))
4008 io_constraint (unformatted
,
4009 "SIGN= specifier at %L must be with an "
4010 "explicit format expression", &dt
->sign
->where
);
4012 io_constraint (k
== M_READ
,
4013 "SIGN= specifier at %L not allowed in a "
4014 "READ statement", &dt
->sign
->where
);
4020 if (!gfc_notify_std (GFC_STD_F2003
, "DELIM= at %L "
4021 "not allowed in Fortran 95", &dt
->delim
->where
))
4024 if (dt
->delim
->expr_type
== EXPR_CONSTANT
)
4026 static const char *delim
[] = { "APOSTROPHE", "QUOTE", "NONE", NULL
};
4028 if (!compare_to_allowed_values ("DELIM", delim
, NULL
, NULL
,
4029 dt
->delim
->value
.character
.string
,
4030 io_kind_name (k
), warn
,
4034 io_constraint (k
== M_READ
,
4035 "DELIM= specifier at %L not allowed in a "
4036 "READ statement", &dt
->delim
->where
);
4038 io_constraint (dt
->format_label
!= &format_asterisk
4039 && dt
->namelist
== NULL
,
4040 "DELIM= specifier at %L must have FMT=*",
4043 io_constraint (unformatted
&& dt
->namelist
== NULL
,
4044 "DELIM= specifier at %L must be with FMT=* or "
4045 "NML= specifier", &dt
->delim
->where
);
4051 io_constraint (io_code
&& dt
->namelist
,
4052 "NAMELIST cannot be followed by IO-list at %L",
4055 io_constraint (dt
->format_expr
,
4056 "IO spec-list cannot contain both NAMELIST group name "
4057 "and format specification at %L",
4058 &dt
->format_expr
->where
);
4060 io_constraint (dt
->format_label
,
4061 "IO spec-list cannot contain both NAMELIST group name "
4062 "and format label at %L", spec_end
);
4064 io_constraint (dt
->rec
,
4065 "NAMELIST IO is not allowed with a REC= specifier "
4066 "at %L", &dt
->rec
->where
);
4068 io_constraint (dt
->advance
,
4069 "NAMELIST IO is not allowed with a ADVANCE= specifier "
4070 "at %L", &dt
->advance
->where
);
4075 io_constraint (dt
->end
,
4076 "An END tag is not allowed with a "
4077 "REC= specifier at %L", &dt
->end_where
);
4079 io_constraint (dt
->format_label
== &format_asterisk
,
4080 "FMT=* is not allowed with a REC= specifier "
4083 io_constraint (dt
->pos
,
4084 "POS= is not allowed with REC= specifier "
4085 "at %L", &dt
->pos
->where
);
4090 int not_yes
, not_no
;
4093 io_constraint (dt
->format_label
== &format_asterisk
,
4094 "List directed format(*) is not allowed with a "
4095 "ADVANCE= specifier at %L.", &expr
->where
);
4097 io_constraint (unformatted
,
4098 "the ADVANCE= specifier at %L must appear with an "
4099 "explicit format expression", &expr
->where
);
4101 if (expr
->expr_type
== EXPR_CONSTANT
&& expr
->ts
.type
== BT_CHARACTER
)
4103 const gfc_char_t
*advance
= expr
->value
.character
.string
;
4104 not_no
= gfc_wide_strlen (advance
) != 2
4105 || gfc_wide_strncasecmp (advance
, "no", 2) != 0;
4106 not_yes
= gfc_wide_strlen (advance
) != 3
4107 || gfc_wide_strncasecmp (advance
, "yes", 3) != 0;
4115 io_constraint (not_no
&& not_yes
,
4116 "ADVANCE= specifier at %L must have value = "
4117 "YES or NO.", &expr
->where
);
4119 io_constraint (dt
->size
&& not_no
&& k
== M_READ
,
4120 "SIZE tag at %L requires an ADVANCE = %<NO%>",
4123 io_constraint (dt
->eor
&& not_no
&& k
== M_READ
,
4124 "EOR tag at %L requires an ADVANCE = %<NO%>",
4130 io_constraint (dt
->end
, "END tag not allowed with output at %L",
4133 io_constraint (dt
->eor
, "EOR tag not allowed with output at %L",
4136 io_constraint (dt
->blank
,
4137 "BLANK= specifier not allowed with output at %L",
4140 io_constraint (dt
->pad
, "PAD= specifier not allowed with output at %L",
4143 io_constraint (dt
->size
, "SIZE= specifier not allowed with output at %L",
4148 io_constraint (dt
->size
&& dt
->advance
== NULL
,
4149 "SIZE tag at %L requires an ADVANCE tag",
4152 io_constraint (dt
->eor
&& dt
->advance
== NULL
,
4153 "EOR tag at %L requires an ADVANCE tag",
4158 #undef io_constraint
4162 /* Match a READ, WRITE or PRINT statement. */
4165 match_io (io_kind k
)
4167 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4176 where
= gfc_current_locus
;
4178 current_dt
= dt
= XCNEW (gfc_dt
);
4179 m
= gfc_match_char ('(');
4182 where
= gfc_current_locus
;
4185 else if (k
== M_PRINT
)
4187 /* Treat the non-standard case of PRINT namelist. */
4188 if ((gfc_current_form
== FORM_FIXED
|| gfc_peek_ascii_char () == ' ')
4189 && gfc_match_name (name
) == MATCH_YES
)
4191 gfc_find_symbol (name
, NULL
, 1, &sym
);
4192 if (sym
&& sym
->attr
.flavor
== FL_NAMELIST
)
4194 if (!gfc_notify_std (GFC_STD_GNU
, "PRINT namelist at "
4195 "%C is an extension"))
4201 dt
->io_unit
= default_unit (k
);
4206 gfc_current_locus
= where
;
4209 if (gfc_match_char ('*') == MATCH_YES
4210 && gfc_match_char(',') == MATCH_YES
)
4212 locus where2
= gfc_current_locus
;
4213 if (gfc_match_eos () == MATCH_YES
)
4215 gfc_current_locus
= where2
;
4216 gfc_error ("Comma after * at %C not allowed without I/O list");
4221 gfc_current_locus
= where
;
4224 gfc_current_locus
= where
;
4227 if (gfc_current_form
== FORM_FREE
)
4229 char c
= gfc_peek_ascii_char ();
4230 if (c
!= ' ' && c
!= '*' && c
!= '\'' && c
!= '"')
4237 m
= match_dt_format (dt
);
4238 if (m
== MATCH_ERROR
)
4244 dt
->io_unit
= default_unit (k
);
4249 /* Before issuing an error for a malformed 'print (1,*)' type of
4250 error, check for a default-char-expr of the form ('(I0)'). */
4253 control
= gfc_current_locus
;
4256 /* Reset current locus to get the initial '(' in an expression. */
4257 gfc_current_locus
= where
;
4258 dt
->format_expr
= NULL
;
4259 m
= match_dt_format (dt
);
4261 if (m
== MATCH_ERROR
)
4263 if (m
== MATCH_NO
|| dt
->format_expr
== NULL
)
4267 dt
->io_unit
= default_unit (k
);
4272 /* Commit any pending symbols now so that when we undo
4273 symbols later we wont lose them. */
4274 gfc_commit_symbols ();
4275 /* Reset current locus to get the initial '(' in an expression. */
4276 gfc_current_locus
= where
;
4277 dt
->format_expr
= NULL
;
4278 m
= gfc_match_expr (&dt
->format_expr
);
4282 && dt
->format_expr
->ts
.type
== BT_CHARACTER
)
4285 dt
->io_unit
= default_unit (k
);
4290 gfc_free_expr (dt
->format_expr
);
4291 dt
->format_expr
= NULL
;
4292 gfc_current_locus
= control
;
4298 gfc_undo_symbols ();
4299 gfc_free_expr (dt
->format_expr
);
4300 dt
->format_expr
= NULL
;
4301 gfc_current_locus
= control
;
4307 /* Match a control list */
4308 if (match_dt_element (k
, dt
) == MATCH_YES
)
4310 if (match_dt_unit (k
, dt
) != MATCH_YES
)
4313 if (gfc_match_char (')') == MATCH_YES
)
4315 if (gfc_match_char (',') != MATCH_YES
)
4318 m
= match_dt_element (k
, dt
);
4321 if (m
== MATCH_ERROR
)
4324 m
= match_dt_format (dt
);
4327 if (m
== MATCH_ERROR
)
4330 where
= gfc_current_locus
;
4332 m
= gfc_match_name (name
);
4335 gfc_find_symbol (name
, NULL
, 1, &sym
);
4336 if (sym
&& sym
->attr
.flavor
== FL_NAMELIST
)
4339 if (k
== M_READ
&& check_namelist (sym
))
4348 gfc_current_locus
= where
;
4350 goto loop
; /* No matches, try regular elements */
4353 if (gfc_match_char (')') == MATCH_YES
)
4355 if (gfc_match_char (',') != MATCH_YES
)
4361 m
= match_dt_element (k
, dt
);
4364 if (m
== MATCH_ERROR
)
4367 if (gfc_match_char (')') == MATCH_YES
)
4369 if (gfc_match_char (',') != MATCH_YES
)
4375 /* Save the IO kind for later use. */
4376 dt
->dt_io_kind
= gfc_get_iokind_expr (&gfc_current_locus
, k
);
4378 /* Optional leading comma (non-standard). We use a gfc_expr structure here
4379 to save the locus. This is used later when resolving transfer statements
4380 that might have a format expression without unit number. */
4381 if (!comma_flag
&& gfc_match_char (',') == MATCH_YES
)
4382 dt
->extra_comma
= dt
->dt_io_kind
;
4385 if (gfc_match_eos () != MATCH_YES
)
4387 if (comma_flag
&& gfc_match_char (',') != MATCH_YES
)
4389 gfc_error ("Expected comma in I/O list at %C");
4394 m
= match_io_list (k
, &io_code
);
4395 if (m
== MATCH_ERROR
)
4401 /* See if we want to use defaults for missing exponents in real transfers
4402 and other DEC runtime extensions. */
4403 if (flag_dec_format_defaults
)
4406 /* Check the format string now. */
4408 && (!gfc_simplify_expr (dt
->format_expr
, 0)
4409 || !check_format_string (dt
->format_expr
, k
== M_READ
)))
4412 new_st
.op
= (k
== M_READ
) ? EXEC_READ
: EXEC_WRITE
;
4414 new_st
.block
= gfc_get_code (new_st
.op
);
4415 new_st
.block
->next
= io_code
;
4417 terminate_io (io_code
);
4422 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
4432 gfc_match_read (void)
4434 return match_io (M_READ
);
4439 gfc_match_write (void)
4441 return match_io (M_WRITE
);
4446 gfc_match_print (void)
4450 m
= match_io (M_PRINT
);
4454 if (gfc_pure (NULL
))
4456 gfc_error ("PRINT statement at %C not allowed within PURE procedure");
4460 gfc_unset_implicit_pure (NULL
);
4466 /* Free a gfc_inquire structure. */
4469 gfc_free_inquire (gfc_inquire
*inquire
)
4472 if (inquire
== NULL
)
4475 gfc_free_expr (inquire
->unit
);
4476 gfc_free_expr (inquire
->file
);
4477 gfc_free_expr (inquire
->iomsg
);
4478 gfc_free_expr (inquire
->iostat
);
4479 gfc_free_expr (inquire
->exist
);
4480 gfc_free_expr (inquire
->opened
);
4481 gfc_free_expr (inquire
->number
);
4482 gfc_free_expr (inquire
->named
);
4483 gfc_free_expr (inquire
->name
);
4484 gfc_free_expr (inquire
->access
);
4485 gfc_free_expr (inquire
->sequential
);
4486 gfc_free_expr (inquire
->direct
);
4487 gfc_free_expr (inquire
->form
);
4488 gfc_free_expr (inquire
->formatted
);
4489 gfc_free_expr (inquire
->unformatted
);
4490 gfc_free_expr (inquire
->recl
);
4491 gfc_free_expr (inquire
->nextrec
);
4492 gfc_free_expr (inquire
->blank
);
4493 gfc_free_expr (inquire
->position
);
4494 gfc_free_expr (inquire
->action
);
4495 gfc_free_expr (inquire
->read
);
4496 gfc_free_expr (inquire
->write
);
4497 gfc_free_expr (inquire
->readwrite
);
4498 gfc_free_expr (inquire
->delim
);
4499 gfc_free_expr (inquire
->encoding
);
4500 gfc_free_expr (inquire
->pad
);
4501 gfc_free_expr (inquire
->iolength
);
4502 gfc_free_expr (inquire
->convert
);
4503 gfc_free_expr (inquire
->strm_pos
);
4504 gfc_free_expr (inquire
->asynchronous
);
4505 gfc_free_expr (inquire
->decimal
);
4506 gfc_free_expr (inquire
->pending
);
4507 gfc_free_expr (inquire
->id
);
4508 gfc_free_expr (inquire
->sign
);
4509 gfc_free_expr (inquire
->size
);
4510 gfc_free_expr (inquire
->round
);
4511 gfc_free_expr (inquire
->share
);
4512 gfc_free_expr (inquire
->cc
);
4517 /* Match an element of an INQUIRE statement. */
4519 #define RETM if (m != MATCH_NO) return m;
4522 match_inquire_element (gfc_inquire
*inquire
)
4526 m
= match_etag (&tag_unit
, &inquire
->unit
);
4527 RETM m
= match_etag (&tag_file
, &inquire
->file
);
4528 RETM m
= match_ltag (&tag_err
, &inquire
->err
);
4529 RETM m
= match_etag (&tag_iomsg
, &inquire
->iomsg
);
4530 RETM m
= match_out_tag (&tag_iostat
, &inquire
->iostat
);
4531 RETM m
= match_vtag (&tag_exist
, &inquire
->exist
);
4532 RETM m
= match_vtag (&tag_opened
, &inquire
->opened
);
4533 RETM m
= match_vtag (&tag_named
, &inquire
->named
);
4534 RETM m
= match_vtag (&tag_name
, &inquire
->name
);
4535 RETM m
= match_out_tag (&tag_number
, &inquire
->number
);
4536 RETM m
= match_vtag (&tag_s_access
, &inquire
->access
);
4537 RETM m
= match_vtag (&tag_sequential
, &inquire
->sequential
);
4538 RETM m
= match_vtag (&tag_direct
, &inquire
->direct
);
4539 RETM m
= match_vtag (&tag_s_form
, &inquire
->form
);
4540 RETM m
= match_vtag (&tag_formatted
, &inquire
->formatted
);
4541 RETM m
= match_vtag (&tag_unformatted
, &inquire
->unformatted
);
4542 RETM m
= match_out_tag (&tag_s_recl
, &inquire
->recl
);
4543 RETM m
= match_out_tag (&tag_nextrec
, &inquire
->nextrec
);
4544 RETM m
= match_vtag (&tag_s_blank
, &inquire
->blank
);
4545 RETM m
= match_vtag (&tag_s_position
, &inquire
->position
);
4546 RETM m
= match_vtag (&tag_s_action
, &inquire
->action
);
4547 RETM m
= match_vtag (&tag_read
, &inquire
->read
);
4548 RETM m
= match_vtag (&tag_write
, &inquire
->write
);
4549 RETM m
= match_vtag (&tag_readwrite
, &inquire
->readwrite
);
4550 RETM m
= match_vtag (&tag_s_async
, &inquire
->asynchronous
);
4551 RETM m
= match_vtag (&tag_s_delim
, &inquire
->delim
);
4552 RETM m
= match_vtag (&tag_s_decimal
, &inquire
->decimal
);
4553 RETM m
= match_out_tag (&tag_size
, &inquire
->size
);
4554 RETM m
= match_vtag (&tag_s_encoding
, &inquire
->encoding
);
4555 RETM m
= match_vtag (&tag_s_round
, &inquire
->round
);
4556 RETM m
= match_vtag (&tag_s_sign
, &inquire
->sign
);
4557 RETM m
= match_vtag (&tag_s_pad
, &inquire
->pad
);
4558 RETM m
= match_out_tag (&tag_iolength
, &inquire
->iolength
);
4559 RETM m
= match_vtag (&tag_convert
, &inquire
->convert
);
4560 RETM m
= match_out_tag (&tag_strm_out
, &inquire
->strm_pos
);
4561 RETM m
= match_vtag (&tag_pending
, &inquire
->pending
);
4562 RETM m
= match_vtag (&tag_id
, &inquire
->id
);
4563 RETM m
= match_vtag (&tag_s_iqstream
, &inquire
->iqstream
);
4564 RETM m
= match_dec_vtag (&tag_v_share
, &inquire
->share
);
4565 RETM m
= match_dec_vtag (&tag_v_cc
, &inquire
->cc
);
4566 RETM
return MATCH_NO
;
4573 gfc_match_inquire (void)
4575 gfc_inquire
*inquire
;
4580 m
= gfc_match_char ('(');
4584 inquire
= XCNEW (gfc_inquire
);
4586 loc
= gfc_current_locus
;
4588 m
= match_inquire_element (inquire
);
4589 if (m
== MATCH_ERROR
)
4593 m
= gfc_match_expr (&inquire
->unit
);
4594 if (m
== MATCH_ERROR
)
4600 /* See if we have the IOLENGTH form of the inquire statement. */
4601 if (inquire
->iolength
!= NULL
)
4603 if (gfc_match_char (')') != MATCH_YES
)
4606 m
= match_io_list (M_INQUIRE
, &code
);
4607 if (m
== MATCH_ERROR
)
4612 for (gfc_code
*c
= code
; c
; c
= c
->next
)
4613 if (c
->expr1
&& c
->expr1
->expr_type
== EXPR_FUNCTION
4614 && c
->expr1
->symtree
&& c
->expr1
->symtree
->n
.sym
->attr
.function
4615 && !c
->expr1
->symtree
->n
.sym
->attr
.external
4616 && strcmp (c
->expr1
->symtree
->name
, "null") == 0)
4618 gfc_error ("NULL() near %L cannot appear in INQUIRE statement",
4623 new_st
.op
= EXEC_IOLENGTH
;
4624 new_st
.expr1
= inquire
->iolength
;
4625 new_st
.ext
.inquire
= inquire
;
4627 if (gfc_pure (NULL
))
4629 gfc_free_statements (code
);
4630 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4634 gfc_unset_implicit_pure (NULL
);
4636 new_st
.block
= gfc_get_code (EXEC_IOLENGTH
);
4637 terminate_io (code
);
4638 new_st
.block
->next
= code
;
4642 /* At this point, we have the non-IOLENGTH inquire statement. */
4645 if (gfc_match_char (')') == MATCH_YES
)
4647 if (gfc_match_char (',') != MATCH_YES
)
4650 m
= match_inquire_element (inquire
);
4651 if (m
== MATCH_ERROR
)
4656 if (inquire
->iolength
!= NULL
)
4658 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
4663 if (gfc_match_eos () != MATCH_YES
)
4666 if (inquire
->unit
!= NULL
&& inquire
->file
!= NULL
)
4668 gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
4669 "UNIT specifiers", &loc
);
4673 if (inquire
->unit
== NULL
&& inquire
->file
== NULL
)
4675 gfc_error ("INQUIRE statement at %L requires either FILE or "
4676 "UNIT specifier", &loc
);
4680 if (inquire
->unit
!= NULL
&& inquire
->unit
->expr_type
== EXPR_CONSTANT
4681 && inquire
->unit
->ts
.type
== BT_INTEGER
4682 && ((mpz_get_si (inquire
->unit
->value
.integer
) == GFC_INTERNAL_UNIT4
)
4683 || (mpz_get_si (inquire
->unit
->value
.integer
) == GFC_INTERNAL_UNIT
)))
4685 gfc_error ("UNIT number in INQUIRE statement at %L cannot "
4686 "be %d", &loc
, (int) mpz_get_si (inquire
->unit
->value
.integer
));
4690 if (gfc_pure (NULL
))
4692 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4696 gfc_unset_implicit_pure (NULL
);
4698 if (inquire
->id
!= NULL
&& inquire
->pending
== NULL
)
4700 gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
4701 "the ID= specifier", &loc
);
4705 new_st
.op
= EXEC_INQUIRE
;
4706 new_st
.ext
.inquire
= inquire
;
4710 gfc_syntax_error (ST_INQUIRE
);
4713 gfc_free_inquire (inquire
);
4718 /* Resolve everything in a gfc_inquire structure. */
4721 gfc_resolve_inquire (gfc_inquire
*inquire
)
4723 RESOLVE_TAG (&tag_unit
, inquire
->unit
);
4724 RESOLVE_TAG (&tag_file
, inquire
->file
);
4725 RESOLVE_TAG (&tag_id
, inquire
->id
);
4727 /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4728 contexts. Thus, use an extended RESOLVE_TAG macro for that. */
4729 #define INQUIRE_RESOLVE_TAG(tag, expr) \
4730 RESOLVE_TAG (tag, expr); \
4734 sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
4735 if (gfc_check_vardef_context ((expr), false, false, false, \
4736 context) == false) \
4739 INQUIRE_RESOLVE_TAG (&tag_iomsg
, inquire
->iomsg
);
4740 INQUIRE_RESOLVE_TAG (&tag_iostat
, inquire
->iostat
);
4741 INQUIRE_RESOLVE_TAG (&tag_exist
, inquire
->exist
);
4742 INQUIRE_RESOLVE_TAG (&tag_opened
, inquire
->opened
);
4743 INQUIRE_RESOLVE_TAG (&tag_number
, inquire
->number
);
4744 INQUIRE_RESOLVE_TAG (&tag_named
, inquire
->named
);
4745 INQUIRE_RESOLVE_TAG (&tag_name
, inquire
->name
);
4746 INQUIRE_RESOLVE_TAG (&tag_s_access
, inquire
->access
);
4747 INQUIRE_RESOLVE_TAG (&tag_sequential
, inquire
->sequential
);
4748 INQUIRE_RESOLVE_TAG (&tag_direct
, inquire
->direct
);
4749 INQUIRE_RESOLVE_TAG (&tag_s_form
, inquire
->form
);
4750 INQUIRE_RESOLVE_TAG (&tag_formatted
, inquire
->formatted
);
4751 INQUIRE_RESOLVE_TAG (&tag_unformatted
, inquire
->unformatted
);
4752 INQUIRE_RESOLVE_TAG (&tag_s_recl
, inquire
->recl
);
4753 INQUIRE_RESOLVE_TAG (&tag_nextrec
, inquire
->nextrec
);
4754 INQUIRE_RESOLVE_TAG (&tag_s_blank
, inquire
->blank
);
4755 INQUIRE_RESOLVE_TAG (&tag_s_position
, inquire
->position
);
4756 INQUIRE_RESOLVE_TAG (&tag_s_action
, inquire
->action
);
4757 INQUIRE_RESOLVE_TAG (&tag_read
, inquire
->read
);
4758 INQUIRE_RESOLVE_TAG (&tag_write
, inquire
->write
);
4759 INQUIRE_RESOLVE_TAG (&tag_readwrite
, inquire
->readwrite
);
4760 INQUIRE_RESOLVE_TAG (&tag_s_delim
, inquire
->delim
);
4761 INQUIRE_RESOLVE_TAG (&tag_s_pad
, inquire
->pad
);
4762 INQUIRE_RESOLVE_TAG (&tag_s_encoding
, inquire
->encoding
);
4763 INQUIRE_RESOLVE_TAG (&tag_s_round
, inquire
->round
);
4764 INQUIRE_RESOLVE_TAG (&tag_iolength
, inquire
->iolength
);
4765 INQUIRE_RESOLVE_TAG (&tag_convert
, inquire
->convert
);
4766 INQUIRE_RESOLVE_TAG (&tag_strm_out
, inquire
->strm_pos
);
4767 INQUIRE_RESOLVE_TAG (&tag_s_async
, inquire
->asynchronous
);
4768 INQUIRE_RESOLVE_TAG (&tag_s_sign
, inquire
->sign
);
4769 INQUIRE_RESOLVE_TAG (&tag_s_round
, inquire
->round
);
4770 INQUIRE_RESOLVE_TAG (&tag_pending
, inquire
->pending
);
4771 INQUIRE_RESOLVE_TAG (&tag_size
, inquire
->size
);
4772 INQUIRE_RESOLVE_TAG (&tag_s_decimal
, inquire
->decimal
);
4773 INQUIRE_RESOLVE_TAG (&tag_s_iqstream
, inquire
->iqstream
);
4774 INQUIRE_RESOLVE_TAG (&tag_v_share
, inquire
->share
);
4775 INQUIRE_RESOLVE_TAG (&tag_v_cc
, inquire
->cc
);
4776 #undef INQUIRE_RESOLVE_TAG
4778 if (!gfc_reference_st_label (inquire
->err
, ST_LABEL_TARGET
))
4786 gfc_free_wait (gfc_wait
*wait
)
4791 gfc_free_expr (wait
->unit
);
4792 gfc_free_expr (wait
->iostat
);
4793 gfc_free_expr (wait
->iomsg
);
4794 gfc_free_expr (wait
->id
);
4800 gfc_resolve_wait (gfc_wait
*wait
)
4802 RESOLVE_TAG (&tag_unit
, wait
->unit
);
4803 RESOLVE_TAG (&tag_iomsg
, wait
->iomsg
);
4804 RESOLVE_TAG (&tag_iostat
, wait
->iostat
);
4805 RESOLVE_TAG (&tag_id
, wait
->id
);
4807 if (!gfc_reference_st_label (wait
->err
, ST_LABEL_TARGET
))
4810 if (!gfc_reference_st_label (wait
->end
, ST_LABEL_TARGET
))
4816 /* Match an element of a WAIT statement. */
4818 #define RETM if (m != MATCH_NO) return m;
4821 match_wait_element (gfc_wait
*wait
)
4825 m
= match_etag (&tag_unit
, &wait
->unit
);
4826 RETM m
= match_ltag (&tag_err
, &wait
->err
);
4827 RETM m
= match_ltag (&tag_end
, &wait
->end
);
4828 RETM m
= match_ltag (&tag_eor
, &wait
->eor
);
4829 RETM m
= match_etag (&tag_iomsg
, &wait
->iomsg
);
4830 RETM m
= match_out_tag (&tag_iostat
, &wait
->iostat
);
4831 RETM m
= match_etag (&tag_id
, &wait
->id
);
4832 RETM
return MATCH_NO
;
4839 gfc_match_wait (void)
4844 m
= gfc_match_char ('(');
4848 wait
= XCNEW (gfc_wait
);
4850 m
= match_wait_element (wait
);
4851 if (m
== MATCH_ERROR
)
4855 m
= gfc_match_expr (&wait
->unit
);
4856 if (m
== MATCH_ERROR
)
4864 if (gfc_match_char (')') == MATCH_YES
)
4866 if (gfc_match_char (',') != MATCH_YES
)
4869 m
= match_wait_element (wait
);
4870 if (m
== MATCH_ERROR
)
4876 if (!gfc_notify_std (GFC_STD_F2003
, "WAIT at %C "
4877 "not allowed in Fortran 95"))
4880 if (gfc_pure (NULL
))
4882 gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4886 gfc_unset_implicit_pure (NULL
);
4888 new_st
.op
= EXEC_WAIT
;
4889 new_st
.ext
.wait
= wait
;
4894 gfc_syntax_error (ST_WAIT
);
4897 gfc_free_wait (wait
);