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, 59 Temple Place - Suite 330, 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
;
494 if (t
!= FMT_RPAREN
|| level
> 0)
496 error
= "$ must the last specifier";
517 error
= unexpected_end
;
521 error
= unexpected_element
;
526 /* In this state, t must currently be a data descriptor.
527 Deal with things that can/must follow the descriptor. */
541 error
= "Repeat count cannot follow P descriptor";
556 error
= posint_required
;
572 error
= posint_required
;
579 error
= period_required
;
584 if (u
!= FMT_ZERO
&& u
!= FMT_POSINT
)
586 error
= nonneg_required
;
593 /* Look for optional exponent. */
604 error
= "Positive exponent width required";
613 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
615 error
= nonneg_required
;
622 error
= period_required
;
627 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
629 error
= nonneg_required
;
636 if(mode
== MODE_STRING
)
638 format_string
+= value
;
639 format_length
-= value
;
653 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
655 error
= nonneg_required
;
667 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
669 error
= nonneg_required
;
677 error
= unexpected_element
;
682 /* Between a descriptor and what comes next. */
701 error
= unexpected_end
;
705 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Missing comma at %C")
712 /* Optional comma is a weird between state where we've just finished
713 reading a colon, slash or P descriptor. */
727 /* Assume that we have another format item. */
734 extension_optional_comma
:
735 /* As a GNU extension, permit a missing comma after a string literal. */
753 error
= unexpected_end
;
757 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Missing comma at %C")
767 /* Something went wrong. If the format we're checking is a string,
768 generate a warning, since the program is correct. If the format
769 is in a FORMAT statement, this messes up parsing, which is an
771 if (mode
!= MODE_STRING
)
772 gfc_error ("%s in format string at %C", error
);
775 gfc_warning ("%s in format string at %C", error
);
777 /* TODO: More elaborate measures are needed to show where a problem
778 is within a format string that has been calculated. */
788 /* Given an expression node that is a constant string, see if it looks
789 like a format string. */
792 check_format_string (gfc_expr
* e
)
796 format_string
= e
->value
.character
.string
;
801 /************ Fortran 95 I/O statement matchers *************/
803 /* Match a FORMAT statement. This amounts to actually parsing the
804 format descriptors in order to correctly locate the end of the
808 gfc_match_format (void)
813 if (gfc_statement_label
== NULL
)
815 gfc_error ("Missing format label at %C");
818 gfc_gobble_whitespace ();
823 start
= gfc_current_locus
;
825 if (check_format () == FAILURE
)
828 if (gfc_match_eos () != MATCH_YES
)
830 gfc_syntax_error (ST_FORMAT
);
834 /* The label doesn't get created until after the statement is done
835 being matched, so we have to leave the string for later. */
837 gfc_current_locus
= start
; /* Back to the beginning */
840 new_st
.op
= EXEC_NOP
;
843 e
->expr_type
= EXPR_CONSTANT
;
844 e
->ts
.type
= BT_CHARACTER
;
845 e
->ts
.kind
= gfc_default_character_kind
;
847 e
->value
.character
.string
= format_string
= gfc_getmem(format_length
+1);
848 e
->value
.character
.length
= format_length
;
849 gfc_statement_label
->format
= e
;
852 check_format (); /* Guaranteed to succeed */
853 gfc_match_eos (); /* Guaranteed to succeed */
859 /* Match an expression I/O tag of some sort. */
862 match_etag (const io_tag
* tag
, gfc_expr
** v
)
867 m
= gfc_match (tag
->spec
, &result
);
873 gfc_error ("Duplicate %s specification at %C", tag
->name
);
874 gfc_free_expr (result
);
883 /* Match a variable I/O tag of some sort. */
886 match_vtag (const io_tag
* tag
, gfc_expr
** v
)
891 m
= gfc_match (tag
->spec
, &result
);
897 gfc_error ("Duplicate %s specification at %C", tag
->name
);
898 gfc_free_expr (result
);
902 if (result
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
904 gfc_error ("Variable tag cannot be INTENT(IN) at %C");
905 gfc_free_expr (result
);
909 if (gfc_pure (NULL
) && gfc_impure_variable (result
->symtree
->n
.sym
))
911 gfc_error ("Variable tag cannot be assigned in PURE procedure at %C");
912 gfc_free_expr (result
);
921 /* Match I/O tags that cause variables to become redefined. */
924 match_out_tag(const io_tag
*tag
, gfc_expr
**result
)
928 m
= match_vtag(tag
, result
);
930 gfc_check_do_variable((*result
)->symtree
);
936 /* Match a label I/O tag. */
939 match_ltag (const io_tag
* tag
, gfc_st_label
** label
)
945 m
= gfc_match (tag
->spec
, label
);
946 if (m
== MATCH_YES
&& old
!= 0)
948 gfc_error ("Duplicate %s label specification at %C", tag
->name
);
956 /* Do expression resolution and type-checking on an expression tag. */
959 resolve_tag (const io_tag
* tag
, gfc_expr
* e
)
965 if (gfc_resolve_expr (e
) == FAILURE
)
968 if (e
->ts
.type
!= tag
->type
)
970 /* Format label can be integer varibale. */
971 if (tag
!= &tag_format
|| e
->ts
.type
!= BT_INTEGER
)
973 gfc_error ("%s tag at %L must be of type %s", tag
->name
, &e
->where
,
974 gfc_basic_typename (tag
->type
));
979 if (tag
== &tag_format
)
981 if (e
->rank
!= 1 && e
->rank
!= 0)
983 gfc_error ("FORMAT tag at %L cannot be array of strings",
987 /* Check assigned label. */
988 if (e
->expr_type
== EXPR_VARIABLE
&& e
->ts
.type
== BT_INTEGER
989 && e
->symtree
->n
.sym
->attr
.assign
!= 1)
991 gfc_error ("Variable '%s' has not been assigned a format label at %L",
992 e
->symtree
->n
.sym
->name
, &e
->where
);
1000 gfc_error ("%s tag at %L must be scalar", tag
->name
, &e
->where
);
1009 /* Match a single tag of an OPEN statement. */
1012 match_open_element (gfc_open
* open
)
1016 m
= match_etag (&tag_unit
, &open
->unit
);
1019 m
= match_out_tag (&tag_iostat
, &open
->iostat
);
1022 m
= match_etag (&tag_file
, &open
->file
);
1025 m
= match_etag (&tag_status
, &open
->status
);
1028 m
= match_etag (&tag_e_access
, &open
->access
);
1031 m
= match_etag (&tag_e_form
, &open
->form
);
1034 m
= match_etag (&tag_e_recl
, &open
->recl
);
1037 m
= match_etag (&tag_e_blank
, &open
->blank
);
1040 m
= match_etag (&tag_e_position
, &open
->position
);
1043 m
= match_etag (&tag_e_action
, &open
->action
);
1046 m
= match_etag (&tag_e_delim
, &open
->delim
);
1049 m
= match_etag (&tag_e_pad
, &open
->pad
);
1052 m
= match_ltag (&tag_err
, &open
->err
);
1060 /* Free the gfc_open structure and all the expressions it contains. */
1063 gfc_free_open (gfc_open
* open
)
1069 gfc_free_expr (open
->unit
);
1070 gfc_free_expr (open
->iostat
);
1071 gfc_free_expr (open
->file
);
1072 gfc_free_expr (open
->status
);
1073 gfc_free_expr (open
->access
);
1074 gfc_free_expr (open
->form
);
1075 gfc_free_expr (open
->recl
);
1076 gfc_free_expr (open
->blank
);
1077 gfc_free_expr (open
->position
);
1078 gfc_free_expr (open
->action
);
1079 gfc_free_expr (open
->delim
);
1080 gfc_free_expr (open
->pad
);
1086 /* Resolve everything in a gfc_open structure. */
1089 gfc_resolve_open (gfc_open
* open
)
1092 RESOLVE_TAG (&tag_unit
, open
->unit
);
1093 RESOLVE_TAG (&tag_iostat
, open
->iostat
);
1094 RESOLVE_TAG (&tag_file
, open
->file
);
1095 RESOLVE_TAG (&tag_status
, open
->status
);
1096 RESOLVE_TAG (&tag_e_form
, open
->form
);
1097 RESOLVE_TAG (&tag_e_recl
, open
->recl
);
1099 RESOLVE_TAG (&tag_e_blank
, open
->blank
);
1100 RESOLVE_TAG (&tag_e_position
, open
->position
);
1101 RESOLVE_TAG (&tag_e_action
, open
->action
);
1102 RESOLVE_TAG (&tag_e_delim
, open
->delim
);
1103 RESOLVE_TAG (&tag_e_pad
, open
->pad
);
1105 if (gfc_reference_st_label (open
->err
, ST_LABEL_TARGET
) == FAILURE
)
1112 /* Match an OPEN statement. */
1115 gfc_match_open (void)
1120 m
= gfc_match_char ('(');
1124 open
= gfc_getmem (sizeof (gfc_open
));
1126 m
= match_open_element (open
);
1128 if (m
== MATCH_ERROR
)
1132 m
= gfc_match_expr (&open
->unit
);
1135 if (m
== MATCH_ERROR
)
1141 if (gfc_match_char (')') == MATCH_YES
)
1143 if (gfc_match_char (',') != MATCH_YES
)
1146 m
= match_open_element (open
);
1147 if (m
== MATCH_ERROR
)
1153 if (gfc_match_eos () == MATCH_NO
)
1156 if (gfc_pure (NULL
))
1158 gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1162 new_st
.op
= EXEC_OPEN
;
1163 new_st
.ext
.open
= open
;
1167 gfc_syntax_error (ST_OPEN
);
1170 gfc_free_open (open
);
1175 /* Free a gfc_close structure an all its expressions. */
1178 gfc_free_close (gfc_close
* close
)
1184 gfc_free_expr (close
->unit
);
1185 gfc_free_expr (close
->iostat
);
1186 gfc_free_expr (close
->status
);
1192 /* Match elements of a CLOSE statement. */
1195 match_close_element (gfc_close
* close
)
1199 m
= match_etag (&tag_unit
, &close
->unit
);
1202 m
= match_etag (&tag_status
, &close
->status
);
1205 m
= match_out_tag (&tag_iostat
, &close
->iostat
);
1208 m
= match_ltag (&tag_err
, &close
->err
);
1216 /* Match a CLOSE statement. */
1219 gfc_match_close (void)
1224 m
= gfc_match_char ('(');
1228 close
= gfc_getmem (sizeof (gfc_close
));
1230 m
= match_close_element (close
);
1232 if (m
== MATCH_ERROR
)
1236 m
= gfc_match_expr (&close
->unit
);
1239 if (m
== MATCH_ERROR
)
1245 if (gfc_match_char (')') == MATCH_YES
)
1247 if (gfc_match_char (',') != MATCH_YES
)
1250 m
= match_close_element (close
);
1251 if (m
== MATCH_ERROR
)
1257 if (gfc_match_eos () == MATCH_NO
)
1260 if (gfc_pure (NULL
))
1262 gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
1266 new_st
.op
= EXEC_CLOSE
;
1267 new_st
.ext
.close
= close
;
1271 gfc_syntax_error (ST_CLOSE
);
1274 gfc_free_close (close
);
1279 /* Resolve everything in a gfc_close structure. */
1282 gfc_resolve_close (gfc_close
* close
)
1285 RESOLVE_TAG (&tag_unit
, close
->unit
);
1286 RESOLVE_TAG (&tag_iostat
, close
->iostat
);
1287 RESOLVE_TAG (&tag_status
, close
->status
);
1289 if (gfc_reference_st_label (close
->err
, ST_LABEL_TARGET
) == FAILURE
)
1296 /* Free a gfc_filepos structure. */
1299 gfc_free_filepos (gfc_filepos
* fp
)
1302 gfc_free_expr (fp
->unit
);
1303 gfc_free_expr (fp
->iostat
);
1308 /* Match elements of a REWIND, BACKSPACE or ENDFILE statement. */
1311 match_file_element (gfc_filepos
* fp
)
1315 m
= match_etag (&tag_unit
, &fp
->unit
);
1318 m
= match_out_tag (&tag_iostat
, &fp
->iostat
);
1321 m
= match_ltag (&tag_err
, &fp
->err
);
1329 /* Match the second half of the file-positioning statements, REWIND,
1330 BACKSPACE or ENDFILE. */
1333 match_filepos (gfc_statement st
, gfc_exec_op op
)
1338 fp
= gfc_getmem (sizeof (gfc_filepos
));
1340 if (gfc_match_char ('(') == MATCH_NO
)
1342 m
= gfc_match_expr (&fp
->unit
);
1343 if (m
== MATCH_ERROR
)
1351 m
= match_file_element (fp
);
1352 if (m
== MATCH_ERROR
)
1356 m
= gfc_match_expr (&fp
->unit
);
1357 if (m
== MATCH_ERROR
)
1365 if (gfc_match_char (')') == MATCH_YES
)
1367 if (gfc_match_char (',') != MATCH_YES
)
1370 m
= match_file_element (fp
);
1371 if (m
== MATCH_ERROR
)
1378 if (gfc_match_eos () != MATCH_YES
)
1381 if (gfc_pure (NULL
))
1383 gfc_error ("%s statement not allowed in PURE procedure at %C",
1384 gfc_ascii_statement (st
));
1390 new_st
.ext
.filepos
= fp
;
1394 gfc_syntax_error (st
);
1397 gfc_free_filepos (fp
);
1403 gfc_resolve_filepos (gfc_filepos
* fp
)
1406 RESOLVE_TAG (&tag_unit
, fp
->unit
);
1407 if (gfc_reference_st_label (fp
->err
, ST_LABEL_TARGET
) == FAILURE
)
1414 /* Match the file positioning statements: ENDFILE, BACKSPACE or
1418 gfc_match_endfile (void)
1421 return match_filepos (ST_END_FILE
, EXEC_ENDFILE
);
1425 gfc_match_backspace (void)
1428 return match_filepos (ST_BACKSPACE
, EXEC_BACKSPACE
);
1432 gfc_match_rewind (void)
1435 return match_filepos (ST_REWIND
, EXEC_REWIND
);
1439 /******************** Data Transfer Statements *********************/
1442 { M_READ
, M_WRITE
, M_PRINT
, M_INQUIRE
}
1446 /* Return a default unit number. */
1449 default_unit (io_kind k
)
1458 return gfc_int_expr (unit
);
1462 /* Match a unit specification for a data transfer statement. */
1465 match_dt_unit (io_kind k
, gfc_dt
* dt
)
1469 if (gfc_match_char ('*') == MATCH_YES
)
1471 if (dt
->io_unit
!= NULL
)
1474 dt
->io_unit
= default_unit (k
);
1478 if (gfc_match_expr (&e
) == MATCH_YES
)
1480 if (dt
->io_unit
!= NULL
)
1493 gfc_error ("Duplicate UNIT specification at %C");
1498 /* Match a format specification. */
1501 match_dt_format (gfc_dt
* dt
)
1505 gfc_st_label
*label
;
1507 where
= gfc_current_locus
;
1509 if (gfc_match_char ('*') == MATCH_YES
)
1511 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
1514 dt
->format_label
= &format_asterisk
;
1518 if (gfc_match_st_label (&label
, 0) == MATCH_YES
)
1520 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
1522 gfc_free_st_label (label
);
1526 if (gfc_reference_st_label (label
, ST_LABEL_FORMAT
) == FAILURE
)
1529 dt
->format_label
= label
;
1533 if (gfc_match_expr (&e
) == MATCH_YES
)
1535 if (dt
->format_expr
!= NULL
|| dt
->format_label
!= NULL
)
1540 dt
->format_expr
= e
;
1544 gfc_current_locus
= where
; /* The only case where we have to restore */
1549 gfc_error ("Duplicate format specification at %C");
1554 /* Traverse a namelist that is part of a READ statement to make sure
1555 that none of the variables in the namelist are INTENT(IN). Returns
1556 nonzero if we find such a variable. */
1559 check_namelist (gfc_symbol
* sym
)
1563 for (p
= sym
->namelist
; p
; p
= p
->next
)
1564 if (p
->sym
->attr
.intent
== INTENT_IN
)
1566 gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
1567 p
->sym
->name
, sym
->name
);
1575 /* Match a single data transfer element. */
1578 match_dt_element (io_kind k
, gfc_dt
* dt
)
1580 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1584 if (gfc_match (" unit =") == MATCH_YES
)
1586 m
= match_dt_unit (k
, dt
);
1591 if (gfc_match (" fmt =") == MATCH_YES
)
1593 m
= match_dt_format (dt
);
1598 if (gfc_match (" nml = %n", name
) == MATCH_YES
)
1600 if (dt
->namelist
!= NULL
)
1602 gfc_error ("Duplicate NML specification at %C");
1606 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
1609 if (sym
== NULL
|| sym
->attr
.flavor
!= FL_NAMELIST
)
1611 gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
1612 sym
!= NULL
? sym
->name
: name
);
1617 if (k
== M_READ
&& check_namelist (sym
))
1623 m
= match_etag (&tag_rec
, &dt
->rec
);
1626 m
= match_out_tag (&tag_iostat
, &dt
->iostat
);
1629 m
= match_ltag (&tag_err
, &dt
->err
);
1632 m
= match_etag (&tag_advance
, &dt
->advance
);
1635 m
= match_out_tag (&tag_size
, &dt
->size
);
1639 m
= match_ltag (&tag_end
, &dt
->end
);
1641 dt
->end_where
= gfc_current_locus
;
1645 m
= match_ltag (&tag_eor
, &dt
->eor
);
1647 dt
->eor_where
= gfc_current_locus
;
1655 /* Free a data transfer structure and everything below it. */
1658 gfc_free_dt (gfc_dt
* dt
)
1664 gfc_free_expr (dt
->io_unit
);
1665 gfc_free_expr (dt
->format_expr
);
1666 gfc_free_expr (dt
->rec
);
1667 gfc_free_expr (dt
->advance
);
1668 gfc_free_expr (dt
->iostat
);
1669 gfc_free_expr (dt
->size
);
1675 /* Resolve everything in a gfc_dt structure. */
1678 gfc_resolve_dt (gfc_dt
* dt
)
1682 RESOLVE_TAG (&tag_format
, dt
->format_expr
);
1683 RESOLVE_TAG (&tag_rec
, dt
->rec
);
1684 RESOLVE_TAG (&tag_advance
, dt
->advance
);
1685 RESOLVE_TAG (&tag_iostat
, dt
->iostat
);
1686 RESOLVE_TAG (&tag_size
, dt
->size
);
1689 if (gfc_resolve_expr (e
) == SUCCESS
1690 && (e
->ts
.type
!= BT_INTEGER
1691 && (e
->ts
.type
!= BT_CHARACTER
1692 || e
->expr_type
!= EXPR_VARIABLE
)))
1695 ("UNIT specification at %L must be an INTEGER expression or a "
1696 "CHARACTER variable", &e
->where
);
1700 /* Sanity checks on data transfer statements. */
1701 if (e
->ts
.type
== BT_CHARACTER
)
1703 if (dt
->rec
!= NULL
)
1705 gfc_error ("REC tag at %L is incompatible with internal file",
1710 if (dt
->namelist
!= NULL
)
1712 gfc_error ("Internal file at %L is incompatible with namelist",
1713 &dt
->io_unit
->where
);
1717 if (dt
->advance
!= NULL
)
1719 gfc_error ("ADVANCE tag at %L is incompatible with internal file",
1720 &dt
->advance
->where
);
1725 if (dt
->rec
!= NULL
)
1727 if (dt
->end
!= NULL
)
1729 gfc_error ("REC tag at %L is incompatible with END tag",
1734 if (dt
->format_label
== &format_asterisk
)
1737 ("END tag at %L is incompatible with list directed format (*)",
1742 if (dt
->namelist
!= NULL
)
1744 gfc_error ("REC tag at %L is incompatible with namelist",
1750 if (dt
->advance
!= NULL
&& dt
->format_label
== &format_asterisk
)
1752 gfc_error ("ADVANCE tag at %L is incompatible with list directed "
1753 "format (*)", &dt
->advance
->where
);
1757 if (dt
->eor
!= 0 && dt
->advance
== NULL
)
1759 gfc_error ("EOR tag at %L requires an ADVANCE tag", &dt
->eor_where
);
1763 if (dt
->size
!= NULL
&& dt
->advance
== NULL
)
1765 gfc_error ("SIZE tag at %L requires an ADVANCE tag", &dt
->size
->where
);
1769 /* TODO: Make sure the ADVANCE tag is 'yes' or 'no' if it is a string
1772 if (gfc_reference_st_label (dt
->err
, ST_LABEL_TARGET
) == FAILURE
)
1775 if (gfc_reference_st_label (dt
->end
, ST_LABEL_TARGET
) == FAILURE
)
1778 if (gfc_reference_st_label (dt
->eor
, ST_LABEL_TARGET
) == FAILURE
)
1781 /* Check the format label actually exists. */
1782 if (dt
->format_label
&& dt
->format_label
!= &format_asterisk
1783 && dt
->format_label
->defined
== ST_LABEL_UNKNOWN
)
1785 gfc_error ("FORMAT label %d at %L not defined", dt
->format_label
->value
,
1786 &dt
->format_label
->where
);
1793 /* Given an io_kind, return its name. */
1796 io_kind_name (io_kind k
)
1815 gfc_internal_error ("io_kind_name(): bad I/O-kind");
1822 /* Match an IO iteration statement of the form:
1824 ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
1826 which is equivalent to a single IO element. This function is
1827 mutually recursive with match_io_element(). */
1829 static match
match_io_element (io_kind k
, gfc_code
**);
1832 match_io_iterator (io_kind k
, gfc_code
** result
)
1834 gfc_code
*head
, *tail
, *new;
1842 old_loc
= gfc_current_locus
;
1844 if (gfc_match_char ('(') != MATCH_YES
)
1847 m
= match_io_element (k
, &head
);
1850 if (m
!= MATCH_YES
|| gfc_match_char (',') != MATCH_YES
)
1856 /* Can't be anything but an IO iterator. Build a list. */
1857 iter
= gfc_get_iterator ();
1861 m
= gfc_match_iterator (iter
, 0);
1862 if (m
== MATCH_ERROR
)
1866 gfc_check_do_variable (iter
->var
->symtree
);
1870 m
= match_io_element (k
, &new);
1871 if (m
== MATCH_ERROR
)
1880 tail
= gfc_append_code (tail
, new);
1882 if (gfc_match_char (',') != MATCH_YES
)
1891 if (gfc_match_char (')') != MATCH_YES
)
1894 new = gfc_get_code ();
1896 new->ext
.iterator
= iter
;
1898 new->block
= gfc_get_code ();
1899 new->block
->op
= EXEC_DO
;
1900 new->block
->next
= head
;
1906 gfc_error ("Syntax error in I/O iterator at %C");
1910 gfc_free_iterator (iter
, 1);
1911 gfc_free_statements (head
);
1912 gfc_current_locus
= old_loc
;
1917 /* Match a single element of an IO list, which is either a single
1918 expression or an IO Iterator. */
1921 match_io_element (io_kind k
, gfc_code
** cpp
)
1929 m
= match_io_iterator (k
, cpp
);
1935 m
= gfc_match_variable (&expr
, 0);
1937 gfc_error ("Expected variable in READ statement at %C");
1941 m
= gfc_match_expr (&expr
);
1943 gfc_error ("Expected expression in %s statement at %C",
1951 if (expr
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1954 ("Variable '%s' in input list at %C cannot be INTENT(IN)",
1955 expr
->symtree
->n
.sym
->name
);
1960 && gfc_impure_variable (expr
->symtree
->n
.sym
)
1961 && current_dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1963 gfc_error ("Cannot read to variable '%s' in PURE procedure at %C",
1964 expr
->symtree
->n
.sym
->name
);
1968 if (gfc_check_do_variable (expr
->symtree
))
1974 if (current_dt
->io_unit
->ts
.type
== BT_CHARACTER
1976 && current_dt
->io_unit
->expr_type
== EXPR_VARIABLE
1977 && gfc_impure_variable (current_dt
->io_unit
->symtree
->n
.sym
))
1980 ("Cannot write to internal file unit '%s' at %C inside a "
1981 "PURE procedure", current_dt
->io_unit
->symtree
->n
.sym
->name
);
1993 gfc_free_expr (expr
);
1997 cp
= gfc_get_code ();
1998 cp
->op
= EXEC_TRANSFER
;
2006 /* Match an I/O list, building gfc_code structures as we go. */
2009 match_io_list (io_kind k
, gfc_code
** head_p
)
2011 gfc_code
*head
, *tail
, *new;
2014 *head_p
= head
= tail
= NULL
;
2015 if (gfc_match_eos () == MATCH_YES
)
2020 m
= match_io_element (k
, &new);
2021 if (m
== MATCH_ERROR
)
2026 tail
= gfc_append_code (tail
, new);
2030 if (gfc_match_eos () == MATCH_YES
)
2032 if (gfc_match_char (',') != MATCH_YES
)
2040 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
2043 gfc_free_statements (head
);
2048 /* Attach the data transfer end node. */
2051 terminate_io (gfc_code
* io_code
)
2055 if (io_code
== NULL
)
2058 c
= gfc_get_code ();
2059 c
->op
= EXEC_DT_END
;
2061 /* Point to structure that is already there */
2062 c
->ext
.dt
= new_st
.ext
.dt
;
2063 gfc_append_code (io_code
, c
);
2067 /* Match a READ, WRITE or PRINT statement. */
2070 match_io (io_kind k
)
2072 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2082 current_dt
= dt
= gfc_getmem (sizeof (gfc_dt
));
2084 if (gfc_match_char ('(') == MATCH_NO
)
2089 if (gfc_current_form
== FORM_FREE
)
2091 c
= gfc_peek_char();
2092 if (c
!= ' ' && c
!= '*' && c
!= '\'' && c
!= '"')
2099 m
= match_dt_format (dt
);
2100 if (m
== MATCH_ERROR
)
2106 dt
->io_unit
= default_unit (k
);
2110 /* Match a control list */
2111 if (match_dt_element (k
, dt
) == MATCH_YES
)
2113 if (match_dt_unit (k
, dt
) != MATCH_YES
)
2116 if (gfc_match_char (')') == MATCH_YES
)
2118 if (gfc_match_char (',') != MATCH_YES
)
2121 m
= match_dt_element (k
, dt
);
2124 if (m
== MATCH_ERROR
)
2127 m
= match_dt_format (dt
);
2130 if (m
== MATCH_ERROR
)
2133 where
= gfc_current_locus
;
2135 if (gfc_match_name (name
) == MATCH_YES
2136 && !gfc_find_symbol (name
, NULL
, 1, &sym
)
2137 && sym
->attr
.flavor
== FL_NAMELIST
)
2140 if (k
== M_READ
&& check_namelist (sym
))
2148 gfc_current_locus
= where
;
2150 goto loop
; /* No matches, try regular elements */
2153 if (gfc_match_char (')') == MATCH_YES
)
2155 if (gfc_match_char (',') != MATCH_YES
)
2161 m
= match_dt_element (k
, dt
);
2164 if (m
== MATCH_ERROR
)
2167 if (gfc_match_char (')') == MATCH_YES
)
2169 if (gfc_match_char (',') != MATCH_YES
)
2174 /* Optional leading comma (non-standard). */
2176 && gfc_match_char (',') == MATCH_YES
2178 && gfc_notify_std (GFC_STD_GNU
, "Extension: Comma before output "
2179 "item list at %C is an extension") == FAILURE
)
2183 if (gfc_match_eos () != MATCH_YES
)
2185 if (comma_flag
&& gfc_match_char (',') != MATCH_YES
)
2187 gfc_error ("Expected comma in I/O list at %C");
2192 m
= match_io_list (k
, &io_code
);
2193 if (m
== MATCH_ERROR
)
2199 /* A full IO statement has been matched. */
2200 if (dt
->io_unit
->expr_type
== EXPR_VARIABLE
2202 && dt
->io_unit
->ts
.type
== BT_CHARACTER
2203 && dt
->io_unit
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2205 gfc_error ("Internal file '%s' at %L is INTENT(IN)",
2206 dt
->io_unit
->symtree
->n
.sym
->name
, &dt
->io_unit
->where
);
2211 expr
= dt
->format_expr
;
2213 if (expr
!= NULL
&& expr
->expr_type
== EXPR_CONSTANT
)
2214 check_format_string (expr
);
2217 && (k
== M_READ
|| k
== M_WRITE
)
2218 && dt
->io_unit
->ts
.type
!= BT_CHARACTER
)
2221 ("io-unit in %s statement at %C must be an internal file in a "
2222 "PURE procedure", io_kind_name (k
));
2227 new_st
.op
= (k
== M_READ
) ? EXEC_READ
: EXEC_WRITE
;
2229 new_st
.next
= io_code
;
2231 terminate_io (io_code
);
2236 gfc_error ("Syntax error in %s statement at %C", io_kind_name (k
));
2246 gfc_match_read (void)
2248 return match_io (M_READ
);
2252 gfc_match_write (void)
2254 return match_io (M_WRITE
);
2258 gfc_match_print (void)
2262 m
= match_io (M_PRINT
);
2266 if (gfc_pure (NULL
))
2268 gfc_error ("PRINT statement at %C not allowed within PURE procedure");
2276 /* Free a gfc_inquire structure. */
2279 gfc_free_inquire (gfc_inquire
* inquire
)
2282 if (inquire
== NULL
)
2285 gfc_free_expr (inquire
->unit
);
2286 gfc_free_expr (inquire
->file
);
2287 gfc_free_expr (inquire
->iostat
);
2288 gfc_free_expr (inquire
->exist
);
2289 gfc_free_expr (inquire
->opened
);
2290 gfc_free_expr (inquire
->number
);
2291 gfc_free_expr (inquire
->named
);
2292 gfc_free_expr (inquire
->name
);
2293 gfc_free_expr (inquire
->access
);
2294 gfc_free_expr (inquire
->sequential
);
2295 gfc_free_expr (inquire
->direct
);
2296 gfc_free_expr (inquire
->form
);
2297 gfc_free_expr (inquire
->formatted
);
2298 gfc_free_expr (inquire
->unformatted
);
2299 gfc_free_expr (inquire
->recl
);
2300 gfc_free_expr (inquire
->nextrec
);
2301 gfc_free_expr (inquire
->blank
);
2302 gfc_free_expr (inquire
->position
);
2303 gfc_free_expr (inquire
->action
);
2304 gfc_free_expr (inquire
->read
);
2305 gfc_free_expr (inquire
->write
);
2306 gfc_free_expr (inquire
->readwrite
);
2307 gfc_free_expr (inquire
->delim
);
2308 gfc_free_expr (inquire
->pad
);
2309 gfc_free_expr (inquire
->iolength
);
2315 /* Match an element of an INQUIRE statement. */
2317 #define RETM if (m != MATCH_NO) return m;
2320 match_inquire_element (gfc_inquire
* inquire
)
2324 m
= match_etag (&tag_unit
, &inquire
->unit
);
2325 RETM m
= match_etag (&tag_file
, &inquire
->file
);
2326 RETM m
= match_ltag (&tag_err
, &inquire
->err
);
2327 RETM m
= match_out_tag (&tag_iostat
, &inquire
->iostat
);
2328 RETM m
= match_vtag (&tag_exist
, &inquire
->exist
);
2329 RETM m
= match_vtag (&tag_opened
, &inquire
->opened
);
2330 RETM m
= match_vtag (&tag_named
, &inquire
->named
);
2331 RETM m
= match_vtag (&tag_name
, &inquire
->name
);
2332 RETM m
= match_out_tag (&tag_number
, &inquire
->number
);
2333 RETM m
= match_vtag (&tag_s_access
, &inquire
->access
);
2334 RETM m
= match_vtag (&tag_sequential
, &inquire
->sequential
);
2335 RETM m
= match_vtag (&tag_direct
, &inquire
->direct
);
2336 RETM m
= match_vtag (&tag_s_form
, &inquire
->form
);
2337 RETM m
= match_vtag (&tag_formatted
, &inquire
->formatted
);
2338 RETM m
= match_vtag (&tag_unformatted
, &inquire
->unformatted
);
2339 RETM m
= match_out_tag (&tag_s_recl
, &inquire
->recl
);
2340 RETM m
= match_out_tag (&tag_nextrec
, &inquire
->nextrec
);
2341 RETM m
= match_vtag (&tag_s_blank
, &inquire
->blank
);
2342 RETM m
= match_vtag (&tag_s_position
, &inquire
->position
);
2343 RETM m
= match_vtag (&tag_s_action
, &inquire
->action
);
2344 RETM m
= match_vtag (&tag_read
, &inquire
->read
);
2345 RETM m
= match_vtag (&tag_write
, &inquire
->write
);
2346 RETM m
= match_vtag (&tag_readwrite
, &inquire
->readwrite
);
2347 RETM m
= match_vtag (&tag_s_delim
, &inquire
->delim
);
2348 RETM m
= match_vtag (&tag_s_pad
, &inquire
->pad
);
2349 RETM m
= match_vtag (&tag_iolength
, &inquire
->iolength
);
2350 RETM
return MATCH_NO
;
2357 gfc_match_inquire (void)
2359 gfc_inquire
*inquire
;
2363 m
= gfc_match_char ('(');
2367 inquire
= gfc_getmem (sizeof (gfc_inquire
));
2369 m
= match_inquire_element (inquire
);
2370 if (m
== MATCH_ERROR
)
2374 m
= gfc_match_expr (&inquire
->unit
);
2375 if (m
== MATCH_ERROR
)
2381 /* See if we have the IOLENGTH form of the inquire statement. */
2382 if (inquire
->iolength
!= NULL
)
2384 if (gfc_match_char (')') != MATCH_YES
)
2387 m
= match_io_list (M_INQUIRE
, &code
);
2388 if (m
== MATCH_ERROR
)
2393 terminate_io (code
);
2395 new_st
.op
= EXEC_IOLENGTH
;
2396 new_st
.expr
= inquire
->iolength
;
2397 new_st
.ext
.inquire
= inquire
;
2399 if (gfc_pure (NULL
))
2401 gfc_free_statements (code
);
2402 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
2410 /* At this point, we have the non-IOLENGTH inquire statement. */
2413 if (gfc_match_char (')') == MATCH_YES
)
2415 if (gfc_match_char (',') != MATCH_YES
)
2418 m
= match_inquire_element (inquire
);
2419 if (m
== MATCH_ERROR
)
2424 if (inquire
->iolength
!= NULL
)
2426 gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
2431 if (gfc_match_eos () != MATCH_YES
)
2434 if (gfc_pure (NULL
))
2436 gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
2440 new_st
.op
= EXEC_INQUIRE
;
2441 new_st
.ext
.inquire
= inquire
;
2445 gfc_syntax_error (ST_INQUIRE
);
2448 gfc_free_inquire (inquire
);
2453 /* Resolve everything in a gfc_inquire structure. */
2456 gfc_resolve_inquire (gfc_inquire
* inquire
)
2459 RESOLVE_TAG (&tag_unit
, inquire
->unit
);
2460 RESOLVE_TAG (&tag_file
, inquire
->file
);
2461 RESOLVE_TAG (&tag_iostat
, inquire
->iostat
);
2462 RESOLVE_TAG (&tag_exist
, inquire
->exist
);
2463 RESOLVE_TAG (&tag_opened
, inquire
->opened
);
2464 RESOLVE_TAG (&tag_number
, inquire
->number
);
2465 RESOLVE_TAG (&tag_named
, inquire
->named
);
2466 RESOLVE_TAG (&tag_name
, inquire
->name
);
2467 RESOLVE_TAG (&tag_s_access
, inquire
->access
);
2468 RESOLVE_TAG (&tag_sequential
, inquire
->sequential
);
2469 RESOLVE_TAG (&tag_direct
, inquire
->direct
);
2470 RESOLVE_TAG (&tag_s_form
, inquire
->form
);
2471 RESOLVE_TAG (&tag_formatted
, inquire
->formatted
);
2472 RESOLVE_TAG (&tag_unformatted
, inquire
->unformatted
);
2473 RESOLVE_TAG (&tag_s_recl
, inquire
->recl
);
2474 RESOLVE_TAG (&tag_nextrec
, inquire
->nextrec
);
2475 RESOLVE_TAG (&tag_s_blank
, inquire
->blank
);
2476 RESOLVE_TAG (&tag_s_position
, inquire
->position
);
2477 RESOLVE_TAG (&tag_s_action
, inquire
->action
);
2478 RESOLVE_TAG (&tag_read
, inquire
->read
);
2479 RESOLVE_TAG (&tag_write
, inquire
->write
);
2480 RESOLVE_TAG (&tag_readwrite
, inquire
->readwrite
);
2481 RESOLVE_TAG (&tag_s_delim
, inquire
->delim
);
2482 RESOLVE_TAG (&tag_s_pad
, inquire
->pad
);
2483 RESOLVE_TAG (&tag_iolength
, inquire
->iolength
);
2485 if (gfc_reference_st_label (inquire
->err
, ST_LABEL_TARGET
) == FAILURE
)