1 /* Deal with I/O statements & related stuff.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
30 format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL,
35 const char *name, *spec, *value;
41 tag_file = {"FILE", " file =", " %e", BT_CHARACTER },
42 tag_status = {"STATUS", " status =", " %e", BT_CHARACTER},
43 tag_e_access = {"ACCESS", " access =", " %e", BT_CHARACTER},
44 tag_e_form = {"FORM", " form =", " %e", BT_CHARACTER},
45 tag_e_recl = {"RECL", " recl =", " %e", BT_INTEGER},
46 tag_e_blank = {"BLANK", " blank =", " %e", BT_CHARACTER},
47 tag_e_position = {"POSITION", " position =", " %e", BT_CHARACTER},
48 tag_e_action = {"ACTION", " action =", " %e", BT_CHARACTER},
49 tag_e_delim = {"DELIM", " delim =", " %e", BT_CHARACTER},
50 tag_e_pad = {"PAD", " pad =", " %e", BT_CHARACTER},
51 tag_e_decimal = {"DECIMAL", " decimal =", " %e", BT_CHARACTER},
52 tag_e_encoding = {"ENCODING", " encoding =", " %e", BT_CHARACTER},
53 tag_e_async = {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER},
54 tag_e_round = {"ROUND", " round =", " %e", BT_CHARACTER},
55 tag_e_sign = {"SIGN", " sign =", " %e", BT_CHARACTER},
56 tag_unit = {"UNIT", " unit =", " %e", BT_INTEGER},
57 tag_advance = {"ADVANCE", " advance =", " %e", BT_CHARACTER},
58 tag_rec = {"REC", " rec =", " %e", BT_INTEGER},
59 tag_spos = {"POSITION", " pos =", " %e", BT_INTEGER},
60 tag_format = {"FORMAT", NULL, NULL, BT_CHARACTER},
61 tag_iomsg = {"IOMSG", " iomsg =", " %e", BT_CHARACTER},
62 tag_iostat = {"IOSTAT", " iostat =", " %v", BT_INTEGER},
63 tag_size = {"SIZE", " size =", " %v", BT_INTEGER},
64 tag_exist = {"EXIST", " exist =", " %v", BT_LOGICAL},
65 tag_opened = {"OPENED", " opened =", " %v", BT_LOGICAL},
66 tag_named = {"NAMED", " named =", " %v", BT_LOGICAL},
67 tag_name = {"NAME", " name =", " %v", BT_CHARACTER},
68 tag_number = {"NUMBER", " number =", " %v", BT_INTEGER},
69 tag_s_access = {"ACCESS", " access =", " %v", BT_CHARACTER},
70 tag_sequential = {"SEQUENTIAL", " sequential =", " %v", BT_CHARACTER},
71 tag_direct = {"DIRECT", " direct =", " %v", BT_CHARACTER},
72 tag_s_form = {"FORM", " form =", " %v", BT_CHARACTER},
73 tag_formatted = {"FORMATTED", " formatted =", " %v", BT_CHARACTER},
74 tag_unformatted = {"UNFORMATTED", " unformatted =", " %v", BT_CHARACTER},
75 tag_s_recl = {"RECL", " recl =", " %v", BT_INTEGER},
76 tag_nextrec = {"NEXTREC", " nextrec =", " %v", BT_INTEGER},
77 tag_s_blank = {"BLANK", " blank =", " %v", BT_CHARACTER},
78 tag_s_position = {"POSITION", " position =", " %v", BT_CHARACTER},
79 tag_s_action = {"ACTION", " action =", " %v", BT_CHARACTER},
80 tag_read = {"READ", " read =", " %v", BT_CHARACTER},
81 tag_write = {"WRITE", " write =", " %v", BT_CHARACTER},
82 tag_readwrite = {"READWRITE", " readwrite =", " %v", BT_CHARACTER},
83 tag_s_delim = {"DELIM", " delim =", " %v", BT_CHARACTER},
84 tag_s_pad = {"PAD", " pad =", " %v", BT_CHARACTER},
85 tag_s_decimal = {"DECIMAL", " decimal =", " %v", BT_CHARACTER},
86 tag_s_encoding = {"ENCODING", " encoding =", " %v", BT_CHARACTER},
87 tag_s_async = {"ASYNCHRONOUS", " asynchronous =", " %v", BT_CHARACTER},
88 tag_s_round = {"ROUND", " round =", " %v", BT_CHARACTER},
89 tag_s_sign = {"SIGN", " sign =", " %v", BT_CHARACTER},
90 tag_iolength = {"IOLENGTH", " iolength =", " %v", BT_INTEGER},
91 tag_convert = {"CONVERT", " convert =", " %e", BT_CHARACTER},
92 tag_strm_out = {"POS", " pos =", " %v", BT_INTEGER},
93 tag_err = {"ERR", " err =", " %l", BT_UNKNOWN},
94 tag_end = {"END", " end =", " %l", BT_UNKNOWN},
95 tag_eor = {"EOR", " eor =", " %l", BT_UNKNOWN},
96 tag_id = {"ID", " id =", " %v", BT_INTEGER},
97 tag_pending = {"PENDING", " pending =", " %v", BT_LOGICAL},
98 tag_newunit = {"NEWUNIT", " newunit =", " %v", BT_INTEGER};
100 static gfc_dt *current_dt;
102 #define RESOLVE_TAG(x, y) if (resolve_tag(x, y) == FAILURE) return FAILURE;
105 /**************** Fortran 95 FORMAT parser *****************/
107 /* FORMAT tokens returned by format_lex(). */
110 FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
111 FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN,
112 FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F,
113 FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END,
114 FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC,
115 FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ
119 /* Local variables for checking format strings. The saved_token is
120 used to back up by a single format token during the parsing
122 static gfc_char_t *format_string;
123 static int format_string_pos;
124 static int format_length, use_last_char;
125 static char error_element;
126 static locus format_locus;
128 static format_token saved_token;
131 { MODE_STRING, MODE_FORMAT, MODE_COPY }
135 /* Return the next character in the format string. */
138 next_char (int in_string)
150 if (mode == MODE_STRING)
151 c = *format_string++;
154 c = gfc_next_char_literal (in_string);
159 if (gfc_option.flag_backslash && c == '\\')
161 locus old_locus = gfc_current_locus;
163 if (gfc_match_special_char (&c) == MATCH_NO)
164 gfc_current_locus = old_locus;
166 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
167 gfc_warning ("Extension: backslash character at %C");
170 if (mode == MODE_COPY)
171 *format_string++ = c;
173 if (mode != MODE_STRING)
174 format_locus = gfc_current_locus;
178 c = gfc_wide_toupper (c);
183 /* Back up one character position. Only works once. */
191 /* Eat up the spaces and return a character. */
194 next_char_not_space (bool *error)
199 error_element = c = next_char (0);
202 if (gfc_option.allow_std & GFC_STD_GNU)
203 gfc_warning ("Extension: Tab character in format at %C");
206 gfc_error ("Extension: 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
230 if (saved_token != FMT_NONE)
233 saved_token = FMT_NONE;
237 c = next_char_not_space (&error);
245 c = next_char_not_space (&error);
256 c = next_char_not_space (&error);
258 value = 10 * value + c - '0';
267 token = FMT_SIGNED_INT;
286 c = next_char_not_space (&error);
289 value = 10 * value + c - '0';
297 token = zflag ? FMT_ZERO : FMT_POSINT;
321 c = next_char_not_space (&error);
349 c = next_char_not_space (&error);
350 if (c != 'P' && c != 'S')
357 c = next_char_not_space (&error);
358 if (c == 'N' || c == 'Z')
419 c = next_char_not_space (&error);
449 c = next_char_not_space (&error);
452 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DP format "
453 "specifier not allowed at %C") == FAILURE)
459 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DC format "
460 "specifier not allowed at %C") == FAILURE)
472 c = next_char_not_space (&error);
521 token_to_string (format_token t)
540 /* Check a format statement. The format string, either from a FORMAT
541 statement or a constant in an I/O statement has already been parsed
542 by itself, and we are checking it for validity. The dual origin
543 means that the warning message is a little less than great. */
546 check_format (bool is_input)
548 const char *posint_required = _("Positive width required");
549 const char *nonneg_required = _("Nonnegative width required");
550 const char *unexpected_element = _("Unexpected element '%c' in format string"
552 const char *unexpected_end = _("Unexpected end of format string");
553 const char *zero_width = _("Zero width in format descriptor");
562 saved_token = FMT_NONE;
566 format_string_pos = 0;
573 error = _("Missing leading left parenthesis");
581 goto finished; /* Empty format is legal */
585 /* In this state, the next thing has to be a format item. */
602 error = _("Left parenthesis required after '*'");
627 /* Signed integer can only precede a P format. */
633 error = _("Expected P edit descriptor");
640 /* P requires a prior number. */
641 error = _("P descriptor requires leading scale factor");
645 /* X requires a prior number if we're being pedantic. */
646 if (mode != MODE_FORMAT)
647 format_locus.nextc += format_string_pos;
648 if (gfc_notify_std (GFC_STD_GNU, "Extension: X descriptor "
649 "requires leading space count at %L", &format_locus)
667 goto extension_optional_comma;
678 if (gfc_notify_std (GFC_STD_GNU, "Extension: $ descriptor at %L",
679 &format_locus) == FAILURE)
681 if (t != FMT_RPAREN || level > 0)
683 gfc_warning ("$ should be the last specifier in format at %L",
685 goto optional_comma_1;
706 error = unexpected_end;
710 error = unexpected_element;
715 /* In this state, t must currently be a data descriptor.
716 Deal with things that can/must follow the descriptor. */
727 /* No comma after P allowed only for F, E, EN, ES, D, or G.
732 if (gfc_option.allow_std < GFC_STD_F2003 && t != FMT_COMMA
733 && t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES
734 && t != FMT_D && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH)
736 error = _("Comma required after P descriptor");
747 if (t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES && t != FMT_D
748 && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH)
750 error = _("Comma required after P descriptor");
764 error = _("Positive width required with T descriptor");
776 switch (gfc_notification_std (GFC_STD_GNU))
779 if (mode != MODE_FORMAT)
780 format_locus.nextc += format_string_pos;
781 gfc_warning ("Extension: Missing positive width after L "
782 "descriptor at %L", &format_locus);
787 error = posint_required;
818 if (t == FMT_G && u == FMT_ZERO)
825 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: 'G0' in "
826 "format at %L", &format_locus) == FAILURE)
837 error = posint_required;
843 error = _("E specifier not allowed with g0 descriptor");
852 format_locus.nextc += format_string_pos;
853 gfc_error_now ("Positive width required in format "
854 "specifier %s at %L", token_to_string (t),
865 /* Warn if -std=legacy, otherwise error. */
866 format_locus.nextc += format_string_pos;
867 if (gfc_option.warn_std != 0)
869 gfc_error_now ("Period required in format "
870 "specifier %s at %L", token_to_string (t),
876 gfc_warning ("Period required in format "
877 "specifier %s at %L", token_to_string (t),
879 /* If we go to finished, we need to unwind this
880 before the next round. */
881 format_locus.nextc -= format_string_pos;
889 if (u != FMT_ZERO && u != FMT_POSINT)
891 error = nonneg_required;
898 /* Look for optional exponent. */
913 error = _("Positive exponent width required");
924 if (t != FMT_ZERO && t != FMT_POSINT)
926 error = nonneg_required;
929 else if (is_input && t == FMT_ZERO)
931 error = posint_required;
940 /* Warn if -std=legacy, otherwise error. */
941 if (gfc_option.warn_std != 0)
943 error = _("Period required in format specifier");
946 if (mode != MODE_FORMAT)
947 format_locus.nextc += format_string_pos;
948 gfc_warning ("Period required in format specifier at %L",
957 if (t != FMT_ZERO && t != FMT_POSINT)
959 error = nonneg_required;
966 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
968 if (mode != MODE_FORMAT)
969 format_locus.nextc += format_string_pos;
970 gfc_warning ("The H format specifier at %L is"
971 " a Fortran 95 deleted feature", &format_locus);
974 if (mode == MODE_STRING)
976 format_string += value;
977 format_length -= value;
993 if (t != FMT_ZERO && t != FMT_POSINT)
995 error = nonneg_required;
998 else if (is_input && t == FMT_ZERO)
1000 error = posint_required;
1007 if (t != FMT_PERIOD)
1016 if (t != FMT_ZERO && t != FMT_POSINT)
1018 error = nonneg_required;
1026 error = unexpected_element;
1031 /* Between a descriptor and what comes next. */
1049 goto optional_comma;
1052 error = unexpected_end;
1056 if (mode != MODE_FORMAT)
1057 format_locus.nextc += format_string_pos - 1;
1058 if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %L",
1059 &format_locus) == FAILURE)
1061 /* If we do not actually return a failure, we need to unwind this
1062 before the next round. */
1063 if (mode != MODE_FORMAT)
1064 format_locus.nextc -= format_string_pos;
1069 /* Optional comma is a weird between state where we've just finished
1070 reading a colon, slash, dollar or P descriptor. */
1087 /* Assume that we have another format item. */
1094 extension_optional_comma:
1095 /* As a GNU extension, permit a missing comma after a string literal. */
1112 goto optional_comma;
1115 error = unexpected_end;
1119 if (mode != MODE_FORMAT)
1120 format_locus.nextc += format_string_pos;
1121 if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %L",
1122 &format_locus) == FAILURE)
1124 /* If we do not actually return a failure, we need to unwind this
1125 before the next round. */
1126 if (mode != MODE_FORMAT)
1127 format_locus.nextc -= format_string_pos;
1135 if (mode != MODE_FORMAT)
1136 format_locus.nextc += format_string_pos;
1137 if (error == unexpected_element)
1138 gfc_error (error, error_element, &format_locus);
1140 gfc_error ("%s in format string at %L", error, &format_locus);
1149 /* Given an expression node that is a constant string, see if it looks
1150 like a format string. */
1153 check_format_string (gfc_expr *e, bool is_input)
1155 if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1159 format_string = e->value.character.string;
1161 /* More elaborate measures are needed to show where a problem is within a
1162 format string that has been calculated, but that's probably not worth the
1164 format_locus = e->where;
1166 return check_format (is_input);
1170 /************ Fortran 95 I/O statement matchers *************/
1172 /* Match a FORMAT statement. This amounts to actually parsing the
1173 format descriptors in order to correctly locate the end of the
1177 gfc_match_format (void)
1182 if (gfc_current_ns->proc_name
1183 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
1185 gfc_error ("Format statement in module main block at %C");
1189 if (gfc_statement_label == NULL)
1191 gfc_error ("Missing format label at %C");
1194 gfc_gobble_whitespace ();
1199 start = gfc_current_locus;
1201 if (check_format (false) == FAILURE)
1204 if (gfc_match_eos () != MATCH_YES)
1206 gfc_syntax_error (ST_FORMAT);
1210 /* The label doesn't get created until after the statement is done
1211 being matched, so we have to leave the string for later. */
1213 gfc_current_locus = start; /* Back to the beginning */
1216 new_st.op = EXEC_NOP;
1219 e->expr_type = EXPR_CONSTANT;
1220 e->ts.type = BT_CHARACTER;
1221 e->ts.kind = gfc_default_character_kind;
1223 e->value.character.string = format_string
1224 = gfc_get_wide_string (format_length + 1);
1225 e->value.character.length = format_length;
1226 gfc_statement_label->format = e;
1229 check_format (false); /* Guaranteed to succeed */
1230 gfc_match_eos (); /* Guaranteed to succeed */
1236 /* Match an expression I/O tag of some sort. */
1239 match_etag (const io_tag *tag, gfc_expr **v)
1244 m = gfc_match (tag->spec);
1248 m = gfc_match (tag->value, &result);
1251 gfc_error ("Invalid value for %s specification at %C", tag->name);
1257 gfc_error ("Duplicate %s specification at %C", tag->name);
1258 gfc_free_expr (result);
1267 /* Match a variable I/O tag of some sort. */
1270 match_vtag (const io_tag *tag, gfc_expr **v)
1275 m = gfc_match (tag->spec);
1279 m = gfc_match (tag->value, &result);
1282 gfc_error ("Invalid value for %s specification at %C", tag->name);
1288 gfc_error ("Duplicate %s specification at %C", tag->name);
1289 gfc_free_expr (result);
1293 if (result->symtree->n.sym->attr.intent == INTENT_IN)
1295 gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag->name);
1296 gfc_free_expr (result);
1300 if (gfc_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
1302 gfc_error ("Variable %s cannot be assigned in PURE procedure at %C",
1304 gfc_free_expr (result);
1313 /* Match I/O tags that cause variables to become redefined. */
1316 match_out_tag (const io_tag *tag, gfc_expr **result)
1320 m = match_vtag (tag, result);
1322 gfc_check_do_variable ((*result)->symtree);
1328 /* Match a label I/O tag. */
1331 match_ltag (const io_tag *tag, gfc_st_label ** label)
1337 m = gfc_match (tag->spec);
1341 m = gfc_match (tag->value, label);
1344 gfc_error ("Invalid value for %s specification at %C", tag->name);
1350 gfc_error ("Duplicate %s label specification at %C", tag->name);
1354 if (gfc_reference_st_label (*label, ST_LABEL_TARGET) == FAILURE)
1361 /* Resolution of the FORMAT tag, to be called from resolve_tag. */
1364 resolve_tag_format (const gfc_expr *e)
1366 if (e->expr_type == EXPR_CONSTANT
1367 && (e->ts.type != BT_CHARACTER
1368 || e->ts.kind != gfc_default_character_kind))
1370 gfc_error ("Constant expression in FORMAT tag at %L must be "
1371 "of type default CHARACTER", &e->where);
1375 /* If e's rank is zero and e is not an element of an array, it should be
1376 of integer or character type. The integer variable should be
1379 && (e->expr_type != EXPR_VARIABLE
1380 || e->symtree == NULL
1381 || e->symtree->n.sym->as == NULL
1382 || e->symtree->n.sym->as->rank == 0))
1384 if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
1386 gfc_error ("FORMAT tag at %L must be of type CHARACTER or INTEGER",
1390 else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
1392 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGNED "
1393 "variable in FORMAT tag at %L", &e->where)
1396 if (e->symtree->n.sym->attr.assign != 1)
1398 gfc_error ("Variable '%s' at %L has not been assigned a "
1399 "format label", e->symtree->n.sym->name, &e->where);
1403 else if (e->ts.type == BT_INTEGER)
1405 gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
1406 "variable", gfc_basic_typename (e->ts.type), &e->where);
1413 /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
1414 It may be assigned an Hollerith constant. */
1415 if (e->ts.type != BT_CHARACTER)
1417 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character "
1418 "in FORMAT tag at %L", &e->where) == FAILURE)
1421 if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)
1423 gfc_error ("Non-character assumed shape array element in FORMAT"
1424 " tag at %L", &e->where);
1428 if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
1430 gfc_error ("Non-character assumed size array element in FORMAT"
1431 " tag at %L", &e->where);
1435 if (e->rank == 0 && e->symtree->n.sym->attr.pointer)
1437 gfc_error ("Non-character pointer array element in FORMAT tag at %L",
1447 /* Do expression resolution and type-checking on an expression tag. */
1450 resolve_tag (const io_tag *tag, gfc_expr *e)
1455 if (gfc_resolve_expr (e) == FAILURE)
1458 if (tag == &tag_format)
1459 return resolve_tag_format (e);
1461 if (e->ts.type != tag->type)
1463 gfc_error ("%s tag at %L must be of type %s", tag->name,
1464 &e->where, gfc_basic_typename (tag->type));
1470 gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
1474 if (tag == &tag_iomsg)
1476 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L",
1477 &e->where) == FAILURE)
1481 if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength)
1482 && e->ts.kind != gfc_default_integer_kind)
1484 if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
1485 "INTEGER in %s tag at %L", tag->name, &e->where)
1490 if (tag == &tag_convert)
1492 if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L",
1493 &e->where) == FAILURE)
1501 /* Match a single tag of an OPEN statement. */
1504 match_open_element (gfc_open *open)
1508 m = match_etag (&tag_e_async, &open->asynchronous);
1511 m = match_etag (&tag_unit, &open->unit);
1514 m = match_out_tag (&tag_iomsg, &open->iomsg);
1517 m = match_out_tag (&tag_iostat, &open->iostat);
1520 m = match_etag (&tag_file, &open->file);
1523 m = match_etag (&tag_status, &open->status);
1526 m = match_etag (&tag_e_access, &open->access);
1529 m = match_etag (&tag_e_form, &open->form);
1532 m = match_etag (&tag_e_recl, &open->recl);
1535 m = match_etag (&tag_e_blank, &open->blank);
1538 m = match_etag (&tag_e_position, &open->position);
1541 m = match_etag (&tag_e_action, &open->action);
1544 m = match_etag (&tag_e_delim, &open->delim);
1547 m = match_etag (&tag_e_pad, &open->pad);
1550 m = match_etag (&tag_e_decimal, &open->decimal);
1553 m = match_etag (&tag_e_encoding, &open->encoding);
1556 m = match_etag (&tag_e_round, &open->round);
1559 m = match_etag (&tag_e_sign, &open->sign);
1562 m = match_ltag (&tag_err, &open->err);
1565 m = match_etag (&tag_convert, &open->convert);
1568 m = match_out_tag (&tag_newunit, &open->newunit);
1576 /* Free the gfc_open structure and all the expressions it contains. */
1579 gfc_free_open (gfc_open *open)
1584 gfc_free_expr (open->unit);
1585 gfc_free_expr (open->iomsg);
1586 gfc_free_expr (open->iostat);
1587 gfc_free_expr (open->file);
1588 gfc_free_expr (open->status);
1589 gfc_free_expr (open->access);
1590 gfc_free_expr (open->form);
1591 gfc_free_expr (open->recl);
1592 gfc_free_expr (open->blank);
1593 gfc_free_expr (open->position);
1594 gfc_free_expr (open->action);
1595 gfc_free_expr (open->delim);
1596 gfc_free_expr (open->pad);
1597 gfc_free_expr (open->decimal);
1598 gfc_free_expr (open->encoding);
1599 gfc_free_expr (open->round);
1600 gfc_free_expr (open->sign);
1601 gfc_free_expr (open->convert);
1602 gfc_free_expr (open->asynchronous);
1603 gfc_free_expr (open->newunit);
1608 /* Resolve everything in a gfc_open structure. */
1611 gfc_resolve_open (gfc_open *open)
1614 RESOLVE_TAG (&tag_unit, open->unit);
1615 RESOLVE_TAG (&tag_iomsg, open->iomsg);
1616 RESOLVE_TAG (&tag_iostat, open->iostat);
1617 RESOLVE_TAG (&tag_file, open->file);
1618 RESOLVE_TAG (&tag_status, open->status);
1619 RESOLVE_TAG (&tag_e_access, open->access);
1620 RESOLVE_TAG (&tag_e_form, open->form);
1621 RESOLVE_TAG (&tag_e_recl, open->recl);
1622 RESOLVE_TAG (&tag_e_blank, open->blank);
1623 RESOLVE_TAG (&tag_e_position, open->position);
1624 RESOLVE_TAG (&tag_e_action, open->action);
1625 RESOLVE_TAG (&tag_e_delim, open->delim);
1626 RESOLVE_TAG (&tag_e_pad, open->pad);
1627 RESOLVE_TAG (&tag_e_decimal, open->decimal);
1628 RESOLVE_TAG (&tag_e_encoding, open->encoding);
1629 RESOLVE_TAG (&tag_e_async, open->asynchronous);
1630 RESOLVE_TAG (&tag_e_round, open->round);
1631 RESOLVE_TAG (&tag_e_sign, open->sign);
1632 RESOLVE_TAG (&tag_convert, open->convert);
1633 RESOLVE_TAG (&tag_newunit, open->newunit);
1635 if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
1642 /* Check if a given value for a SPECIFIER is either in the list of values
1643 allowed in F95 or F2003, issuing an error message and returning a zero
1644 value if it is not allowed. */
1647 compare_to_allowed_values (const char *specifier, const char *allowed[],
1648 const char *allowed_f2003[],
1649 const char *allowed_gnu[], gfc_char_t *value,
1650 const char *statement, bool warn)
1655 len = gfc_wide_strlen (value);
1658 for (len--; len > 0; len--)
1659 if (value[len] != ' ')
1664 for (i = 0; allowed[i]; i++)
1665 if (len == strlen (allowed[i])
1666 && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
1669 for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
1670 if (len == strlen (allowed_f2003[i])
1671 && gfc_wide_strncasecmp (value, allowed_f2003[i],
1672 strlen (allowed_f2003[i])) == 0)
1674 notification n = gfc_notification_std (GFC_STD_F2003);
1676 if (n == WARNING || (warn && n == ERROR))
1678 gfc_warning ("Fortran 2003: %s specifier in %s statement at %C "
1679 "has value '%s'", specifier, statement,
1686 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: %s specifier in "
1687 "%s statement at %C has value '%s'", specifier,
1688 statement, allowed_f2003[i]);
1696 for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
1697 if (len == strlen (allowed_gnu[i])
1698 && gfc_wide_strncasecmp (value, allowed_gnu[i],
1699 strlen (allowed_gnu[i])) == 0)
1701 notification n = gfc_notification_std (GFC_STD_GNU);
1703 if (n == WARNING || (warn && n == ERROR))
1705 gfc_warning ("Extension: %s specifier in %s statement at %C "
1706 "has value '%s'", specifier, statement,
1713 gfc_notify_std (GFC_STD_GNU, "Extension: %s specifier in "
1714 "%s statement at %C has value '%s'", specifier,
1715 statement, allowed_gnu[i]);
1725 char *s = gfc_widechar_to_char (value, -1);
1726 gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
1727 specifier, statement, s);
1733 char *s = gfc_widechar_to_char (value, -1);
1734 gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
1735 specifier, statement, s);
1742 /* Match an OPEN statement. */
1745 gfc_match_open (void)
1751 m = gfc_match_char ('(');
1755 open = XCNEW (gfc_open);
1757 m = match_open_element (open);
1759 if (m == MATCH_ERROR)
1763 m = gfc_match_expr (&open->unit);
1766 if (m == MATCH_ERROR)
1772 if (gfc_match_char (')') == MATCH_YES)
1774 if (gfc_match_char (',') != MATCH_YES)
1777 m = match_open_element (open);
1778 if (m == MATCH_ERROR)
1784 if (gfc_match_eos () == MATCH_NO)
1787 if (gfc_pure (NULL))
1789 gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1793 warn = (open->err || open->iostat) ? true : false;
1795 /* Checks on NEWUNIT specifier. */
1800 gfc_error ("UNIT specifier not allowed with NEWUNIT at %C");
1804 if (!(open->file || (open->status
1805 && gfc_wide_strncasecmp (open->status->value.character.string,
1806 "scratch", 7) == 0)))
1808 gfc_error ("NEWUNIT specifier must have FILE= "
1809 "or STATUS='scratch' at %C");
1814 /* Checks on the ACCESS specifier. */
1815 if (open->access && open->access->expr_type == EXPR_CONSTANT)
1817 static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
1818 static const char *access_f2003[] = { "STREAM", NULL };
1819 static const char *access_gnu[] = { "APPEND", NULL };
1821 if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
1823 open->access->value.character.string,
1828 /* Checks on the ACTION specifier. */
1829 if (open->action && open->action->expr_type == EXPR_CONSTANT)
1831 static const char *action[] = { "READ", "WRITE", "READWRITE", NULL };
1833 if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
1834 open->action->value.character.string,
1839 /* Checks on the ASYNCHRONOUS specifier. */
1840 if (open->asynchronous)
1842 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASYNCHRONOUS= at %C "
1843 "not allowed in Fortran 95") == FAILURE)
1846 if (open->asynchronous->expr_type == EXPR_CONSTANT)
1848 static const char * asynchronous[] = { "YES", "NO", NULL };
1850 if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous,
1851 NULL, NULL, open->asynchronous->value.character.string,
1857 /* Checks on the BLANK specifier. */
1860 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
1861 "not allowed in Fortran 95") == FAILURE)
1864 if (open->blank->expr_type == EXPR_CONSTANT)
1866 static const char *blank[] = { "ZERO", "NULL", NULL };
1868 if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
1869 open->blank->value.character.string,
1875 /* Checks on the DECIMAL specifier. */
1878 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
1879 "not allowed in Fortran 95") == FAILURE)
1882 if (open->decimal->expr_type == EXPR_CONSTANT)
1884 static const char * decimal[] = { "COMMA", "POINT", NULL };
1886 if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
1887 open->decimal->value.character.string,
1893 /* Checks on the DELIM specifier. */
1896 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
1897 "not allowed in Fortran 95") == FAILURE)
1900 if (open->delim->expr_type == EXPR_CONSTANT)
1902 static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
1904 if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
1905 open->delim->value.character.string,
1911 /* Checks on the ENCODING specifier. */
1914 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENCODING= at %C "
1915 "not allowed in Fortran 95") == FAILURE)
1918 if (open->encoding->expr_type == EXPR_CONSTANT)
1920 static const char * encoding[] = { "DEFAULT", "UTF-8", NULL };
1922 if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
1923 open->encoding->value.character.string,
1929 /* Checks on the FORM specifier. */
1930 if (open->form && open->form->expr_type == EXPR_CONSTANT)
1932 static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
1934 if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
1935 open->form->value.character.string,
1940 /* Checks on the PAD specifier. */
1941 if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
1943 static const char *pad[] = { "YES", "NO", NULL };
1945 if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
1946 open->pad->value.character.string,
1951 /* Checks on the POSITION specifier. */
1952 if (open->position && open->position->expr_type == EXPR_CONSTANT)
1954 static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
1956 if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
1957 open->position->value.character.string,
1962 /* Checks on the ROUND specifier. */
1965 if (gfc_notify_std (GFC_STD_F2003, "Fortran F2003: ROUND= at %C "
1966 "not allowed in Fortran 95") == FAILURE)
1969 if (open->round->expr_type == EXPR_CONSTANT)
1971 static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
1972 "COMPATIBLE", "PROCESSOR_DEFINED",
1975 if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
1976 open->round->value.character.string,
1982 /* Checks on the SIGN specifier. */
1985 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
1986 "not allowed in Fortran 95") == FAILURE)
1989 if (open->sign->expr_type == EXPR_CONSTANT)
1991 static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
1994 if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
1995 open->sign->value.character.string,
2001 #define warn_or_error(...) \
2004 gfc_warning (__VA_ARGS__); \
2007 gfc_error (__VA_ARGS__); \
2012 /* Checks on the RECL specifier. */
2013 if (open->recl && open->recl->expr_type == EXPR_CONSTANT
2014 && open->recl->ts.type == BT_INTEGER
2015 && mpz_sgn (open->recl->value.integer) != 1)
2017 warn_or_error ("RECL in OPEN statement at %C must be positive");
2020 /* Checks on the STATUS specifier. */
2021 if (open->status && open->status->expr_type == EXPR_CONSTANT)
2023 static const char *status[] = { "OLD", "NEW", "SCRATCH",
2024 "REPLACE", "UNKNOWN", NULL };
2026 if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2027 open->status->value.character.string,
2031 /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2032 the FILE= specifier shall appear. */
2033 if (open->file == NULL
2034 && (gfc_wide_strncasecmp (open->status->value.character.string,
2036 || gfc_wide_strncasecmp (open->status->value.character.string,
2039 char *s = gfc_widechar_to_char (open->status->value.character.string,
2041 warn_or_error ("The STATUS specified in OPEN statement at %C is "
2042 "'%s' and no FILE specifier is present", s);
2046 /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2047 the FILE= specifier shall not appear. */
2048 if (gfc_wide_strncasecmp (open->status->value.character.string,
2049 "scratch", 7) == 0 && open->file)
2051 warn_or_error ("The STATUS specified in OPEN statement at %C "
2052 "cannot have the value SCRATCH if a FILE specifier "
2057 /* Things that are not allowed for unformatted I/O. */
2058 if (open->form && open->form->expr_type == EXPR_CONSTANT
2059 && (open->delim || open->decimal || open->encoding || open->round
2060 || open->sign || open->pad || open->blank)
2061 && gfc_wide_strncasecmp (open->form->value.character.string,
2062 "unformatted", 11) == 0)
2064 const char *spec = (open->delim ? "DELIM "
2065 : (open->pad ? "PAD " : open->blank
2068 warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
2069 "unformatted I/O", spec);
2072 if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
2073 && gfc_wide_strncasecmp (open->access->value.character.string,
2076 warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
2081 && open->access && open->access->expr_type == EXPR_CONSTANT
2082 && !(gfc_wide_strncasecmp (open->access->value.character.string,
2083 "sequential", 10) == 0
2084 || gfc_wide_strncasecmp (open->access->value.character.string,
2086 || gfc_wide_strncasecmp (open->access->value.character.string,
2089 warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
2090 "for stream or sequential ACCESS");
2093 #undef warn_or_error
2095 new_st.op = EXEC_OPEN;
2096 new_st.ext.open = open;
2100 gfc_syntax_error (ST_OPEN);
2103 gfc_free_open (open);
2108 /* Free a gfc_close structure an all its expressions. */
2111 gfc_free_close (gfc_close *close)
2116 gfc_free_expr (close->unit);
2117 gfc_free_expr (close->iomsg);
2118 gfc_free_expr (close->iostat);
2119 gfc_free_expr (close->status);
2124 /* Match elements of a CLOSE statement. */
2127 match_close_element (gfc_close *close)
2131 m = match_etag (&tag_unit, &close->unit);
2134 m = match_etag (&tag_status, &close->status);
2137 m = match_out_tag (&tag_iomsg, &close->iomsg);
2140 m = match_out_tag (&tag_iostat, &close->iostat);
2143 m = match_ltag (&tag_err, &close->err);
2151 /* Match a CLOSE statement. */
2154 gfc_match_close (void)
2160 m = gfc_match_char ('(');
2164 close = XCNEW (gfc_close);
2166 m = match_close_element (close);
2168 if (m == MATCH_ERROR)
2172 m = gfc_match_expr (&close->unit);
2175 if (m == MATCH_ERROR)
2181 if (gfc_match_char (')') == MATCH_YES)
2183 if (gfc_match_char (',') != MATCH_YES)
2186 m = match_close_element (close);
2187 if (m == MATCH_ERROR)
2193 if (gfc_match_eos () == MATCH_NO)
2196 if (gfc_pure (NULL))
2198 gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2202 warn = (close->iostat || close->err) ? true : false;
2204 /* Checks on the STATUS specifier. */
2205 if (close->status && close->status->expr_type == EXPR_CONSTANT)
2207 static const char *status[] = { "KEEP", "DELETE", NULL };
2209 if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2210 close->status->value.character.string,
2215 new_st.op = EXEC_CLOSE;
2216 new_st.ext.close = close;
2220 gfc_syntax_error (ST_CLOSE);
2223 gfc_free_close (close);
2228 /* Resolve everything in a gfc_close structure. */
2231 gfc_resolve_close (gfc_close *close)
2233 RESOLVE_TAG (&tag_unit, close->unit);
2234 RESOLVE_TAG (&tag_iomsg, close->iomsg);
2235 RESOLVE_TAG (&tag_iostat, close->iostat);
2236 RESOLVE_TAG (&tag_status, close->status);
2238 if (gfc_reference_st_label (close->err, ST_LABEL_TARGET) == FAILURE)
2241 if (close->unit->expr_type == EXPR_CONSTANT
2242 && close->unit->ts.type == BT_INTEGER
2243 && mpz_sgn (close->unit->value.integer) < 0)
2245 gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2246 &close->unit->where);
2253 /* Free a gfc_filepos structure. */
2256 gfc_free_filepos (gfc_filepos *fp)
2258 gfc_free_expr (fp->unit);
2259 gfc_free_expr (fp->iomsg);
2260 gfc_free_expr (fp->iostat);
2265 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
2268 match_file_element (gfc_filepos *fp)
2272 m = match_etag (&tag_unit, &fp->unit);
2275 m = match_out_tag (&tag_iomsg, &fp->iomsg);
2278 m = match_out_tag (&tag_iostat, &fp->iostat);
2281 m = match_ltag (&tag_err, &fp->err);
2289 /* Match the second half of the file-positioning statements, REWIND,
2290 BACKSPACE, ENDFILE, or the FLUSH statement. */
2293 match_filepos (gfc_statement st, gfc_exec_op op)
2298 fp = XCNEW (gfc_filepos);
2300 if (gfc_match_char ('(') == MATCH_NO)
2302 m = gfc_match_expr (&fp->unit);
2303 if (m == MATCH_ERROR)
2311 m = match_file_element (fp);
2312 if (m == MATCH_ERROR)
2316 m = gfc_match_expr (&fp->unit);
2317 if (m == MATCH_ERROR)
2325 if (gfc_match_char (')') == MATCH_YES)
2327 if (gfc_match_char (',') != MATCH_YES)
2330 m = match_file_element (fp);
2331 if (m == MATCH_ERROR)
2338 if (gfc_match_eos () != MATCH_YES)
2341 if (gfc_pure (NULL))
2343 gfc_error ("%s statement not allowed in PURE procedure at %C",
2344 gfc_ascii_statement (st));
2350 new_st.ext.filepos = fp;
2354 gfc_syntax_error (st);
2357 gfc_free_filepos (fp);
2363 gfc_resolve_filepos (gfc_filepos *fp)
2365 RESOLVE_TAG (&tag_unit, fp->unit);
2366 RESOLVE_TAG (&tag_iostat, fp->iostat);
2367 RESOLVE_TAG (&tag_iomsg, fp->iomsg);
2368 if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE)
2371 if (fp->unit->expr_type == EXPR_CONSTANT
2372 && fp->unit->ts.type == BT_INTEGER
2373 && mpz_sgn (fp->unit->value.integer) < 0)
2375 gfc_error ("UNIT number in statement at %L must be non-negative",
2383 /* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2384 and the FLUSH statement. */
2387 gfc_match_endfile (void)
2389 return match_filepos (ST_END_FILE, EXEC_ENDFILE);
2393 gfc_match_backspace (void)
2395 return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
2399 gfc_match_rewind (void)
2401 return match_filepos (ST_REWIND, EXEC_REWIND);
2405 gfc_match_flush (void)
2407 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C")
2411 return match_filepos (ST_FLUSH, EXEC_FLUSH);
2414 /******************** Data Transfer Statements *********************/
2416 /* Return a default unit number. */
2419 default_unit (io_kind k)
2428 return gfc_int_expr (unit);
2432 /* Match a unit specification for a data transfer statement. */
2435 match_dt_unit (io_kind k, gfc_dt *dt)
2439 if (gfc_match_char ('*') == MATCH_YES)
2441 if (dt->io_unit != NULL)
2444 dt->io_unit = default_unit (k);
2448 if (gfc_match_expr (&e) == MATCH_YES)
2450 if (dt->io_unit != NULL)
2463 gfc_error ("Duplicate UNIT specification at %C");
2468 /* Match a format specification. */
2471 match_dt_format (gfc_dt *dt)
2475 gfc_st_label *label;
2478 where = gfc_current_locus;
2480 if (gfc_match_char ('*') == MATCH_YES)
2482 if (dt->format_expr != NULL || dt->format_label != NULL)
2485 dt->format_label = &format_asterisk;
2489 if ((m = gfc_match_st_label (&label)) == MATCH_YES)
2491 if (dt->format_expr != NULL || dt->format_label != NULL)
2493 gfc_free_st_label (label);
2497 if (gfc_reference_st_label (label, ST_LABEL_FORMAT) == FAILURE)
2500 dt->format_label = label;
2503 else if (m == MATCH_ERROR)
2504 /* The label was zero or too large. Emit the correct diagnosis. */
2507 if (gfc_match_expr (&e) == MATCH_YES)
2509 if (dt->format_expr != NULL || dt->format_label != NULL)
2514 dt->format_expr = e;
2518 gfc_current_locus = where; /* The only case where we have to restore */
2523 gfc_error ("Duplicate format specification at %C");
2528 /* Traverse a namelist that is part of a READ statement to make sure
2529 that none of the variables in the namelist are INTENT(IN). Returns
2530 nonzero if we find such a variable. */
2533 check_namelist (gfc_symbol *sym)
2537 for (p = sym->namelist; p; p = p->next)
2538 if (p->sym->attr.intent == INTENT_IN)
2540 gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
2541 p->sym->name, sym->name);
2549 /* Match a single data transfer element. */
2552 match_dt_element (io_kind k, gfc_dt *dt)
2554 char name[GFC_MAX_SYMBOL_LEN + 1];
2558 if (gfc_match (" unit =") == MATCH_YES)
2560 m = match_dt_unit (k, dt);
2565 if (gfc_match (" fmt =") == MATCH_YES)
2567 m = match_dt_format (dt);
2572 if (gfc_match (" nml = %n", name) == MATCH_YES)
2574 if (dt->namelist != NULL)
2576 gfc_error ("Duplicate NML specification at %C");
2580 if (gfc_find_symbol (name, NULL, 1, &sym))
2583 if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
2585 gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
2586 sym != NULL ? sym->name : name);
2591 if (k == M_READ && check_namelist (sym))
2597 m = match_etag (&tag_e_async, &dt->asynchronous);
2600 m = match_etag (&tag_e_blank, &dt->blank);
2603 m = match_etag (&tag_e_delim, &dt->delim);
2606 m = match_etag (&tag_e_pad, &dt->pad);
2609 m = match_etag (&tag_e_sign, &dt->sign);
2612 m = match_etag (&tag_e_round, &dt->round);
2615 m = match_out_tag (&tag_id, &dt->id);
2618 m = match_etag (&tag_e_decimal, &dt->decimal);
2621 m = match_etag (&tag_rec, &dt->rec);
2624 m = match_etag (&tag_spos, &dt->pos);
2627 m = match_out_tag (&tag_iomsg, &dt->iomsg);
2630 m = match_out_tag (&tag_iostat, &dt->iostat);
2633 m = match_ltag (&tag_err, &dt->err);
2635 dt->err_where = gfc_current_locus;
2638 m = match_etag (&tag_advance, &dt->advance);
2641 m = match_out_tag (&tag_size, &dt->size);
2645 m = match_ltag (&tag_end, &dt->end);
2650 gfc_error ("END tag at %C not allowed in output statement");
2653 dt->end_where = gfc_current_locus;
2658 m = match_ltag (&tag_eor, &dt->eor);
2660 dt->eor_where = gfc_current_locus;
2668 /* Free a data transfer structure and everything below it. */
2671 gfc_free_dt (gfc_dt *dt)
2676 gfc_free_expr (dt->io_unit);
2677 gfc_free_expr (dt->format_expr);
2678 gfc_free_expr (dt->rec);
2679 gfc_free_expr (dt->advance);
2680 gfc_free_expr (dt->iomsg);
2681 gfc_free_expr (dt->iostat);
2682 gfc_free_expr (dt->size);
2683 gfc_free_expr (dt->pad);
2684 gfc_free_expr (dt->delim);
2685 gfc_free_expr (dt->sign);
2686 gfc_free_expr (dt->round);
2687 gfc_free_expr (dt->blank);
2688 gfc_free_expr (dt->decimal);
2689 gfc_free_expr (dt->extra_comma);
2690 gfc_free_expr (dt->pos);
2695 /* Resolve everything in a gfc_dt structure. */
2698 gfc_resolve_dt (gfc_dt *dt, locus *loc)
2702 RESOLVE_TAG (&tag_format, dt->format_expr);
2703 RESOLVE_TAG (&tag_rec, dt->rec);
2704 RESOLVE_TAG (&tag_spos, dt->pos);
2705 RESOLVE_TAG (&tag_advance, dt->advance);
2706 RESOLVE_TAG (&tag_id, dt->id);
2707 RESOLVE_TAG (&tag_iomsg, dt->iomsg);
2708 RESOLVE_TAG (&tag_iostat, dt->iostat);
2709 RESOLVE_TAG (&tag_size, dt->size);
2710 RESOLVE_TAG (&tag_e_pad, dt->pad);
2711 RESOLVE_TAG (&tag_e_delim, dt->delim);
2712 RESOLVE_TAG (&tag_e_sign, dt->sign);
2713 RESOLVE_TAG (&tag_e_round, dt->round);
2714 RESOLVE_TAG (&tag_e_blank, dt->blank);
2715 RESOLVE_TAG (&tag_e_decimal, dt->decimal);
2716 RESOLVE_TAG (&tag_e_async, dt->asynchronous);
2721 gfc_error ("UNIT not specified at %L", loc);
2725 if (gfc_resolve_expr (e) == SUCCESS
2726 && (e->ts.type != BT_INTEGER
2727 && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
2729 /* If there is no extra comma signifying the "format" form of the IO
2730 statement, then this must be an error. */
2731 if (!dt->extra_comma)
2733 gfc_error ("UNIT specification at %L must be an INTEGER expression "
2734 "or a CHARACTER variable", &e->where);
2739 /* At this point, we have an extra comma. If io_unit has arrived as
2740 type character, we assume its really the "format" form of the I/O
2741 statement. We set the io_unit to the default unit and format to
2742 the character expression. See F95 Standard section 9.4. */
2744 k = dt->extra_comma->value.iokind;
2745 if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
2747 dt->format_expr = dt->io_unit;
2748 dt->io_unit = default_unit (k);
2750 /* Free this pointer now so that a warning/error is not triggered
2751 below for the "Extension". */
2752 gfc_free_expr (dt->extra_comma);
2753 dt->extra_comma = NULL;
2758 gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
2759 &dt->extra_comma->where);
2765 if (e->ts.type == BT_CHARACTER)
2767 if (gfc_has_vector_index (e))
2769 gfc_error ("Internal unit with vector subscript at %L", &e->where);
2774 if (e->rank && e->ts.type != BT_CHARACTER)
2776 gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
2780 if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER
2781 && mpz_sgn (e->value.integer) < 0)
2783 gfc_error ("UNIT number in statement at %L must be non-negative", &e->where);
2788 && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before i/o "
2789 "item list at %L", &dt->extra_comma->where) == FAILURE)
2794 if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
2796 if (dt->err->defined == ST_LABEL_UNKNOWN)
2798 gfc_error ("ERR tag label %d at %L not defined",
2799 dt->err->value, &dt->err_where);
2806 if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
2808 if (dt->end->defined == ST_LABEL_UNKNOWN)
2810 gfc_error ("END tag label %d at %L not defined",
2811 dt->end->value, &dt->end_where);
2818 if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
2820 if (dt->eor->defined == ST_LABEL_UNKNOWN)
2822 gfc_error ("EOR tag label %d at %L not defined",
2823 dt->eor->value, &dt->eor_where);
2828 /* Check the format label actually exists. */
2829 if (dt->format_label && dt->format_label != &format_asterisk
2830 && dt->format_label->defined == ST_LABEL_UNKNOWN)
2832 gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
2833 &dt->format_label->where);
2840 /* Given an io_kind, return its name. */
2843 io_kind_name (io_kind k)
2862 gfc_internal_error ("io_kind_name(): bad I/O-kind");
2869 /* Match an IO iteration statement of the form:
2871 ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
2873 which is equivalent to a single IO element. This function is
2874 mutually recursive with match_io_element(). */
2876 static match match_io_element (io_kind, gfc_code **);
2879 match_io_iterator (io_kind k, gfc_code **result)
2881 gfc_code *head, *tail, *new_code;
2889 old_loc = gfc_current_locus;
2891 if (gfc_match_char ('(') != MATCH_YES)
2894 m = match_io_element (k, &head);
2897 if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
2903 /* Can't be anything but an IO iterator. Build a list. */
2904 iter = gfc_get_iterator ();
2908 m = gfc_match_iterator (iter, 0);
2909 if (m == MATCH_ERROR)
2913 gfc_check_do_variable (iter->var->symtree);
2917 m = match_io_element (k, &new_code);
2918 if (m == MATCH_ERROR)
2927 tail = gfc_append_code (tail, new_code);
2929 if (gfc_match_char (',') != MATCH_YES)
2938 if (gfc_match_char (')') != MATCH_YES)
2941 new_code = gfc_get_code ();
2942 new_code->op = EXEC_DO;
2943 new_code->ext.iterator = iter;
2945 new_code->block = gfc_get_code ();
2946 new_code->block->op = EXEC_DO;
2947 new_code->block->next = head;
2953 gfc_error ("Syntax error in I/O iterator at %C");
2957 gfc_free_iterator (iter, 1);
2958 gfc_free_statements (head);
2959 gfc_current_locus = old_loc;
2964 /* Match a single element of an IO list, which is either a single
2965 expression or an IO Iterator. */
2968 match_io_element (io_kind k, gfc_code **cpp)
2976 m = match_io_iterator (k, cpp);
2982 m = gfc_match_variable (&expr, 0);
2984 gfc_error ("Expected variable in READ statement at %C");
2988 m = gfc_match_expr (&expr);
2990 gfc_error ("Expected expression in %s statement at %C",
2998 if (expr->symtree->n.sym->attr.intent == INTENT_IN)
3000 gfc_error ("Variable '%s' in input list at %C cannot be "
3001 "INTENT(IN)", expr->symtree->n.sym->name);
3006 && gfc_impure_variable (expr->symtree->n.sym)
3007 && current_dt->io_unit
3008 && current_dt->io_unit->ts.type == BT_CHARACTER)
3010 gfc_error ("Cannot read to variable '%s' in PURE procedure at %C",
3011 expr->symtree->n.sym->name);
3015 if (gfc_check_do_variable (expr->symtree))
3021 if (current_dt->io_unit
3022 && current_dt->io_unit->ts.type == BT_CHARACTER
3024 && current_dt->io_unit->expr_type == EXPR_VARIABLE
3025 && gfc_impure_variable (current_dt->io_unit->symtree->n.sym))
3027 gfc_error ("Cannot write to internal file unit '%s' at %C "
3028 "inside a PURE procedure",
3029 current_dt->io_unit->symtree->n.sym->name);
3041 gfc_free_expr (expr);
3045 cp = gfc_get_code ();
3046 cp->op = EXEC_TRANSFER;
3054 /* Match an I/O list, building gfc_code structures as we go. */
3057 match_io_list (io_kind k, gfc_code **head_p)
3059 gfc_code *head, *tail, *new_code;
3062 *head_p = head = tail = NULL;
3063 if (gfc_match_eos () == MATCH_YES)
3068 m = match_io_element (k, &new_code);
3069 if (m == MATCH_ERROR)
3074 tail = gfc_append_code (tail, new_code);
3078 if (gfc_match_eos () == MATCH_YES)
3080 if (gfc_match_char (',') != MATCH_YES)
3088 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3091 gfc_free_statements (head);
3096 /* Attach the data transfer end node. */
3099 terminate_io (gfc_code *io_code)
3103 if (io_code == NULL)
3104 io_code = new_st.block;
3106 c = gfc_get_code ();
3107 c->op = EXEC_DT_END;
3109 /* Point to structure that is already there */
3110 c->ext.dt = new_st.ext.dt;
3111 gfc_append_code (io_code, c);
3115 /* Check the constraints for a data transfer statement. The majority of the
3116 constraints appearing in 9.4 of the standard appear here. Some are handled
3117 in resolve_tag and others in gfc_resolve_dt. */
3120 check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
3123 #define io_constraint(condition,msg,arg)\
3126 gfc_error(msg,arg);\
3132 gfc_symbol *sym = NULL;
3133 bool warn, unformatted;
3135 warn = (dt->err || dt->iostat) ? true : false;
3136 unformatted = dt->format_expr == NULL && dt->format_label == NULL
3137 && dt->namelist == NULL;
3142 if (expr && expr->expr_type == EXPR_VARIABLE
3143 && expr->ts.type == BT_CHARACTER)
3145 sym = expr->symtree->n.sym;
3147 io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
3148 "Internal file at %L must not be INTENT(IN)",
3151 io_constraint (gfc_has_vector_index (dt->io_unit),
3152 "Internal file incompatible with vector subscript at %L",
3155 io_constraint (dt->rec != NULL,
3156 "REC tag at %L is incompatible with internal file",
3159 io_constraint (dt->pos != NULL,
3160 "POS tag at %L is incompatible with internal file",
3163 io_constraint (unformatted,
3164 "Unformatted I/O not allowed with internal unit at %L",
3165 &dt->io_unit->where);
3167 io_constraint (dt->asynchronous != NULL,
3168 "ASYNCHRONOUS tag at %L not allowed with internal file",
3169 &dt->asynchronous->where);
3171 if (dt->namelist != NULL)
3173 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Internal file "
3174 "at %L with namelist", &expr->where)
3179 io_constraint (dt->advance != NULL,
3180 "ADVANCE tag at %L is incompatible with internal file",
3181 &dt->advance->where);
3184 if (expr && expr->ts.type != BT_CHARACTER)
3187 io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE),
3188 "IO UNIT in %s statement at %C must be "
3189 "an internal file in a PURE procedure",
3195 io_constraint (dt->end, "END tag not allowed with output at %L",
3198 io_constraint (dt->eor, "EOR tag not allowed with output at %L",
3201 io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L",
3204 io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
3207 io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
3212 io_constraint (dt->size && dt->advance == NULL,
3213 "SIZE tag at %L requires an ADVANCE tag",
3216 io_constraint (dt->eor && dt->advance == NULL,
3217 "EOR tag at %L requires an ADVANCE tag",
3221 if (dt->asynchronous)
3223 static const char * asynchronous[] = { "YES", "NO", NULL };
3225 if (gfc_reduce_init_expr (dt->asynchronous) != SUCCESS)
3227 gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3228 "expression", &dt->asynchronous->where);
3232 if (!compare_to_allowed_values
3233 ("ASYNCHRONOUS", asynchronous, NULL, NULL,
3234 dt->asynchronous->value.character.string,
3235 io_kind_name (k), warn))
3243 || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
3244 || gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
3246 io_constraint (not_yes,
3247 "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3248 "specifier", &dt->id->where);
3253 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
3254 "not allowed in Fortran 95") == FAILURE)
3257 if (dt->decimal->expr_type == EXPR_CONSTANT)
3259 static const char * decimal[] = { "COMMA", "POINT", NULL };
3261 if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
3262 dt->decimal->value.character.string,
3263 io_kind_name (k), warn))
3266 io_constraint (unformatted,
3267 "the DECIMAL= specifier at %L must be with an "
3268 "explicit format expression", &dt->decimal->where);
3274 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
3275 "not allowed in Fortran 95") == FAILURE)
3278 if (dt->blank->expr_type == EXPR_CONSTANT)
3280 static const char * blank[] = { "NULL", "ZERO", NULL };
3282 if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
3283 dt->blank->value.character.string,
3284 io_kind_name (k), warn))
3287 io_constraint (unformatted,
3288 "the BLANK= specifier at %L must be with an "
3289 "explicit format expression", &dt->blank->where);
3295 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PAD= at %C "
3296 "not allowed in Fortran 95") == FAILURE)
3299 if (dt->pad->expr_type == EXPR_CONSTANT)
3301 static const char * pad[] = { "YES", "NO", NULL };
3303 if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
3304 dt->pad->value.character.string,
3305 io_kind_name (k), warn))
3308 io_constraint (unformatted,
3309 "the PAD= specifier at %L must be with an "
3310 "explicit format expression", &dt->pad->where);
3316 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ROUND= at %C "
3317 "not allowed in Fortran 95") == FAILURE)
3320 if (dt->round->expr_type == EXPR_CONSTANT)
3322 static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
3323 "COMPATIBLE", "PROCESSOR_DEFINED",
3326 if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
3327 dt->round->value.character.string,
3328 io_kind_name (k), warn))
3335 /* When implemented, change the following to use gfc_notify_std F2003.
3336 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
3337 "not allowed in Fortran 95") == FAILURE)
3338 return MATCH_ERROR; */
3339 if (dt->sign->expr_type == EXPR_CONSTANT)
3341 static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3344 if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
3345 dt->sign->value.character.string,
3346 io_kind_name (k), warn))
3349 io_constraint (unformatted,
3350 "SIGN= specifier at %L must be with an "
3351 "explicit format expression", &dt->sign->where);
3353 io_constraint (k == M_READ,
3354 "SIGN= specifier at %L not allowed in a "
3355 "READ statement", &dt->sign->where);
3361 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
3362 "not allowed in Fortran 95") == FAILURE)
3365 if (dt->delim->expr_type == EXPR_CONSTANT)
3367 static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
3369 if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
3370 dt->delim->value.character.string,
3371 io_kind_name (k), warn))
3374 io_constraint (k == M_READ,
3375 "DELIM= specifier at %L not allowed in a "
3376 "READ statement", &dt->delim->where);
3378 io_constraint (dt->format_label != &format_asterisk
3379 && dt->namelist == NULL,
3380 "DELIM= specifier at %L must have FMT=*",
3383 io_constraint (unformatted && dt->namelist == NULL,
3384 "DELIM= specifier at %L must be with FMT=* or "
3385 "NML= specifier ", &dt->delim->where);
3391 io_constraint (io_code && dt->namelist,
3392 "NAMELIST cannot be followed by IO-list at %L",
3395 io_constraint (dt->format_expr,
3396 "IO spec-list cannot contain both NAMELIST group name "
3397 "and format specification at %L",
3398 &dt->format_expr->where);
3400 io_constraint (dt->format_label,
3401 "IO spec-list cannot contain both NAMELIST group name "
3402 "and format label at %L", spec_end);
3404 io_constraint (dt->rec,
3405 "NAMELIST IO is not allowed with a REC= specifier "
3406 "at %L", &dt->rec->where);
3408 io_constraint (dt->advance,
3409 "NAMELIST IO is not allowed with a ADVANCE= specifier "
3410 "at %L", &dt->advance->where);
3415 io_constraint (dt->end,
3416 "An END tag is not allowed with a "
3417 "REC= specifier at %L", &dt->end_where);
3419 io_constraint (dt->format_label == &format_asterisk,
3420 "FMT=* is not allowed with a REC= specifier "
3423 io_constraint (dt->pos,
3424 "POS= is not allowed with REC= specifier "
3425 "at %L", &dt->pos->where);
3430 int not_yes, not_no;
3433 io_constraint (dt->format_label == &format_asterisk,
3434 "List directed format(*) is not allowed with a "
3435 "ADVANCE= specifier at %L.", &expr->where);
3437 io_constraint (unformatted,
3438 "the ADVANCE= specifier at %L must appear with an "
3439 "explicit format expression", &expr->where);
3441 if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
3443 const gfc_char_t *advance = expr->value.character.string;
3444 not_no = gfc_wide_strlen (advance) != 2
3445 || gfc_wide_strncasecmp (advance, "no", 2) != 0;
3446 not_yes = gfc_wide_strlen (advance) != 3
3447 || gfc_wide_strncasecmp (advance, "yes", 3) != 0;
3455 io_constraint (not_no && not_yes,
3456 "ADVANCE= specifier at %L must have value = "
3457 "YES or NO.", &expr->where);
3459 io_constraint (dt->size && not_no && k == M_READ,
3460 "SIZE tag at %L requires an ADVANCE = 'NO'",
3463 io_constraint (dt->eor && not_no && k == M_READ,
3464 "EOR tag at %L requires an ADVANCE = 'NO'",
3468 expr = dt->format_expr;
3469 if (gfc_simplify_expr (expr, 0) == FAILURE
3470 || check_format_string (expr, k == M_READ) == FAILURE)
3475 #undef io_constraint
3478 /* Match a READ, WRITE or PRINT statement. */
3481 match_io (io_kind k)
3483 char name[GFC_MAX_SYMBOL_LEN + 1];
3492 where = gfc_current_locus;
3494 current_dt = dt = XCNEW (gfc_dt);
3495 m = gfc_match_char ('(');
3498 where = gfc_current_locus;
3501 else if (k == M_PRINT)
3503 /* Treat the non-standard case of PRINT namelist. */
3504 if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
3505 && gfc_match_name (name) == MATCH_YES)
3507 gfc_find_symbol (name, NULL, 1, &sym);
3508 if (sym && sym->attr.flavor == FL_NAMELIST)
3510 if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
3511 "%C is an extension") == FAILURE)
3517 dt->io_unit = default_unit (k);
3522 gfc_current_locus = where;
3526 if (gfc_current_form == FORM_FREE)
3528 char c = gfc_peek_ascii_char ();
3529 if (c != ' ' && c != '*' && c != '\'' && c != '"')
3536 m = match_dt_format (dt);
3537 if (m == MATCH_ERROR)
3543 dt->io_unit = default_unit (k);
3548 /* Before issuing an error for a malformed 'print (1,*)' type of
3549 error, check for a default-char-expr of the form ('(I0)'). */
3550 if (k == M_PRINT && m == MATCH_YES)
3552 /* Reset current locus to get the initial '(' in an expression. */
3553 gfc_current_locus = where;
3554 dt->format_expr = NULL;
3555 m = match_dt_format (dt);
3557 if (m == MATCH_ERROR)
3559 if (m == MATCH_NO || dt->format_expr == NULL)
3563 dt->io_unit = default_unit (k);
3568 /* Match a control list */
3569 if (match_dt_element (k, dt) == MATCH_YES)
3571 if (match_dt_unit (k, dt) != MATCH_YES)
3574 if (gfc_match_char (')') == MATCH_YES)
3576 if (gfc_match_char (',') != MATCH_YES)
3579 m = match_dt_element (k, dt);
3582 if (m == MATCH_ERROR)
3585 m = match_dt_format (dt);
3588 if (m == MATCH_ERROR)
3591 where = gfc_current_locus;
3593 m = gfc_match_name (name);
3596 gfc_find_symbol (name, NULL, 1, &sym);
3597 if (sym && sym->attr.flavor == FL_NAMELIST)
3600 if (k == M_READ && check_namelist (sym))
3609 gfc_current_locus = where;
3611 goto loop; /* No matches, try regular elements */
3614 if (gfc_match_char (')') == MATCH_YES)
3616 if (gfc_match_char (',') != MATCH_YES)
3622 m = match_dt_element (k, dt);
3625 if (m == MATCH_ERROR)
3628 if (gfc_match_char (')') == MATCH_YES)
3630 if (gfc_match_char (',') != MATCH_YES)
3636 /* Used in check_io_constraints, where no locus is available. */
3637 spec_end = gfc_current_locus;
3639 /* Optional leading comma (non-standard). We use a gfc_expr structure here
3640 to save the locus. This is used later when resolving transfer statements
3641 that might have a format expression without unit number. */
3642 if (!comma_flag && gfc_match_char (',') == MATCH_YES)
3644 dt->extra_comma = gfc_get_expr ();
3646 /* Set the types to something compatible with iokind. This is needed to
3647 get through gfc_free_expr later since iokind really has no Basic Type,
3649 dt->extra_comma->expr_type = EXPR_CONSTANT;
3650 dt->extra_comma->ts.type = BT_LOGICAL;
3652 /* Save the iokind and locus for later use in resolution. */
3653 dt->extra_comma->value.iokind = k;
3654 dt->extra_comma->where = gfc_current_locus;
3658 if (gfc_match_eos () != MATCH_YES)
3660 if (comma_flag && gfc_match_char (',') != MATCH_YES)
3662 gfc_error ("Expected comma in I/O list at %C");
3667 m = match_io_list (k, &io_code);
3668 if (m == MATCH_ERROR)
3674 /* A full IO statement has been matched. Check the constraints. spec_end is
3675 supplied for cases where no locus is supplied. */
3676 m = check_io_constraints (k, dt, io_code, &spec_end);
3678 if (m == MATCH_ERROR)
3681 new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
3683 new_st.block = gfc_get_code ();
3684 new_st.block->op = new_st.op;
3685 new_st.block->next = io_code;
3687 terminate_io (io_code);
3692 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3702 gfc_match_read (void)
3704 return match_io (M_READ);
3709 gfc_match_write (void)
3711 return match_io (M_WRITE);
3716 gfc_match_print (void)
3720 m = match_io (M_PRINT);
3724 if (gfc_pure (NULL))
3726 gfc_error ("PRINT statement at %C not allowed within PURE procedure");
3734 /* Free a gfc_inquire structure. */
3737 gfc_free_inquire (gfc_inquire *inquire)
3740 if (inquire == NULL)
3743 gfc_free_expr (inquire->unit);
3744 gfc_free_expr (inquire->file);
3745 gfc_free_expr (inquire->iomsg);
3746 gfc_free_expr (inquire->iostat);
3747 gfc_free_expr (inquire->exist);
3748 gfc_free_expr (inquire->opened);
3749 gfc_free_expr (inquire->number);
3750 gfc_free_expr (inquire->named);
3751 gfc_free_expr (inquire->name);
3752 gfc_free_expr (inquire->access);
3753 gfc_free_expr (inquire->sequential);
3754 gfc_free_expr (inquire->direct);
3755 gfc_free_expr (inquire->form);
3756 gfc_free_expr (inquire->formatted);
3757 gfc_free_expr (inquire->unformatted);
3758 gfc_free_expr (inquire->recl);
3759 gfc_free_expr (inquire->nextrec);
3760 gfc_free_expr (inquire->blank);
3761 gfc_free_expr (inquire->position);
3762 gfc_free_expr (inquire->action);
3763 gfc_free_expr (inquire->read);
3764 gfc_free_expr (inquire->write);
3765 gfc_free_expr (inquire->readwrite);
3766 gfc_free_expr (inquire->delim);
3767 gfc_free_expr (inquire->encoding);
3768 gfc_free_expr (inquire->pad);
3769 gfc_free_expr (inquire->iolength);
3770 gfc_free_expr (inquire->convert);
3771 gfc_free_expr (inquire->strm_pos);
3772 gfc_free_expr (inquire->asynchronous);
3773 gfc_free_expr (inquire->decimal);
3774 gfc_free_expr (inquire->pending);
3775 gfc_free_expr (inquire->id);
3776 gfc_free_expr (inquire->sign);
3777 gfc_free_expr (inquire->size);
3778 gfc_free_expr (inquire->round);
3783 /* Match an element of an INQUIRE statement. */
3785 #define RETM if (m != MATCH_NO) return m;
3788 match_inquire_element (gfc_inquire *inquire)
3792 m = match_etag (&tag_unit, &inquire->unit);
3793 RETM m = match_etag (&tag_file, &inquire->file);
3794 RETM m = match_ltag (&tag_err, &inquire->err);
3795 RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg);
3796 RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
3797 RETM m = match_vtag (&tag_exist, &inquire->exist);
3798 RETM m = match_vtag (&tag_opened, &inquire->opened);
3799 RETM m = match_vtag (&tag_named, &inquire->named);
3800 RETM m = match_vtag (&tag_name, &inquire->name);
3801 RETM m = match_out_tag (&tag_number, &inquire->number);
3802 RETM m = match_vtag (&tag_s_access, &inquire->access);
3803 RETM m = match_vtag (&tag_sequential, &inquire->sequential);
3804 RETM m = match_vtag (&tag_direct, &inquire->direct);
3805 RETM m = match_vtag (&tag_s_form, &inquire->form);
3806 RETM m = match_vtag (&tag_formatted, &inquire->formatted);
3807 RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
3808 RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
3809 RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
3810 RETM m = match_vtag (&tag_s_blank, &inquire->blank);
3811 RETM m = match_vtag (&tag_s_position, &inquire->position);
3812 RETM m = match_vtag (&tag_s_action, &inquire->action);
3813 RETM m = match_vtag (&tag_read, &inquire->read);
3814 RETM m = match_vtag (&tag_write, &inquire->write);
3815 RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
3816 RETM m = match_vtag (&tag_s_async, &inquire->asynchronous);
3817 RETM m = match_vtag (&tag_s_delim, &inquire->delim);
3818 RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
3819 RETM m = match_vtag (&tag_size, &inquire->size);
3820 RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
3821 RETM m = match_vtag (&tag_s_round, &inquire->round);
3822 RETM m = match_vtag (&tag_s_sign, &inquire->sign);
3823 RETM m = match_vtag (&tag_s_pad, &inquire->pad);
3824 RETM m = match_vtag (&tag_iolength, &inquire->iolength);
3825 RETM m = match_vtag (&tag_convert, &inquire->convert);
3826 RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
3827 RETM m = match_vtag (&tag_pending, &inquire->pending);
3828 RETM m = match_vtag (&tag_id, &inquire->id);
3829 RETM return MATCH_NO;
3836 gfc_match_inquire (void)
3838 gfc_inquire *inquire;
3843 m = gfc_match_char ('(');
3847 inquire = XCNEW (gfc_inquire);
3849 loc = gfc_current_locus;
3851 m = match_inquire_element (inquire);
3852 if (m == MATCH_ERROR)
3856 m = gfc_match_expr (&inquire->unit);
3857 if (m == MATCH_ERROR)
3863 /* See if we have the IOLENGTH form of the inquire statement. */
3864 if (inquire->iolength != NULL)
3866 if (gfc_match_char (')') != MATCH_YES)
3869 m = match_io_list (M_INQUIRE, &code);
3870 if (m == MATCH_ERROR)
3875 new_st.op = EXEC_IOLENGTH;
3876 new_st.expr1 = inquire->iolength;
3877 new_st.ext.inquire = inquire;
3879 if (gfc_pure (NULL))
3881 gfc_free_statements (code);
3882 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3886 new_st.block = gfc_get_code ();
3887 new_st.block->op = EXEC_IOLENGTH;
3888 terminate_io (code);
3889 new_st.block->next = code;
3893 /* At this point, we have the non-IOLENGTH inquire statement. */
3896 if (gfc_match_char (')') == MATCH_YES)
3898 if (gfc_match_char (',') != MATCH_YES)
3901 m = match_inquire_element (inquire);
3902 if (m == MATCH_ERROR)
3907 if (inquire->iolength != NULL)
3909 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
3914 if (gfc_match_eos () != MATCH_YES)
3917 if (inquire->unit != NULL && inquire->file != NULL)
3919 gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
3920 "UNIT specifiers", &loc);
3924 if (inquire->unit == NULL && inquire->file == NULL)
3926 gfc_error ("INQUIRE statement at %L requires either FILE or "
3927 "UNIT specifier", &loc);
3931 if (gfc_pure (NULL))
3933 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3937 if (inquire->id != NULL && inquire->pending == NULL)
3939 gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
3940 "the ID= specifier", &loc);
3944 new_st.op = EXEC_INQUIRE;
3945 new_st.ext.inquire = inquire;
3949 gfc_syntax_error (ST_INQUIRE);
3952 gfc_free_inquire (inquire);
3957 /* Resolve everything in a gfc_inquire structure. */
3960 gfc_resolve_inquire (gfc_inquire *inquire)
3962 RESOLVE_TAG (&tag_unit, inquire->unit);
3963 RESOLVE_TAG (&tag_file, inquire->file);
3964 RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
3965 RESOLVE_TAG (&tag_iostat, inquire->iostat);
3966 RESOLVE_TAG (&tag_exist, inquire->exist);
3967 RESOLVE_TAG (&tag_opened, inquire->opened);
3968 RESOLVE_TAG (&tag_number, inquire->number);
3969 RESOLVE_TAG (&tag_named, inquire->named);
3970 RESOLVE_TAG (&tag_name, inquire->name);
3971 RESOLVE_TAG (&tag_s_access, inquire->access);
3972 RESOLVE_TAG (&tag_sequential, inquire->sequential);
3973 RESOLVE_TAG (&tag_direct, inquire->direct);
3974 RESOLVE_TAG (&tag_s_form, inquire->form);
3975 RESOLVE_TAG (&tag_formatted, inquire->formatted);
3976 RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
3977 RESOLVE_TAG (&tag_s_recl, inquire->recl);
3978 RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
3979 RESOLVE_TAG (&tag_s_blank, inquire->blank);
3980 RESOLVE_TAG (&tag_s_position, inquire->position);
3981 RESOLVE_TAG (&tag_s_action, inquire->action);
3982 RESOLVE_TAG (&tag_read, inquire->read);
3983 RESOLVE_TAG (&tag_write, inquire->write);
3984 RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
3985 RESOLVE_TAG (&tag_s_delim, inquire->delim);
3986 RESOLVE_TAG (&tag_s_pad, inquire->pad);
3987 RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
3988 RESOLVE_TAG (&tag_s_round, inquire->round);
3989 RESOLVE_TAG (&tag_iolength, inquire->iolength);
3990 RESOLVE_TAG (&tag_convert, inquire->convert);
3991 RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
3992 RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
3993 RESOLVE_TAG (&tag_s_sign, inquire->sign);
3994 RESOLVE_TAG (&tag_s_round, inquire->round);
3995 RESOLVE_TAG (&tag_pending, inquire->pending);
3996 RESOLVE_TAG (&tag_size, inquire->size);
3997 RESOLVE_TAG (&tag_id, inquire->id);
3999 if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
4007 gfc_free_wait (gfc_wait *wait)
4012 gfc_free_expr (wait->unit);
4013 gfc_free_expr (wait->iostat);
4014 gfc_free_expr (wait->iomsg);
4015 gfc_free_expr (wait->id);
4020 gfc_resolve_wait (gfc_wait *wait)
4022 RESOLVE_TAG (&tag_unit, wait->unit);
4023 RESOLVE_TAG (&tag_iomsg, wait->iomsg);
4024 RESOLVE_TAG (&tag_iostat, wait->iostat);
4025 RESOLVE_TAG (&tag_id, wait->id);
4027 if (gfc_reference_st_label (wait->err, ST_LABEL_TARGET) == FAILURE)
4030 if (gfc_reference_st_label (wait->end, ST_LABEL_TARGET) == FAILURE)
4036 /* Match an element of a WAIT statement. */
4038 #define RETM if (m != MATCH_NO) return m;
4041 match_wait_element (gfc_wait *wait)
4045 m = match_etag (&tag_unit, &wait->unit);
4046 RETM m = match_ltag (&tag_err, &wait->err);
4047 RETM m = match_ltag (&tag_end, &wait->eor);
4048 RETM m = match_ltag (&tag_eor, &wait->end);
4049 RETM m = match_out_tag (&tag_iomsg, &wait->iomsg);
4050 RETM m = match_out_tag (&tag_iostat, &wait->iostat);
4051 RETM m = match_etag (&tag_id, &wait->id);
4052 RETM return MATCH_NO;
4059 gfc_match_wait (void)
4064 m = gfc_match_char ('(');
4068 wait = XCNEW (gfc_wait);
4070 m = match_wait_element (wait);
4071 if (m == MATCH_ERROR)
4075 m = gfc_match_expr (&wait->unit);
4076 if (m == MATCH_ERROR)
4084 if (gfc_match_char (')') == MATCH_YES)
4086 if (gfc_match_char (',') != MATCH_YES)
4089 m = match_wait_element (wait);
4090 if (m == MATCH_ERROR)
4096 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: WAIT at %C "
4097 "not allowed in Fortran 95") == FAILURE)
4100 if (gfc_pure (NULL))
4102 gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4106 new_st.op = EXEC_WAIT;
4107 new_st.ext.wait = wait;
4112 gfc_syntax_error (ST_WAIT);
4115 gfc_free_wait (wait);