1 /* Deal with I/O statements & related stuff.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
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 2, 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 COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
30 gfc_st_label format_asterisk =
31 { -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL, 0,
32 {NULL, NULL}, NULL, NULL};
36 const char *name, *spec;
42 tag_file = { "FILE", " file = %e", BT_CHARACTER },
43 tag_status = { "STATUS", " status = %e", BT_CHARACTER},
44 tag_e_access = {"ACCESS", " access = %e", BT_CHARACTER},
45 tag_e_form = {"FORM", " form = %e", BT_CHARACTER},
46 tag_e_recl = {"RECL", " recl = %e", BT_INTEGER},
47 tag_e_blank = {"BLANK", " blank = %e", BT_CHARACTER},
48 tag_e_position = {"POSITION", " position = %e", BT_CHARACTER},
49 tag_e_action = {"ACTION", " action = %e", BT_CHARACTER},
50 tag_e_delim = {"DELIM", " delim = %e", BT_CHARACTER},
51 tag_e_pad = {"PAD", " pad = %e", BT_CHARACTER},
52 tag_unit = {"UNIT", " unit = %e", BT_INTEGER},
53 tag_advance = {"ADVANCE", " advance = %e", BT_CHARACTER},
54 tag_rec = {"REC", " rec = %e", BT_INTEGER},
55 tag_format = {"FORMAT", NULL, BT_CHARACTER},
56 tag_iostat = {"IOSTAT", " iostat = %v", BT_INTEGER},
57 tag_size = {"SIZE", " size = %v", BT_INTEGER},
58 tag_exist = {"EXIST", " exist = %v", BT_LOGICAL},
59 tag_opened = {"OPENED", " opened = %v", BT_LOGICAL},
60 tag_named = {"NAMED", " named = %v", BT_LOGICAL},
61 tag_name = {"NAME", " name = %v", BT_CHARACTER},
62 tag_number = {"NUMBER", " number = %v", BT_INTEGER},
63 tag_s_access = {"ACCESS", " access = %v", BT_CHARACTER},
64 tag_sequential = {"SEQUENTIAL", " sequential = %v", BT_CHARACTER},
65 tag_direct = {"DIRECT", " direct = %v", BT_CHARACTER},
66 tag_s_form = {"FORM", " form = %v", BT_CHARACTER},
67 tag_formatted = {"FORMATTED", " formatted = %v", BT_CHARACTER},
68 tag_unformatted = {"UNFORMATTED", " unformatted = %v", BT_CHARACTER},
69 tag_s_recl = {"RECL", " recl = %v", BT_INTEGER},
70 tag_nextrec = {"NEXTREC", " nextrec = %v", BT_INTEGER},
71 tag_s_blank = {"BLANK", " blank = %v", BT_CHARACTER},
72 tag_s_position = {"POSITION", " position = %v", BT_CHARACTER},
73 tag_s_action = {"ACTION", " action = %v", BT_CHARACTER},
74 tag_read = {"READ", " read = %v", BT_CHARACTER},
75 tag_write = {"WRITE", " write = %v", BT_CHARACTER},
76 tag_readwrite = {"READWRITE", " readwrite = %v", BT_CHARACTER},
77 tag_s_delim = {"DELIM", " delim = %v", BT_CHARACTER},
78 tag_s_pad = {"PAD", " pad = %v", BT_CHARACTER},
79 tag_iolength = {"IOLENGTH", " iolength = %v", BT_INTEGER},
80 tag_err = {"ERR", " err = %l", BT_UNKNOWN},
81 tag_end = {"END", " end = %l", BT_UNKNOWN},
82 tag_eor = {"EOR", " eor = %l", BT_UNKNOWN};
84 static gfc_dt *current_dt;
86 #define RESOLVE_TAG(x, y) if (resolve_tag(x, y) == FAILURE) return FAILURE;
89 /**************** Fortran 95 FORMAT parser *****************/
91 /* FORMAT tokens returned by format_lex(). */
94 FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
95 FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_POS, FMT_LPAREN,
96 FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F,
97 FMT_E, FMT_EXT, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END
101 /* Local variables for checking format strings. The saved_token is
102 used to back up by a single format token during the parsing
104 static char *format_string;
105 static int format_length, use_last_char;
107 static format_token saved_token;
110 { MODE_STRING, MODE_FORMAT, MODE_COPY }
114 /* Return the next character in the format string. */
117 next_char (int in_string)
129 if (mode == MODE_STRING)
130 c = *format_string++;
133 c = gfc_next_char_literal (in_string);
137 if (mode == MODE_COPY)
138 *format_string++ = c;
146 /* Back up one character position. Only works once. */
155 static int value = 0;
157 /* Simple lexical analyzer for getting the next token in a FORMAT
168 if (saved_token != FMT_NONE)
171 saved_token = FMT_NONE;
179 while (gfc_is_whitespace (c));
200 value = 10 * value + c - '0';
209 token = FMT_SIGNED_INT;
232 value = 10 * value + c - '0';
237 token = zflag ? FMT_ZERO : FMT_POSINT;
262 if (c != 'L' && c != 'R')
282 if (c != 'P' && c != 'S')
290 if (c == 'N' || c == 'Z')
352 if (c == 'N' || c == 'S')
395 /* Check a format statement. The format string, either from a FORMAT
396 statement or a constant in an I/O statement has already been parsed
397 by itself, and we are checking it for validity. The dual origin
398 means that the warning message is a little less than great. */
403 const char *posint_required = "Positive width required";
404 const char *period_required = "Period required";
405 const char *nonneg_required = "Nonnegative width required";
406 const char *unexpected_element = "Unexpected element";
407 const char *unexpected_end = "Unexpected end of format string";
416 saved_token = FMT_NONE;
424 error = "Missing leading left parenthesis";
430 goto finished; /* Empty format is legal */
434 /* In this state, the next thing has to be a format item. */
458 /* Signed integer can only precede a P format. */
462 error = "Expected P edit descriptor";
469 /* P requires a prior number. */
470 error = "P descriptor requires leading scale factor";
474 /* X requires a prior number if we're being pedantic. */
475 if (gfc_notify_std (GFC_STD_GNU, "Extension: X descriptor "
476 "requires leading space count at %C")
486 goto extension_optional_comma;
495 if (gfc_notify_std (GFC_STD_GNU, "Extension: $ descriptor at %C")
498 if (t != FMT_RPAREN || level > 0)
500 error = "$ must be the last specifier";
521 error = unexpected_end;
525 error = unexpected_element;
530 /* In this state, t must currently be a data descriptor.
531 Deal with things that can/must follow the descriptor. */
545 error = "Repeat count cannot follow P descriptor";
560 error = posint_required;
576 error = posint_required;
583 error = period_required;
588 if (u != FMT_ZERO && u != FMT_POSINT)
590 error = nonneg_required;
597 /* Look for optional exponent. */
608 error = "Positive exponent width required";
617 if (t != FMT_ZERO && t != FMT_POSINT)
619 error = nonneg_required;
626 error = period_required;
631 if (t != FMT_ZERO && t != FMT_POSINT)
633 error = nonneg_required;
640 if(mode == MODE_STRING)
642 format_string += value;
643 format_length -= value;
657 if (t != FMT_ZERO && t != FMT_POSINT)
659 error = nonneg_required;
671 if (t != FMT_ZERO && t != FMT_POSINT)
673 error = nonneg_required;
681 error = unexpected_element;
686 /* Between a descriptor and what comes next. */
705 error = unexpected_end;
709 if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %C")
716 /* Optional comma is a weird between state where we've just finished
717 reading a colon, slash or P descriptor. */
731 /* Assume that we have another format item. */
738 extension_optional_comma:
739 /* As a GNU extension, permit a missing comma after a string literal. */
757 error = unexpected_end;
761 if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %C")
771 /* Something went wrong. If the format we're checking is a string,
772 generate a warning, since the program is correct. If the format
773 is in a FORMAT statement, this messes up parsing, which is an
775 if (mode != MODE_STRING)
776 gfc_error ("%s in format string at %C", error);
779 gfc_warning ("%s in format string at %C", error);
781 /* TODO: More elaborate measures are needed to show where a problem
782 is within a format string that has been calculated. */
792 /* Given an expression node that is a constant string, see if it looks
793 like a format string. */
796 check_format_string (gfc_expr * e)
800 format_string = e->value.character.string;
805 /************ Fortran 95 I/O statement matchers *************/
807 /* Match a FORMAT statement. This amounts to actually parsing the
808 format descriptors in order to correctly locate the end of the
812 gfc_match_format (void)
817 if (gfc_statement_label == NULL)
819 gfc_error ("Missing format label at %C");
822 gfc_gobble_whitespace ();
827 start = gfc_current_locus;
829 if (check_format () == FAILURE)
832 if (gfc_match_eos () != MATCH_YES)
834 gfc_syntax_error (ST_FORMAT);
838 /* The label doesn't get created until after the statement is done
839 being matched, so we have to leave the string for later. */
841 gfc_current_locus = start; /* Back to the beginning */
844 new_st.op = EXEC_NOP;
847 e->expr_type = EXPR_CONSTANT;
848 e->ts.type = BT_CHARACTER;
849 e->ts.kind = gfc_default_character_kind;
851 e->value.character.string = format_string = gfc_getmem(format_length+1);
852 e->value.character.length = format_length;
853 gfc_statement_label->format = e;
856 check_format (); /* Guaranteed to succeed */
857 gfc_match_eos (); /* Guaranteed to succeed */
863 /* Match an expression I/O tag of some sort. */
866 match_etag (const io_tag * tag, gfc_expr ** v)
871 m = gfc_match (tag->spec, &result);
877 gfc_error ("Duplicate %s specification at %C", tag->name);
878 gfc_free_expr (result);
887 /* Match a variable I/O tag of some sort. */
890 match_vtag (const io_tag * tag, gfc_expr ** v)
895 m = gfc_match (tag->spec, &result);
901 gfc_error ("Duplicate %s specification at %C", tag->name);
902 gfc_free_expr (result);
906 if (result->symtree->n.sym->attr.intent == INTENT_IN)
908 gfc_error ("Variable tag cannot be INTENT(IN) at %C");
909 gfc_free_expr (result);
913 if (gfc_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
915 gfc_error ("Variable tag cannot be assigned in PURE procedure at %C");
916 gfc_free_expr (result);
925 /* Match I/O tags that cause variables to become redefined. */
928 match_out_tag(const io_tag *tag, gfc_expr **result)
932 m = match_vtag(tag, result);
934 gfc_check_do_variable((*result)->symtree);
940 /* Match a label I/O tag. */
943 match_ltag (const io_tag * tag, gfc_st_label ** label)
949 m = gfc_match (tag->spec, label);
950 if (m == MATCH_YES && old != 0)
952 gfc_error ("Duplicate %s label specification at %C", tag->name);
960 /* Do expression resolution and type-checking on an expression tag. */
963 resolve_tag (const io_tag * tag, gfc_expr * e)
969 if (gfc_resolve_expr (e) == FAILURE)
972 if (e->ts.type != tag->type && tag != &tag_format)
974 gfc_error ("%s tag at %L must be of type %s", tag->name,
975 &e->where, gfc_basic_typename (tag->type));
979 if (tag == &tag_format)
981 /* If e's rank is zero and e is not an element of an array, it should be
982 of integer or character type. The integer variable should be
984 if (e->symtree == NULL || e->symtree->n.sym->as == NULL
985 || e->symtree->n.sym->as->rank == 0)
987 if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
989 gfc_error ("%s tag at %L must be of type %s or %s", tag->name,
990 &e->where, gfc_basic_typename (BT_CHARACTER),
991 gfc_basic_typename (BT_INTEGER));
994 else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
996 if (gfc_notify_std (GFC_STD_F95_DEL,
997 "Obsolete: ASSIGNED variable in FORMAT tag at %L",
998 &e->where) == FAILURE)
1000 if (e->symtree->n.sym->attr.assign != 1)
1002 gfc_error ("Variable '%s' at %L has not been assigned a "
1003 "format label", e->symtree->n.sym->name, &e->where);
1011 /* if rank is nonzero, we allow the type to be character under
1012 GFC_STD_GNU and other type under GFC_STD_LEGACY. It may be
1013 assigned an Hollerith constant. */
1014 if (e->ts.type == BT_CHARACTER)
1016 if (gfc_notify_std (GFC_STD_GNU,
1017 "Extension: Character array in FORMAT tag at %L",
1018 &e->where) == FAILURE)
1023 if (gfc_notify_std (GFC_STD_LEGACY,
1024 "Extension: Non-character in FORMAT tag at %L",
1025 &e->where) == FAILURE)
1035 gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
1044 /* Match a single tag of an OPEN statement. */
1047 match_open_element (gfc_open * open)
1051 m = match_etag (&tag_unit, &open->unit);
1054 m = match_out_tag (&tag_iostat, &open->iostat);
1057 m = match_etag (&tag_file, &open->file);
1060 m = match_etag (&tag_status, &open->status);
1063 m = match_etag (&tag_e_access, &open->access);
1066 m = match_etag (&tag_e_form, &open->form);
1069 m = match_etag (&tag_e_recl, &open->recl);
1072 m = match_etag (&tag_e_blank, &open->blank);
1075 m = match_etag (&tag_e_position, &open->position);
1078 m = match_etag (&tag_e_action, &open->action);
1081 m = match_etag (&tag_e_delim, &open->delim);
1084 m = match_etag (&tag_e_pad, &open->pad);
1087 m = match_ltag (&tag_err, &open->err);
1095 /* Free the gfc_open structure and all the expressions it contains. */
1098 gfc_free_open (gfc_open * open)
1104 gfc_free_expr (open->unit);
1105 gfc_free_expr (open->iostat);
1106 gfc_free_expr (open->file);
1107 gfc_free_expr (open->status);
1108 gfc_free_expr (open->access);
1109 gfc_free_expr (open->form);
1110 gfc_free_expr (open->recl);
1111 gfc_free_expr (open->blank);
1112 gfc_free_expr (open->position);
1113 gfc_free_expr (open->action);
1114 gfc_free_expr (open->delim);
1115 gfc_free_expr (open->pad);
1121 /* Resolve everything in a gfc_open structure. */
1124 gfc_resolve_open (gfc_open * open)
1127 RESOLVE_TAG (&tag_unit, open->unit);
1128 RESOLVE_TAG (&tag_iostat, open->iostat);
1129 RESOLVE_TAG (&tag_file, open->file);
1130 RESOLVE_TAG (&tag_status, open->status);
1131 RESOLVE_TAG (&tag_e_form, open->form);
1132 RESOLVE_TAG (&tag_e_recl, open->recl);
1134 RESOLVE_TAG (&tag_e_blank, open->blank);
1135 RESOLVE_TAG (&tag_e_position, open->position);
1136 RESOLVE_TAG (&tag_e_action, open->action);
1137 RESOLVE_TAG (&tag_e_delim, open->delim);
1138 RESOLVE_TAG (&tag_e_pad, open->pad);
1140 if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
1147 /* Match an OPEN statement. */
1150 gfc_match_open (void)
1155 m = gfc_match_char ('(');
1159 open = gfc_getmem (sizeof (gfc_open));
1161 m = match_open_element (open);
1163 if (m == MATCH_ERROR)
1167 m = gfc_match_expr (&open->unit);
1170 if (m == MATCH_ERROR)
1176 if (gfc_match_char (')') == MATCH_YES)
1178 if (gfc_match_char (',') != MATCH_YES)
1181 m = match_open_element (open);
1182 if (m == MATCH_ERROR)
1188 if (gfc_match_eos () == MATCH_NO)
1191 if (gfc_pure (NULL))
1193 gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1197 new_st.op = EXEC_OPEN;
1198 new_st.ext.open = open;
1202 gfc_syntax_error (ST_OPEN);
1205 gfc_free_open (open);
1210 /* Free a gfc_close structure an all its expressions. */
1213 gfc_free_close (gfc_close * close)
1219 gfc_free_expr (close->unit);
1220 gfc_free_expr (close->iostat);
1221 gfc_free_expr (close->status);
1227 /* Match elements of a CLOSE statement. */
1230 match_close_element (gfc_close * close)
1234 m = match_etag (&tag_unit, &close->unit);
1237 m = match_etag (&tag_status, &close->status);
1240 m = match_out_tag (&tag_iostat, &close->iostat);
1243 m = match_ltag (&tag_err, &close->err);
1251 /* Match a CLOSE statement. */
1254 gfc_match_close (void)
1259 m = gfc_match_char ('(');
1263 close = gfc_getmem (sizeof (gfc_close));
1265 m = match_close_element (close);
1267 if (m == MATCH_ERROR)
1271 m = gfc_match_expr (&close->unit);
1274 if (m == MATCH_ERROR)
1280 if (gfc_match_char (')') == MATCH_YES)
1282 if (gfc_match_char (',') != MATCH_YES)
1285 m = match_close_element (close);
1286 if (m == MATCH_ERROR)
1292 if (gfc_match_eos () == MATCH_NO)
1295 if (gfc_pure (NULL))
1297 gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
1301 new_st.op = EXEC_CLOSE;
1302 new_st.ext.close = close;
1306 gfc_syntax_error (ST_CLOSE);
1309 gfc_free_close (close);
1314 /* Resolve everything in a gfc_close structure. */
1317 gfc_resolve_close (gfc_close * close)
1320 RESOLVE_TAG (&tag_unit, close->unit);
1321 RESOLVE_TAG (&tag_iostat, close->iostat);
1322 RESOLVE_TAG (&tag_status, close->status);
1324 if (gfc_reference_st_label (close->err, ST_LABEL_TARGET) == FAILURE)
1331 /* Free a gfc_filepos structure. */
1334 gfc_free_filepos (gfc_filepos * fp)
1337 gfc_free_expr (fp->unit);
1338 gfc_free_expr (fp->iostat);
1343 /* Match elements of a REWIND, BACKSPACE or ENDFILE statement. */
1346 match_file_element (gfc_filepos * fp)
1350 m = match_etag (&tag_unit, &fp->unit);
1353 m = match_out_tag (&tag_iostat, &fp->iostat);
1356 m = match_ltag (&tag_err, &fp->err);
1364 /* Match the second half of the file-positioning statements, REWIND,
1365 BACKSPACE or ENDFILE. */
1368 match_filepos (gfc_statement st, gfc_exec_op op)
1373 fp = gfc_getmem (sizeof (gfc_filepos));
1375 if (gfc_match_char ('(') == MATCH_NO)
1377 m = gfc_match_expr (&fp->unit);
1378 if (m == MATCH_ERROR)
1386 m = match_file_element (fp);
1387 if (m == MATCH_ERROR)
1391 m = gfc_match_expr (&fp->unit);
1392 if (m == MATCH_ERROR)
1400 if (gfc_match_char (')') == MATCH_YES)
1402 if (gfc_match_char (',') != MATCH_YES)
1405 m = match_file_element (fp);
1406 if (m == MATCH_ERROR)
1413 if (gfc_match_eos () != MATCH_YES)
1416 if (gfc_pure (NULL))
1418 gfc_error ("%s statement not allowed in PURE procedure at %C",
1419 gfc_ascii_statement (st));
1425 new_st.ext.filepos = fp;
1429 gfc_syntax_error (st);
1432 gfc_free_filepos (fp);
1438 gfc_resolve_filepos (gfc_filepos * fp)
1441 RESOLVE_TAG (&tag_unit, fp->unit);
1442 if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE)
1449 /* Match the file positioning statements: ENDFILE, BACKSPACE or
1453 gfc_match_endfile (void)
1456 return match_filepos (ST_END_FILE, EXEC_ENDFILE);
1460 gfc_match_backspace (void)
1463 return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
1467 gfc_match_rewind (void)
1470 return match_filepos (ST_REWIND, EXEC_REWIND);
1474 /******************** Data Transfer Statements *********************/
1477 { M_READ, M_WRITE, M_PRINT, M_INQUIRE }
1481 /* Return a default unit number. */
1484 default_unit (io_kind k)
1493 return gfc_int_expr (unit);
1497 /* Match a unit specification for a data transfer statement. */
1500 match_dt_unit (io_kind k, gfc_dt * dt)
1504 if (gfc_match_char ('*') == MATCH_YES)
1506 if (dt->io_unit != NULL)
1509 dt->io_unit = default_unit (k);
1513 if (gfc_match_expr (&e) == MATCH_YES)
1515 if (dt->io_unit != NULL)
1528 gfc_error ("Duplicate UNIT specification at %C");
1533 /* Match a format specification. */
1536 match_dt_format (gfc_dt * dt)
1540 gfc_st_label *label;
1542 where = gfc_current_locus;
1544 if (gfc_match_char ('*') == MATCH_YES)
1546 if (dt->format_expr != NULL || dt->format_label != NULL)
1549 dt->format_label = &format_asterisk;
1553 if (gfc_match_st_label (&label, 0) == MATCH_YES)
1555 if (dt->format_expr != NULL || dt->format_label != NULL)
1557 gfc_free_st_label (label);
1561 if (gfc_reference_st_label (label, ST_LABEL_FORMAT) == FAILURE)
1564 dt->format_label = label;
1568 if (gfc_match_expr (&e) == MATCH_YES)
1570 if (dt->format_expr != NULL || dt->format_label != NULL)
1575 dt->format_expr = e;
1579 gfc_current_locus = where; /* The only case where we have to restore */
1584 gfc_error ("Duplicate format specification at %C");
1589 /* Traverse a namelist that is part of a READ statement to make sure
1590 that none of the variables in the namelist are INTENT(IN). Returns
1591 nonzero if we find such a variable. */
1594 check_namelist (gfc_symbol * sym)
1598 for (p = sym->namelist; p; p = p->next)
1599 if (p->sym->attr.intent == INTENT_IN)
1601 gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
1602 p->sym->name, sym->name);
1610 /* Match a single data transfer element. */
1613 match_dt_element (io_kind k, gfc_dt * dt)
1615 char name[GFC_MAX_SYMBOL_LEN + 1];
1619 if (gfc_match (" unit =") == MATCH_YES)
1621 m = match_dt_unit (k, dt);
1626 if (gfc_match (" fmt =") == MATCH_YES)
1628 m = match_dt_format (dt);
1633 if (gfc_match (" nml = %n", name) == MATCH_YES)
1635 if (dt->namelist != NULL)
1637 gfc_error ("Duplicate NML specification at %C");
1641 if (gfc_find_symbol (name, NULL, 1, &sym))
1644 if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
1646 gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
1647 sym != NULL ? sym->name : name);
1652 if (k == M_READ && check_namelist (sym))
1658 m = match_etag (&tag_rec, &dt->rec);
1661 m = match_out_tag (&tag_iostat, &dt->iostat);
1664 m = match_ltag (&tag_err, &dt->err);
1667 m = match_etag (&tag_advance, &dt->advance);
1670 m = match_out_tag (&tag_size, &dt->size);
1674 m = match_ltag (&tag_end, &dt->end);
1679 gfc_error ("END tag at %C not allowed in output statement");
1682 dt->end_where = gfc_current_locus;
1687 m = match_ltag (&tag_eor, &dt->eor);
1689 dt->eor_where = gfc_current_locus;
1697 /* Free a data transfer structure and everything below it. */
1700 gfc_free_dt (gfc_dt * dt)
1706 gfc_free_expr (dt->io_unit);
1707 gfc_free_expr (dt->format_expr);
1708 gfc_free_expr (dt->rec);
1709 gfc_free_expr (dt->advance);
1710 gfc_free_expr (dt->iostat);
1711 gfc_free_expr (dt->size);
1717 /* Resolve everything in a gfc_dt structure. */
1720 gfc_resolve_dt (gfc_dt * dt)
1724 RESOLVE_TAG (&tag_format, dt->format_expr);
1725 RESOLVE_TAG (&tag_rec, dt->rec);
1726 RESOLVE_TAG (&tag_advance, dt->advance);
1727 RESOLVE_TAG (&tag_iostat, dt->iostat);
1728 RESOLVE_TAG (&tag_size, dt->size);
1731 if (gfc_resolve_expr (e) == SUCCESS
1732 && (e->ts.type != BT_INTEGER
1733 && (e->ts.type != BT_CHARACTER
1734 || e->expr_type != EXPR_VARIABLE)))
1737 ("UNIT specification at %L must be an INTEGER expression or a "
1738 "CHARACTER variable", &e->where);
1742 /* Sanity checks on data transfer statements. */
1743 if (e->ts.type == BT_CHARACTER)
1745 if (dt->rec != NULL)
1747 gfc_error ("REC tag at %L is incompatible with internal file",
1752 if (dt->namelist != NULL)
1754 gfc_error ("Internal file at %L is incompatible with namelist",
1755 &dt->io_unit->where);
1759 if (dt->advance != NULL)
1761 gfc_error ("ADVANCE tag at %L is incompatible with internal file",
1762 &dt->advance->where);
1767 if (dt->rec != NULL)
1769 if (dt->end != NULL)
1771 gfc_error ("REC tag at %L is incompatible with END tag",
1776 if (dt->format_label == &format_asterisk)
1779 ("END tag at %L is incompatible with list directed format (*)",
1784 if (dt->namelist != NULL)
1786 gfc_error ("REC tag at %L is incompatible with namelist",
1792 if (dt->advance != NULL && dt->format_label == &format_asterisk)
1794 gfc_error ("ADVANCE tag at %L is incompatible with list directed "
1795 "format (*)", &dt->advance->where);
1799 if (dt->eor != 0 && dt->advance == NULL)
1801 gfc_error ("EOR tag at %L requires an ADVANCE tag", &dt->eor_where);
1805 if (dt->size != NULL && dt->advance == NULL)
1807 gfc_error ("SIZE tag at %L requires an ADVANCE tag", &dt->size->where);
1811 /* TODO: Make sure the ADVANCE tag is 'yes' or 'no' if it is a string
1814 if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
1817 if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
1820 if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
1823 /* Check the format label actually exists. */
1824 if (dt->format_label && dt->format_label != &format_asterisk
1825 && dt->format_label->defined == ST_LABEL_UNKNOWN)
1827 gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
1828 &dt->format_label->where);
1835 /* Given an io_kind, return its name. */
1838 io_kind_name (io_kind k)
1857 gfc_internal_error ("io_kind_name(): bad I/O-kind");
1864 /* Match an IO iteration statement of the form:
1866 ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
1868 which is equivalent to a single IO element. This function is
1869 mutually recursive with match_io_element(). */
1871 static match match_io_element (io_kind k, gfc_code **);
1874 match_io_iterator (io_kind k, gfc_code ** result)
1876 gfc_code *head, *tail, *new;
1884 old_loc = gfc_current_locus;
1886 if (gfc_match_char ('(') != MATCH_YES)
1889 m = match_io_element (k, &head);
1892 if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
1898 /* Can't be anything but an IO iterator. Build a list. */
1899 iter = gfc_get_iterator ();
1903 m = gfc_match_iterator (iter, 0);
1904 if (m == MATCH_ERROR)
1908 gfc_check_do_variable (iter->var->symtree);
1912 m = match_io_element (k, &new);
1913 if (m == MATCH_ERROR)
1922 tail = gfc_append_code (tail, new);
1924 if (gfc_match_char (',') != MATCH_YES)
1933 if (gfc_match_char (')') != MATCH_YES)
1936 new = gfc_get_code ();
1938 new->ext.iterator = iter;
1940 new->block = gfc_get_code ();
1941 new->block->op = EXEC_DO;
1942 new->block->next = head;
1948 gfc_error ("Syntax error in I/O iterator at %C");
1952 gfc_free_iterator (iter, 1);
1953 gfc_free_statements (head);
1954 gfc_current_locus = old_loc;
1959 /* Match a single element of an IO list, which is either a single
1960 expression or an IO Iterator. */
1963 match_io_element (io_kind k, gfc_code ** cpp)
1971 m = match_io_iterator (k, cpp);
1977 m = gfc_match_variable (&expr, 0);
1979 gfc_error ("Expected variable in READ statement at %C");
1983 m = gfc_match_expr (&expr);
1985 gfc_error ("Expected expression in %s statement at %C",
1993 if (expr->symtree->n.sym->attr.intent == INTENT_IN)
1996 ("Variable '%s' in input list at %C cannot be INTENT(IN)",
1997 expr->symtree->n.sym->name);
2002 && gfc_impure_variable (expr->symtree->n.sym)
2003 && current_dt->io_unit->ts.type == BT_CHARACTER)
2005 gfc_error ("Cannot read to variable '%s' in PURE procedure at %C",
2006 expr->symtree->n.sym->name);
2010 if (gfc_check_do_variable (expr->symtree))
2016 if (current_dt->io_unit->ts.type == BT_CHARACTER
2018 && current_dt->io_unit->expr_type == EXPR_VARIABLE
2019 && gfc_impure_variable (current_dt->io_unit->symtree->n.sym))
2022 ("Cannot write to internal file unit '%s' at %C inside a "
2023 "PURE procedure", current_dt->io_unit->symtree->n.sym->name);
2035 gfc_free_expr (expr);
2039 cp = gfc_get_code ();
2040 cp->op = EXEC_TRANSFER;
2048 /* Match an I/O list, building gfc_code structures as we go. */
2051 match_io_list (io_kind k, gfc_code ** head_p)
2053 gfc_code *head, *tail, *new;
2056 *head_p = head = tail = NULL;
2057 if (gfc_match_eos () == MATCH_YES)
2062 m = match_io_element (k, &new);
2063 if (m == MATCH_ERROR)
2068 tail = gfc_append_code (tail, new);
2072 if (gfc_match_eos () == MATCH_YES)
2074 if (gfc_match_char (',') != MATCH_YES)
2082 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
2085 gfc_free_statements (head);
2090 /* Attach the data transfer end node. */
2093 terminate_io (gfc_code * io_code)
2097 if (io_code == NULL)
2100 c = gfc_get_code ();
2101 c->op = EXEC_DT_END;
2103 /* Point to structure that is already there */
2104 c->ext.dt = new_st.ext.dt;
2105 gfc_append_code (io_code, c);
2109 /* Match a READ, WRITE or PRINT statement. */
2112 match_io (io_kind k)
2114 char name[GFC_MAX_SYMBOL_LEN + 1];
2124 current_dt = dt = gfc_getmem (sizeof (gfc_dt));
2126 if (gfc_match_char ('(') == MATCH_NO)
2131 if (gfc_current_form == FORM_FREE)
2133 c = gfc_peek_char();
2134 if (c != ' ' && c != '*' && c != '\'' && c != '"')
2141 m = match_dt_format (dt);
2142 if (m == MATCH_ERROR)
2148 dt->io_unit = default_unit (k);
2152 /* Match a control list */
2153 if (match_dt_element (k, dt) == MATCH_YES)
2155 if (match_dt_unit (k, dt) != MATCH_YES)
2158 if (gfc_match_char (')') == MATCH_YES)
2160 if (gfc_match_char (',') != MATCH_YES)
2163 m = match_dt_element (k, dt);
2166 if (m == MATCH_ERROR)
2169 m = match_dt_format (dt);
2172 if (m == MATCH_ERROR)
2175 where = gfc_current_locus;
2177 if (gfc_match_name (name) == MATCH_YES
2178 && !gfc_find_symbol (name, NULL, 1, &sym)
2179 && sym->attr.flavor == FL_NAMELIST)
2182 if (k == M_READ && check_namelist (sym))
2190 gfc_current_locus = where;
2192 goto loop; /* No matches, try regular elements */
2195 if (gfc_match_char (')') == MATCH_YES)
2197 if (gfc_match_char (',') != MATCH_YES)
2203 m = match_dt_element (k, dt);
2206 if (m == MATCH_ERROR)
2209 if (gfc_match_char (')') == MATCH_YES)
2211 if (gfc_match_char (',') != MATCH_YES)
2216 /* Optional leading comma (non-standard). */
2218 && gfc_match_char (',') == MATCH_YES
2220 && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before output "
2221 "item list at %C is an extension") == FAILURE)
2225 if (gfc_match_eos () != MATCH_YES)
2227 if (comma_flag && gfc_match_char (',') != MATCH_YES)
2229 gfc_error ("Expected comma in I/O list at %C");
2234 m = match_io_list (k, &io_code);
2235 if (m == MATCH_ERROR)
2241 /* A full IO statement has been matched. */
2242 if (dt->io_unit->expr_type == EXPR_VARIABLE
2244 && dt->io_unit->ts.type == BT_CHARACTER
2245 && dt->io_unit->symtree->n.sym->attr.intent == INTENT_IN)
2247 gfc_error ("Internal file '%s' at %L is INTENT(IN)",
2248 dt->io_unit->symtree->n.sym->name, &dt->io_unit->where);
2253 expr = dt->format_expr;
2255 if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
2256 check_format_string (expr);
2259 && (k == M_READ || k == M_WRITE)
2260 && dt->io_unit->ts.type != BT_CHARACTER)
2263 ("io-unit in %s statement at %C must be an internal file in a "
2264 "PURE procedure", io_kind_name (k));
2269 new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
2271 new_st.next = io_code;
2273 terminate_io (io_code);
2278 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
2288 gfc_match_read (void)
2290 return match_io (M_READ);
2294 gfc_match_write (void)
2296 return match_io (M_WRITE);
2300 gfc_match_print (void)
2304 m = match_io (M_PRINT);
2308 if (gfc_pure (NULL))
2310 gfc_error ("PRINT statement at %C not allowed within PURE procedure");
2318 /* Free a gfc_inquire structure. */
2321 gfc_free_inquire (gfc_inquire * inquire)
2324 if (inquire == NULL)
2327 gfc_free_expr (inquire->unit);
2328 gfc_free_expr (inquire->file);
2329 gfc_free_expr (inquire->iostat);
2330 gfc_free_expr (inquire->exist);
2331 gfc_free_expr (inquire->opened);
2332 gfc_free_expr (inquire->number);
2333 gfc_free_expr (inquire->named);
2334 gfc_free_expr (inquire->name);
2335 gfc_free_expr (inquire->access);
2336 gfc_free_expr (inquire->sequential);
2337 gfc_free_expr (inquire->direct);
2338 gfc_free_expr (inquire->form);
2339 gfc_free_expr (inquire->formatted);
2340 gfc_free_expr (inquire->unformatted);
2341 gfc_free_expr (inquire->recl);
2342 gfc_free_expr (inquire->nextrec);
2343 gfc_free_expr (inquire->blank);
2344 gfc_free_expr (inquire->position);
2345 gfc_free_expr (inquire->action);
2346 gfc_free_expr (inquire->read);
2347 gfc_free_expr (inquire->write);
2348 gfc_free_expr (inquire->readwrite);
2349 gfc_free_expr (inquire->delim);
2350 gfc_free_expr (inquire->pad);
2351 gfc_free_expr (inquire->iolength);
2357 /* Match an element of an INQUIRE statement. */
2359 #define RETM if (m != MATCH_NO) return m;
2362 match_inquire_element (gfc_inquire * inquire)
2366 m = match_etag (&tag_unit, &inquire->unit);
2367 RETM m = match_etag (&tag_file, &inquire->file);
2368 RETM m = match_ltag (&tag_err, &inquire->err);
2369 RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
2370 RETM m = match_vtag (&tag_exist, &inquire->exist);
2371 RETM m = match_vtag (&tag_opened, &inquire->opened);
2372 RETM m = match_vtag (&tag_named, &inquire->named);
2373 RETM m = match_vtag (&tag_name, &inquire->name);
2374 RETM m = match_out_tag (&tag_number, &inquire->number);
2375 RETM m = match_vtag (&tag_s_access, &inquire->access);
2376 RETM m = match_vtag (&tag_sequential, &inquire->sequential);
2377 RETM m = match_vtag (&tag_direct, &inquire->direct);
2378 RETM m = match_vtag (&tag_s_form, &inquire->form);
2379 RETM m = match_vtag (&tag_formatted, &inquire->formatted);
2380 RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
2381 RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
2382 RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
2383 RETM m = match_vtag (&tag_s_blank, &inquire->blank);
2384 RETM m = match_vtag (&tag_s_position, &inquire->position);
2385 RETM m = match_vtag (&tag_s_action, &inquire->action);
2386 RETM m = match_vtag (&tag_read, &inquire->read);
2387 RETM m = match_vtag (&tag_write, &inquire->write);
2388 RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
2389 RETM m = match_vtag (&tag_s_delim, &inquire->delim);
2390 RETM m = match_vtag (&tag_s_pad, &inquire->pad);
2391 RETM m = match_vtag (&tag_iolength, &inquire->iolength);
2392 RETM return MATCH_NO;
2399 gfc_match_inquire (void)
2401 gfc_inquire *inquire;
2406 m = gfc_match_char ('(');
2410 inquire = gfc_getmem (sizeof (gfc_inquire));
2412 loc = gfc_current_locus;
2414 m = match_inquire_element (inquire);
2415 if (m == MATCH_ERROR)
2419 m = gfc_match_expr (&inquire->unit);
2420 if (m == MATCH_ERROR)
2426 /* See if we have the IOLENGTH form of the inquire statement. */
2427 if (inquire->iolength != NULL)
2429 if (gfc_match_char (')') != MATCH_YES)
2432 m = match_io_list (M_INQUIRE, &code);
2433 if (m == MATCH_ERROR)
2438 terminate_io (code);
2440 new_st.op = EXEC_IOLENGTH;
2441 new_st.expr = inquire->iolength;
2442 new_st.ext.inquire = inquire;
2444 if (gfc_pure (NULL))
2446 gfc_free_statements (code);
2447 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
2455 /* At this point, we have the non-IOLENGTH inquire statement. */
2458 if (gfc_match_char (')') == MATCH_YES)
2460 if (gfc_match_char (',') != MATCH_YES)
2463 m = match_inquire_element (inquire);
2464 if (m == MATCH_ERROR)
2469 if (inquire->iolength != NULL)
2471 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
2476 if (gfc_match_eos () != MATCH_YES)
2479 if (inquire->unit != NULL && inquire->file != NULL)
2481 gfc_error ("INQUIRE statement at %L cannot contain both FILE and"
2482 " UNIT specifiers", &loc);
2486 if (inquire->unit == NULL && inquire->file == NULL)
2488 gfc_error ("INQUIRE statement at %L requires either FILE or"
2489 " UNIT specifier", &loc);
2493 if (gfc_pure (NULL))
2495 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
2499 new_st.op = EXEC_INQUIRE;
2500 new_st.ext.inquire = inquire;
2504 gfc_syntax_error (ST_INQUIRE);
2507 gfc_free_inquire (inquire);
2512 /* Resolve everything in a gfc_inquire structure. */
2515 gfc_resolve_inquire (gfc_inquire * inquire)
2518 RESOLVE_TAG (&tag_unit, inquire->unit);
2519 RESOLVE_TAG (&tag_file, inquire->file);
2520 RESOLVE_TAG (&tag_iostat, inquire->iostat);
2521 RESOLVE_TAG (&tag_exist, inquire->exist);
2522 RESOLVE_TAG (&tag_opened, inquire->opened);
2523 RESOLVE_TAG (&tag_number, inquire->number);
2524 RESOLVE_TAG (&tag_named, inquire->named);
2525 RESOLVE_TAG (&tag_name, inquire->name);
2526 RESOLVE_TAG (&tag_s_access, inquire->access);
2527 RESOLVE_TAG (&tag_sequential, inquire->sequential);
2528 RESOLVE_TAG (&tag_direct, inquire->direct);
2529 RESOLVE_TAG (&tag_s_form, inquire->form);
2530 RESOLVE_TAG (&tag_formatted, inquire->formatted);
2531 RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
2532 RESOLVE_TAG (&tag_s_recl, inquire->recl);
2533 RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
2534 RESOLVE_TAG (&tag_s_blank, inquire->blank);
2535 RESOLVE_TAG (&tag_s_position, inquire->position);
2536 RESOLVE_TAG (&tag_s_action, inquire->action);
2537 RESOLVE_TAG (&tag_read, inquire->read);
2538 RESOLVE_TAG (&tag_write, inquire->write);
2539 RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
2540 RESOLVE_TAG (&tag_s_delim, inquire->delim);
2541 RESOLVE_TAG (&tag_s_pad, inquire->pad);
2542 RESOLVE_TAG (&tag_iolength, inquire->iolength);
2544 if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)