1	/* Deal with I/O statements & related stuff.
2	Copyright (C) 2000-2023 Free Software Foundation, Inc.
3	Contributed by Andy Vaught
4
5	This file is part of GCC.
6
7	GCC is free software; you can redistribute it and/or modify it under
8	the terms of the GNU General Public License as published by the Free
9	Software Foundation; either version 3, or (at your option) any later
10	version.
11
12	GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13	WARRANTY; without even the implied warranty of MERCHANTABILITY or
14	FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15	for more details.
16
17	You should have received a copy of the GNU General Public License
18	along with GCC; see the file COPYING3. If not see
19	<http://www.gnu.org/licenses/>. */
20
21	#include "config.h"
22	#include "system.h"
23	#include "coretypes.h"
24	#include "options.h"
25	#include "gfortran.h"
26	#include "match.h"
27	#include "parse.h"
28	#include "constructor.h"
29
30	gfc_st_label
31	format_asterisk = {.priority: 0, NULL, NULL, .value: -1, .defined: ST_LABEL_FORMAT, .referenced: ST_LABEL_FORMAT, NULL,
32	.backend_decl: 0, .where: {NULL, NULL}, NULL};
33
34	typedef struct
35	{
36	const char *name, *spec, *value;
37	bt type;
38	}
39	io_tag;
40
41	static const io_tag
42	tag_readonly = {.name: "READONLY", .spec: " readonly", NULL, .type: BT_UNKNOWN },
43	tag_shared = {.name: "SHARE", .spec: " shared", NULL, .type: BT_UNKNOWN },
44	tag_noshared = {.name: "SHARE", .spec: " noshared", NULL, .type: BT_UNKNOWN },
45	tag_e_share = {.name: "SHARE", .spec: " share =", .value: " %e", .type: BT_CHARACTER },
46	tag_v_share = {.name: "SHARE", .spec: " share =", .value: " %v", .type: BT_CHARACTER },
47	tag_cc = {.name: "CARRIAGECONTROL", .spec: " carriagecontrol =", .value: " %e",
48	.type: BT_CHARACTER },
49	tag_v_cc = {.name: "CARRIAGECONTROL", .spec: " carriagecontrol =", .value: " %v",
50	.type: BT_CHARACTER },
51	tag_file = {.name: "FILE", .spec: " file =", .value: " %e", .type: BT_CHARACTER },
52	tag_status = {.name: "STATUS", .spec: " status =", .value: " %e", .type: BT_CHARACTER},
53	tag_e_access = {.name: "ACCESS", .spec: " access =", .value: " %e", .type: BT_CHARACTER},
54	tag_e_form = {.name: "FORM", .spec: " form =", .value: " %e", .type: BT_CHARACTER},
55	tag_e_recl = {.name: "RECL", .spec: " recl =", .value: " %e", .type: BT_INTEGER},
56	tag_e_blank = {.name: "BLANK", .spec: " blank =", .value: " %e", .type: BT_CHARACTER},
57	tag_e_position = {.name: "POSITION", .spec: " position =", .value: " %e", .type: BT_CHARACTER},
58	tag_e_action = {.name: "ACTION", .spec: " action =", .value: " %e", .type: BT_CHARACTER},
59	tag_e_delim = {.name: "DELIM", .spec: " delim =", .value: " %e", .type: BT_CHARACTER},
60	tag_e_pad = {.name: "PAD", .spec: " pad =", .value: " %e", .type: BT_CHARACTER},
61	tag_e_decimal = {.name: "DECIMAL", .spec: " decimal =", .value: " %e", .type: BT_CHARACTER},
62	tag_e_encoding = {.name: "ENCODING", .spec: " encoding =", .value: " %e", .type: BT_CHARACTER},
63	tag_e_async = {.name: "ASYNCHRONOUS", .spec: " asynchronous =", .value: " %e", .type: BT_CHARACTER},
64	tag_e_round = {.name: "ROUND", .spec: " round =", .value: " %e", .type: BT_CHARACTER},
65	tag_e_sign = {.name: "SIGN", .spec: " sign =", .value: " %e", .type: BT_CHARACTER},
66	tag_unit = {.name: "UNIT", .spec: " unit =", .value: " %e", .type: BT_INTEGER},
67	tag_advance = {.name: "ADVANCE", .spec: " advance =", .value: " %e", .type: BT_CHARACTER},
68	tag_rec = {.name: "REC", .spec: " rec =", .value: " %e", .type: BT_INTEGER},
69	tag_spos = {.name: "POSITION", .spec: " pos =", .value: " %e", .type: BT_INTEGER},
70	tag_format = {.name: "FORMAT", NULL, NULL, .type: BT_CHARACTER},
71	tag_iomsg = {.name: "IOMSG", .spec: " iomsg =", .value: " %e", .type: BT_CHARACTER},
72	tag_iostat = {.name: "IOSTAT", .spec: " iostat =", .value: " %v", .type: BT_INTEGER},
73	tag_size = {.name: "SIZE", .spec: " size =", .value: " %v", .type: BT_INTEGER},
74	tag_exist = {.name: "EXIST", .spec: " exist =", .value: " %v", .type: BT_LOGICAL},
75	tag_opened = {.name: "OPENED", .spec: " opened =", .value: " %v", .type: BT_LOGICAL},
76	tag_named = {.name: "NAMED", .spec: " named =", .value: " %v", .type: BT_LOGICAL},
77	tag_name = {.name: "NAME", .spec: " name =", .value: " %v", .type: BT_CHARACTER},
78	tag_number = {.name: "NUMBER", .spec: " number =", .value: " %v", .type: BT_INTEGER},
79	tag_s_access = {.name: "ACCESS", .spec: " access =", .value: " %v", .type: BT_CHARACTER},
80	tag_sequential = {.name: "SEQUENTIAL", .spec: " sequential =", .value: " %v", .type: BT_CHARACTER},
81	tag_direct = {.name: "DIRECT", .spec: " direct =", .value: " %v", .type: BT_CHARACTER},
82	tag_s_form = {.name: "FORM", .spec: " form =", .value: " %v", .type: BT_CHARACTER},
83	tag_formatted = {.name: "FORMATTED", .spec: " formatted =", .value: " %v", .type: BT_CHARACTER},
84	tag_unformatted = {.name: "UNFORMATTED", .spec: " unformatted =", .value: " %v", .type: BT_CHARACTER},
85	tag_s_recl = {.name: "RECL", .spec: " recl =", .value: " %v", .type: BT_INTEGER},
86	tag_nextrec = {.name: "NEXTREC", .spec: " nextrec =", .value: " %v", .type: BT_INTEGER},
87	tag_s_blank = {.name: "BLANK", .spec: " blank =", .value: " %v", .type: BT_CHARACTER},
88	tag_s_position = {.name: "POSITION", .spec: " position =", .value: " %v", .type: BT_CHARACTER},
89	tag_s_action = {.name: "ACTION", .spec: " action =", .value: " %v", .type: BT_CHARACTER},
90	tag_read = {.name: "READ", .spec: " read =", .value: " %v", .type: BT_CHARACTER},
91	tag_write = {.name: "WRITE", .spec: " write =", .value: " %v", .type: BT_CHARACTER},
92	tag_readwrite = {.name: "READWRITE", .spec: " readwrite =", .value: " %v", .type: BT_CHARACTER},
93	tag_s_delim = {.name: "DELIM", .spec: " delim =", .value: " %v", .type: BT_CHARACTER},
94	tag_s_pad = {.name: "PAD", .spec: " pad =", .value: " %v", .type: BT_CHARACTER},
95	tag_s_decimal = {.name: "DECIMAL", .spec: " decimal =", .value: " %v", .type: BT_CHARACTER},
96	tag_s_encoding = {.name: "ENCODING", .spec: " encoding =", .value: " %v", .type: BT_CHARACTER},
97	tag_s_async = {.name: "ASYNCHRONOUS", .spec: " asynchronous =", .value: " %v", .type: BT_CHARACTER},
98	tag_s_round = {.name: "ROUND", .spec: " round =", .value: " %v", .type: BT_CHARACTER},
99	tag_s_sign = {.name: "SIGN", .spec: " sign =", .value: " %v", .type: BT_CHARACTER},
100	tag_iolength = {.name: "IOLENGTH", .spec: " iolength =", .value: " %v", .type: BT_INTEGER},
101	tag_convert = {.name: "CONVERT", .spec: " convert =", .value: " %e", .type: BT_CHARACTER},
102	tag_strm_out = {.name: "POS", .spec: " pos =", .value: " %v", .type: BT_INTEGER},
103	tag_err = {.name: "ERR", .spec: " err =", .value: " %l", .type: BT_UNKNOWN},
104	tag_end = {.name: "END", .spec: " end =", .value: " %l", .type: BT_UNKNOWN},
105	tag_eor = {.name: "EOR", .spec: " eor =", .value: " %l", .type: BT_UNKNOWN},
106	tag_id = {.name: "ID", .spec: " id =", .value: " %v", .type: BT_INTEGER},
107	tag_pending = {.name: "PENDING", .spec: " pending =", .value: " %v", .type: BT_LOGICAL},
108	tag_newunit = {.name: "NEWUNIT", .spec: " newunit =", .value: " %v", .type: BT_INTEGER},
109	tag_s_iqstream = {.name: "STREAM", .spec: " stream =", .value: " %v", .type: BT_CHARACTER};
110
111	static gfc_dt *current_dt;
112
113	#define RESOLVE_TAG(x, y) if (!resolve_tag (x, y)) return false;
114
115	/**************** Fortran 95 FORMAT parser *****************/
116
117	/* FORMAT tokens returned by format_lex(). */
118	enum format_token
119	{
120	FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
121	FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN,
122	FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F,
123	FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END,
124	FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC,
125	FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT
126	};
127
128	/* Local variables for checking format strings. The saved_token is
129	used to back up by a single format token during the parsing
130	process. */
131	static gfc_char_t *format_string;
132	static int format_string_pos;
133	static int format_length, use_last_char;
134	static char error_element;
135	static locus format_locus;
136
137	static format_token saved_token;
138
139	static enum
140	{ MODE_STRING, MODE_FORMAT, MODE_COPY }
141	mode;
142
143
144	/* Return the next character in the format string. */
145
146	static char
147	next_char (gfc_instring in_string)
148	{
149	static gfc_char_t c;
150
151	if (use_last_char)
152	{
153	use_last_char = 0;
154	return c;
155	}
156
157	format_length++;
158
159	if (mode == MODE_STRING)
160	c = *format_string++;
161	else
162	{
163	c = gfc_next_char_literal (in_string);
164	if (c == '\n')
165	c = '\0';
166	}
167
168	if (flag_backslash && c == '\\')
169	{
170	locus old_locus = gfc_current_locus;
171
172	if (gfc_match_special_char (&c) == MATCH_NO)
173	gfc_current_locus = old_locus;
174
175	if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
176	gfc_warning (opt: 0, "Extension: backslash character at %C");
177	}
178
179	if (mode == MODE_COPY)
180	*format_string++ = c;
181
182	if (mode != MODE_STRING)
183	format_locus = gfc_current_locus;
184
185	format_string_pos++;
186
187	c = gfc_wide_toupper (c);
188	return c;
189	}
190
191
192	/* Back up one character position. Only works once. */
193
194	static void
195	unget_char (void)
196	{
197	use_last_char = 1;
198	}
199
200	/* Eat up the spaces and return a character. */
201
202	static char
203	next_char_not_space ()
204	{
205	char c;
206	do
207	{
208	error_element = c = next_char (in_string: NONSTRING);
209	if (c == '\t')
210	gfc_warning (opt: OPT_Wtabs, "Nonconforming tab character in format at %C");
211	}
212	while (gfc_is_whitespace (c));
213	return c;
214	}
215
216	static int value = 0;
217
218	/* Simple lexical analyzer for getting the next token in a FORMAT
219	statement. */
220
221	static format_token
222	format_lex (void)
223	{
224	format_token token;
225	char c, delim;
226	int zflag;
227	int negative_flag;
228
229	if (saved_token != FMT_NONE)
230	{
231	token = saved_token;
232	saved_token = FMT_NONE;
233	return token;
234	}
235
236	c = next_char_not_space ();
237
238	negative_flag = 0;
239	switch (c)
240	{
241	case '-':
242	negative_flag = 1;
243	/* Falls through. */
244
245	case '+':
246	c = next_char_not_space ();
247	if (!ISDIGIT (c))
248	{
249	token = FMT_UNKNOWN;
250	break;
251	}
252
253	value = c - '0';
254
255	do
256	{
257	c = next_char_not_space ();
258	if (ISDIGIT (c))
259	value = 10 * value + c - '0';
260	}
261	while (ISDIGIT (c));
262
263	unget_char ();
264
265	if (negative_flag)
266	value = -value;
267
268	token = FMT_SIGNED_INT;
269	break;
270
271	case '0':
272	case '1':
273	case '2':
274	case '3':
275	case '4':
276	case '5':
277	case '6':
278	case '7':
279	case '8':
280	case '9':
281	zflag = (c == '0');
282
283	value = c - '0';
284
285	do
286	{
287	c = next_char_not_space ();
288	if (ISDIGIT (c))
289	{
290	value = 10 * value + c - '0';
291	if (c != '0')
292	zflag = 0;
293	}
294	}
295	while (ISDIGIT (c));
296
297	unget_char ();
298	token = zflag ? FMT_ZERO : FMT_POSINT;
299	break;
300
301	case '.':
302	token = FMT_PERIOD;
303	break;
304
305	case ',':
306	token = FMT_COMMA;
307	break;
308
309	case ':':
310	token = FMT_COLON;
311	break;
312
313	case '/':
314	token = FMT_SLASH;
315	break;
316
317	case '$':
318	token = FMT_DOLLAR;
319	break;
320
321	case 'T':
322	c = next_char_not_space ();
323	switch (c)
324	{
325	case 'L':
326	token = FMT_TL;
327	break;
328	case 'R':
329	token = FMT_TR;
330	break;
331	default:
332	token = FMT_T;
333	unget_char ();
334	}
335	break;
336
337	case '(':
338	token = FMT_LPAREN;
339	break;
340
341	case ')':
342	token = FMT_RPAREN;
343	break;
344
345	case 'X':
346	token = FMT_X;
347	break;
348
349	case 'S':
350	c = next_char_not_space ();
351	if (c != 'P' && c != 'S')
352	unget_char ();
353
354	token = FMT_SIGN;
355	break;
356
357	case 'B':
358	c = next_char_not_space ();
359	if (c == 'N' || c == 'Z')
360	token = FMT_BLANK;
361	else
362	{
363	unget_char ();
364	token = FMT_IBOZ;
365	}
366
367	break;
368
369	case '\'':
370	case '"':
371	delim = c;
372
373	value = 0;
374
375	for (;;)
376	{
377	c = next_char (in_string: INSTRING_WARN);
378	if (c == '\0')
379	{
380	token = FMT_END;
381	break;
382	}
383
384	if (c == delim)
385	{
386	c = next_char (in_string: NONSTRING);
387
388	if (c == '\0')
389	{
390	token = FMT_END;
391	break;
392	}
393
394	if (c != delim)
395	{
396	unget_char ();
397	token = FMT_CHAR;
398	break;
399	}
400	}
401	value++;
402	}
403	break;
404
405	case 'P':
406	token = FMT_P;
407	break;
408
409	case 'I':
410	case 'O':
411	case 'Z':
412	token = FMT_IBOZ;
413	break;
414
415	case 'F':
416	token = FMT_F;
417	break;
418
419	case 'E':
420	c = next_char_not_space ();
421	if (c == 'N' )
422	token = FMT_EN;
423	else if (c == 'S')
424	token = FMT_ES;
425	else
426	{
427	token = FMT_E;
428	unget_char ();
429	}
430
431	break;
432
433	case 'G':
434	token = FMT_G;
435	break;
436
437	case 'H':
438	token = FMT_H;
439	break;
440
441	case 'L':
442	token = FMT_L;
443	break;
444
445	case 'A':
446	token = FMT_A;
447	break;
448
449	case 'D':
450	c = next_char_not_space ();
451	if (c == 'P')
452	{
453	if (!gfc_notify_std (GFC_STD_F2003, "DP format "
454	"specifier not allowed at %C"))
455	return FMT_ERROR;
456	token = FMT_DP;
457	}
458	else if (c == 'C')
459	{
460	if (!gfc_notify_std (GFC_STD_F2003, "DC format "
461	"specifier not allowed at %C"))
462	return FMT_ERROR;
463	token = FMT_DC;
464	}
465	else if (c == 'T')
466	{
467	if (!gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DT format "
468	"specifier not allowed at %C"))
469	return FMT_ERROR;
470	token = FMT_DT;
471	c = next_char_not_space ();
472	if (c == '\'' || c == '"')
473	{
474	delim = c;
475	value = 0;
476
477	for (;;)
478	{
479	c = next_char (in_string: INSTRING_WARN);
480	if (c == '\0')
481	{
482	token = FMT_END;
483	break;
484	}
485
486	if (c == delim)
487	{
488	c = next_char (in_string: NONSTRING);
489	if (c == '\0')
490	{
491	token = FMT_END;
492	break;
493	}
494	if (c == '/')
495	{
496	token = FMT_SLASH;
497	break;
498	}
499	if (c == delim)
500	continue;
501	unget_char ();
502	break;
503	}
504	}
505	}
506	else if (c == '/')
507	{
508	token = FMT_SLASH;
509	break;
510	}
511	else
512	unget_char ();
513	}
514	else
515	{
516	token = FMT_D;
517	unget_char ();
518	}
519	break;
520
521	case 'R':
522	c = next_char_not_space ();
523	switch (c)
524	{
525	case 'C':
526	token = FMT_RC;
527	break;
528	case 'D':
529	token = FMT_RD;
530	break;
531	case 'N':
532	token = FMT_RN;
533	break;
534	case 'P':
535	token = FMT_RP;
536	break;
537	case 'U':
538	token = FMT_RU;
539	break;
540	case 'Z':
541	token = FMT_RZ;
542	break;
543	default:
544	token = FMT_UNKNOWN;
545	unget_char ();
546	break;
547	}
548	break;
549
550	case '\0':
551	token = FMT_END;
552	break;
553
554	case '*':
555	token = FMT_STAR;
556	break;
557
558	default:
559	token = FMT_UNKNOWN;
560	break;
561	}
562
563	return token;
564	}
565
566
567	static const char *
568	token_to_string (format_token t)
569	{
570	switch (t)
571	{
572	case FMT_D:
573	return "D";
574	case FMT_G:
575	return "G";
576	case FMT_E:
577	return "E";
578	case FMT_EN:
579	return "EN";
580	case FMT_ES:
581	return "ES";
582	default:
583	return "";
584	}
585	}
586
587	/* Check a format statement. The format string, either from a FORMAT
588	statement or a constant in an I/O statement has already been parsed
589	by itself, and we are checking it for validity. The dual origin
590	means that the warning message is a little less than great. */
591
592	static bool
593	check_format (bool is_input)
594	{
595	const char *posint_required
596	= G_("Positive width required in format string at %L");
597	const char *nonneg_required
598	= G_("Nonnegative width required in format string at %L");
599	const char *unexpected_element
600	= G_("Unexpected element %qc in format string at %L");
601	const char *unexpected_end
602	= G_("Unexpected end of format string in format string at %L");
603	const char *zero_width
604	= G_("Zero width in format descriptor in format string at %L");
605
606	const char *error = NULL;
607	format_token t, u;
608	int level;
609	int repeat;
610	bool rv;
611
612	use_last_char = 0;
613	saved_token = FMT_NONE;
614	level = 0;
615	repeat = 0;
616	rv = true;
617	format_string_pos = 0;
618
619	t = format_lex ();
620	if (t == FMT_ERROR)
621	goto fail;
622	if (t != FMT_LPAREN)
623	{
624	error = G_("Missing leading left parenthesis in format string at %L");
625	goto syntax;
626	}
627
628	t = format_lex ();
629	if (t == FMT_ERROR)
630	goto fail;
631	if (t == FMT_RPAREN)
632	goto finished; /* Empty format is legal */
633	saved_token = t;
634
635	format_item:
636	/* In this state, the next thing has to be a format item. */
637	t = format_lex ();
638	if (t == FMT_ERROR)
639	goto fail;
640	format_item_1:
641	switch (t)
642	{
643	case FMT_STAR:
644	repeat = -1;
645	t = format_lex ();
646	if (t == FMT_ERROR)
647	goto fail;
648	if (t == FMT_LPAREN)
649	{
650	level++;
651	goto format_item;
652	}
653	error = G_("Left parenthesis required after %<*%> in format string "
654	"at %L");
655	goto syntax;
656
657	case FMT_POSINT:
658	repeat = value;
659	t = format_lex ();
660	if (t == FMT_ERROR)
661	goto fail;
662	if (t == FMT_LPAREN)
663	{
664	level++;
665	goto format_item;
666	}
667
668	if (t == FMT_SLASH)
669	goto optional_comma;
670
671	goto data_desc;
672
673	case FMT_LPAREN:
674	level++;
675	goto format_item;
676
677	case FMT_SIGNED_INT:
678	case FMT_ZERO:
679	/* Signed integer can only precede a P format. */
680	t = format_lex ();
681	if (t == FMT_ERROR)
682	goto fail;
683	if (t != FMT_P)
684	{
685	error = G_("Expected P edit descriptor in format string at %L");
686	goto syntax;
687	}
688
689	goto data_desc;
690
691	case FMT_P:
692	/* P requires a prior number. */
693	error = G_("P descriptor requires leading scale factor in format "
694	"string at %L");
695	goto syntax;
696
697	case FMT_X:
698	/* X requires a prior number if we're being pedantic. */
699	if (mode != MODE_FORMAT)
700	format_locus.nextc += format_string_pos;
701	if (!gfc_notify_std (GFC_STD_GNU, "X descriptor requires leading "
702	"space count at %L", &format_locus))
703	return false;
704	goto between_desc;
705
706	case FMT_SIGN:
707	case FMT_BLANK:
708	case FMT_DP:
709	case FMT_DC:
710	case FMT_RC:
711	case FMT_RD:
712	case FMT_RN:
713	case FMT_RP:
714	case FMT_RU:
715	case FMT_RZ:
716	goto between_desc;
717
718	case FMT_CHAR:
719	goto extension_optional_comma;
720
721	case FMT_COLON:
722	case FMT_SLASH:
723	goto optional_comma;
724
725	case FMT_DOLLAR:
726	t = format_lex ();
727	if (t == FMT_ERROR)
728	goto fail;
729
730	if (!gfc_notify_std (GFC_STD_GNU, "$ descriptor at %L", &format_locus))
731	return false;
732	if (t != FMT_RPAREN || level > 0)
733	{
734	gfc_warning (opt: 0, "$ should be the last specifier in format at %L",
735	&format_locus);
736	goto optional_comma_1;
737	}
738
739	goto finished;
740
741	case FMT_T:
742	case FMT_TL:
743	case FMT_TR:
744	case FMT_IBOZ:
745	case FMT_F:
746	case FMT_E:
747	case FMT_EN:
748	case FMT_ES:
749	case FMT_G:
750	case FMT_L:
751	case FMT_A:
752	case FMT_D:
753	case FMT_H:
754	case FMT_DT:
755	goto data_desc;
756
757	case FMT_END:
758	error = unexpected_end;
759	goto syntax;
760
761	case FMT_RPAREN:
762	if (flag_dec_blank_format_item)
763	goto finished;
764	else
765	{
766	error = G_("Missing item in format string at %L");
767	goto syntax;
768	}
769
770	default:
771	error = unexpected_element;
772	goto syntax;
773	}
774
775	data_desc:
776	/* In this state, t must currently be a data descriptor.
777	Deal with things that can/must follow the descriptor. */
778	switch (t)
779	{
780	case FMT_SIGN:
781	case FMT_BLANK:
782	case FMT_DP:
783	case FMT_DC:
784	case FMT_X:
785	break;
786
787	case FMT_P:
788	/* No comma after P allowed only for F, E, EN, ES, D, or G.
789	10.1.1 (1). */
790	t = format_lex ();
791	if (t == FMT_ERROR)
792	goto fail;
793	if (!(gfc_option.allow_std & GFC_STD_F2003) && t != FMT_COMMA
794	&& t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES
795	&& t != FMT_D && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH)
796	{
797	error = G_("Comma required after P descriptor in format string "
798	"at %L");
799	goto syntax;
800	}
801	if (t != FMT_COMMA)
802	{
803	if (t == FMT_POSINT)
804	{
805	t = format_lex ();
806	if (t == FMT_ERROR)
807	goto fail;
808	}
809	if (t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES
810	&& t != FMT_D && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH)
811	{
812	error = G_("Comma required after P descriptor in format string "
813	"at %L");
814	goto syntax;
815	}
816	}
817
818	saved_token = t;
819	goto optional_comma;
820
821	case FMT_T:
822	case FMT_TL:
823	case FMT_TR:
824	t = format_lex ();
825	if (t != FMT_POSINT)
826	{
827	error = G_("Positive width required with T descriptor in format "
828	"string at %L");
829	goto syntax;
830	}
831	break;
832
833	case FMT_L:
834	t = format_lex ();
835	if (t == FMT_ERROR)
836	goto fail;
837	if (t == FMT_POSINT)
838	break;
839	if (mode != MODE_FORMAT)
840	format_locus.nextc += format_string_pos;
841	if (t == FMT_ZERO)
842	{
843	switch (gfc_notification_std (GFC_STD_GNU))
844	{
845	case WARNING:
846	gfc_warning (opt: 0, "Extension: Zero width after L "
847	"descriptor at %L", &format_locus);
848	break;
849	case ERROR:
850	gfc_error ("Extension: Zero width after L "
851	"descriptor at %L", &format_locus);
852	goto fail;
853	case SILENT:
854	break;
855	default:
856	gcc_unreachable ();
857	}
858	}
859	else
860	{
861	saved_token = t;
862	gfc_notify_std (GFC_STD_GNU, "Missing positive width after "
863	"L descriptor at %L", &format_locus);
864	}
865	break;
866
867	case FMT_A:
868	t = format_lex ();
869	if (t == FMT_ERROR)
870	goto fail;
871	if (t == FMT_ZERO)
872	{
873	error = zero_width;
874	goto syntax;
875	}
876	if (t != FMT_POSINT)
877	saved_token = t;
878	break;
879
880	case FMT_D:
881	case FMT_E:
882	case FMT_G:
883	case FMT_EN:
884	case FMT_ES:
885	u = format_lex ();
886	if (t == FMT_G && u == FMT_ZERO)
887	{
888	if (is_input)
889	{
890	error = zero_width;
891	goto syntax;
892	}
893	if (!gfc_notify_std (GFC_STD_F2008, "%<G0%> in format at %L",
894	&format_locus))
895	return false;
896	u = format_lex ();
897	if (u != FMT_PERIOD)
898	{
899	saved_token = u;
900	break;
901	}
902	u = format_lex ();
903	if (u != FMT_POSINT)
904	{
905	error = posint_required;
906	goto syntax;
907	}
908	u = format_lex ();
909	if (u == FMT_E)
910	{
911	error = G_("E specifier not allowed with g0 descriptor in "
912	"format string at %L");
913	goto syntax;
914	}
915	saved_token = u;
916	break;
917	}
918
919	if (u != FMT_POSINT)
920	{
921	if (flag_dec)
922	{
923	if (flag_dec_format_defaults)
924	{
925	/* Assume a default width based on the variable size. */
926	saved_token = u;
927	break;
928	}
929	else
930	{
931	gfc_error ("Positive width required in format "
932	"specifier %s at %L", token_to_string (t),
933	&format_locus);
934	saved_token = u;
935	goto fail;
936	}
937	}
938
939	format_locus.nextc += format_string_pos;
940	if (!gfc_notify_std (GFC_STD_F2018,
941	"positive width required at %L",
942	&format_locus))
943	{
944	saved_token = u;
945	goto fail;
946	}
947	if (flag_dec_format_defaults)
948	{
949	/* Assume a default width based on the variable size. */
950	saved_token = u;
951	break;
952	}
953	}
954
955	u = format_lex ();
956	if (u == FMT_ERROR)
957	goto fail;
958	if (u != FMT_PERIOD)
959	{
960	/* Warn if -std=legacy, otherwise error. */
961	format_locus.nextc += format_string_pos;
962	if (gfc_option.warn_std != 0)
963	{
964	gfc_error ("Period required in format "
965	"specifier %s at %L", token_to_string (t),
966	&format_locus);
967	saved_token = u;
968	goto fail;
969	}
970	else
971	gfc_warning (opt: 0, "Period required in format "
972	"specifier %s at %L", token_to_string (t),
973	&format_locus);
974	/* If we go to finished, we need to unwind this
975	before the next round. */
976	format_locus.nextc -= format_string_pos;
977	saved_token = u;
978	break;
979	}
980
981	u = format_lex ();
982	if (u == FMT_ERROR)
983	goto fail;
984	if (u != FMT_ZERO && u != FMT_POSINT)
985	{
986	error = nonneg_required;
987	goto syntax;
988	}
989
990	if (t == FMT_D)
991	break;
992
993	/* Look for optional exponent. */
994	u = format_lex ();
995	if (u == FMT_ERROR)
996	goto fail;
997	if (u != FMT_E)
998	saved_token = u;
999	else
1000	{
1001	u = format_lex ();
1002	if (u == FMT_ERROR)
1003	goto fail;
1004	if (u != FMT_POSINT)
1005	{
1006	if (u == FMT_ZERO)
1007	{
1008	if (!gfc_notify_std (GFC_STD_F2018,
1009	"Positive exponent width required in "
1010	"format string at %L", &format_locus))
1011	{
1012	saved_token = u;
1013	goto fail;
1014	}
1015	}
1016	else
1017	{
1018	error = G_("Positive exponent width required in format "
1019	"string at %L");
1020	goto syntax;
1021	}
1022	}
1023	}
1024
1025	break;
1026
1027	case FMT_DT:
1028	t = format_lex ();
1029	if (t == FMT_ERROR)
1030	goto fail;
1031	switch (t)
1032	{
1033	case FMT_RPAREN:
1034	level--;
1035	if (level < 0)
1036	goto finished;
1037	goto between_desc;
1038
1039	case FMT_COMMA:
1040	goto format_item;
1041
1042	case FMT_COLON:
1043	goto format_item_1;
1044
1045	case FMT_LPAREN:
1046
1047	dtio_vlist:
1048	t = format_lex ();
1049	if (t == FMT_ERROR)
1050	goto fail;
1051
1052	if (t != FMT_POSINT)
1053	{
1054	error = posint_required;
1055	goto syntax;
1056	}
1057
1058	t = format_lex ();
1059	if (t == FMT_ERROR)
1060	goto fail;
1061
1062	if (t == FMT_COMMA)
1063	goto dtio_vlist;
1064	if (t != FMT_RPAREN)
1065	{
1066	error = G_("Right parenthesis expected at %C in format string "
1067	"at %L");
1068	goto syntax;
1069	}
1070	goto between_desc;
1071
1072	default:
1073	error = unexpected_element;
1074	goto syntax;
1075	}
1076	break;
1077
1078	case FMT_F:
1079	t = format_lex ();
1080	if (t == FMT_ERROR)
1081	goto fail;
1082	if (t != FMT_ZERO && t != FMT_POSINT)
1083	{
1084	if (flag_dec_format_defaults)
1085	{
1086	/* Assume the default width is expected here and continue lexing. */
1087	value = 0; /* It doesn't matter what we set the value to here. */
1088	saved_token = t;
1089	break;
1090	}
1091	error = nonneg_required;
1092	goto syntax;
1093	}
1094	else if (is_input && t == FMT_ZERO)
1095	{
1096	error = posint_required;
1097	goto syntax;
1098	}
1099
1100	t = format_lex ();
1101	if (t == FMT_ERROR)
1102	goto fail;
1103	if (t != FMT_PERIOD)
1104	{
1105	/* Warn if -std=legacy, otherwise error. */
1106	if (gfc_option.warn_std != 0)
1107	{
1108	error = G_("Period required in format specifier in format "
1109	"string at %L");
1110	goto syntax;
1111	}
1112	if (mode != MODE_FORMAT)
1113	format_locus.nextc += format_string_pos;
1114	gfc_warning (opt: 0, "Period required in format specifier at %L",
1115	&format_locus);
1116	saved_token = t;
1117	break;
1118	}
1119
1120	t = format_lex ();
1121	if (t == FMT_ERROR)
1122	goto fail;
1123	if (t != FMT_ZERO && t != FMT_POSINT)
1124	{
1125	error = nonneg_required;
1126	goto syntax;
1127	}
1128
1129	break;
1130
1131	case FMT_H:
1132	if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
1133	{
1134	if (mode != MODE_FORMAT)
1135	format_locus.nextc += format_string_pos;
1136	gfc_warning (opt: 0, "The H format specifier at %L is"
1137	" a Fortran 95 deleted feature", &format_locus);
1138	}
1139	if (mode == MODE_STRING)
1140	{
1141	format_string += value;
1142	format_length -= value;
1143	format_string_pos += repeat;
1144	}
1145	else
1146	{
1147	while (repeat >0)
1148	{
1149	next_char (in_string: INSTRING_WARN);
1150	repeat -- ;
1151	}
1152	}
1153	break;
1154
1155	case FMT_IBOZ:
1156	t = format_lex ();
1157	if (t == FMT_ERROR)
1158	goto fail;
1159	if (t != FMT_ZERO && t != FMT_POSINT)
1160	{
1161	if (flag_dec_format_defaults)
1162	{
1163	/* Assume the default width is expected here and continue lexing. */
1164	value = 0; /* It doesn't matter what we set the value to here. */
1165	saved_token = t;
1166	}
1167	else
1168	{
1169	error = nonneg_required;
1170	goto syntax;
1171	}
1172	}
1173	else if (is_input && t == FMT_ZERO)
1174	{
1175	error = posint_required;
1176	goto syntax;
1177	}
1178
1179	t = format_lex ();
1180	if (t == FMT_ERROR)
1181	goto fail;
1182	if (t != FMT_PERIOD)
1183	saved_token = t;
1184	else
1185	{
1186	t = format_lex ();
1187	if (t == FMT_ERROR)
1188	goto fail;
1189	if (t != FMT_ZERO && t != FMT_POSINT)
1190	{
1191	error = nonneg_required;
1192	goto syntax;
1193	}
1194	}
1195
1196	break;
1197
1198	default:
1199	error = unexpected_element;
1200	goto syntax;
1201	}
1202
1203	between_desc:
1204	/* Between a descriptor and what comes next. */
1205	t = format_lex ();
1206	if (t == FMT_ERROR)
1207	goto fail;
1208	switch (t)
1209	{
1210
1211	case FMT_COMMA:
1212	goto format_item;
1213
1214	case FMT_RPAREN:
1215	level--;
1216	if (level < 0)
1217	goto finished;
1218	goto between_desc;
1219
1220	case FMT_COLON:
1221	case FMT_SLASH:
1222	goto optional_comma;
1223
1224	case FMT_END:
1225	error = unexpected_end;
1226	goto syntax;
1227
1228	default:
1229	if (mode != MODE_FORMAT)
1230	format_locus.nextc += format_string_pos - 1;
1231	if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus))
1232	return false;
1233	/* If we do not actually return a failure, we need to unwind this
1234	before the next round. */
1235	if (mode != MODE_FORMAT)
1236	format_locus.nextc -= format_string_pos;
1237	goto format_item_1;
1238	}
1239
1240	optional_comma:
1241	/* Optional comma is a weird between state where we've just finished
1242	reading a colon, slash, dollar or P descriptor. */
1243	t = format_lex ();
1244	if (t == FMT_ERROR)
1245	goto fail;
1246	optional_comma_1:
1247	switch (t)
1248	{
1249	case FMT_COMMA:
1250	break;
1251
1252	case FMT_RPAREN:
1253	level--;
1254	if (level < 0)
1255	goto finished;
1256	goto between_desc;
1257
1258	default:
1259	/* Assume that we have another format item. */
1260	saved_token = t;
1261	break;
1262	}
1263
1264	goto format_item;
1265
1266	extension_optional_comma:
1267	/* As a GNU extension, permit a missing comma after a string literal. */
1268	t = format_lex ();
1269	if (t == FMT_ERROR)
1270	goto fail;
1271	switch (t)
1272	{
1273	case FMT_COMMA:
1274	break;
1275
1276	case FMT_RPAREN:
1277	level--;
1278	if (level < 0)
1279	goto finished;
1280	goto between_desc;
1281
1282	case FMT_COLON:
1283	case FMT_SLASH:
1284	goto optional_comma;
1285
1286	case FMT_END:
1287	error = unexpected_end;
1288	goto syntax;
1289
1290	default:
1291	if (mode != MODE_FORMAT)
1292	format_locus.nextc += format_string_pos;
1293	if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus))
1294	return false;
1295	/* If we do not actually return a failure, we need to unwind this
1296	before the next round. */
1297	if (mode != MODE_FORMAT)
1298	format_locus.nextc -= format_string_pos;
1299	saved_token = t;
1300	break;
1301	}
1302
1303	goto format_item;
1304
1305	syntax:
1306	if (mode != MODE_FORMAT)
1307	format_locus.nextc += format_string_pos;
1308	if (error == unexpected_element)
1309	gfc_error (error, error_element, &format_locus);
1310	else
1311	gfc_error (error, &format_locus);
1312	fail:
1313	rv = false;
1314
1315	finished:
1316	return rv;
1317	}
1318
1319
1320	/* Given an expression node that is a constant string, see if it looks
1321	like a format string. */
1322
1323	static bool
1324	check_format_string (gfc_expr *e, bool is_input)
1325	{
1326	bool rv;
1327	int i;
1328	if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1329	return true;
1330
1331	mode = MODE_STRING;
1332	format_string = e->value.character.string;
1333
1334	/* More elaborate measures are needed to show where a problem is within a
1335	format string that has been calculated, but that's probably not worth the
1336	effort. */
1337	format_locus = e->where;
1338	rv = check_format (is_input);
1339	/* check for extraneous characters at the end of an otherwise valid format
1340	string, like '(A10,I3)F5'
1341	start at the end and move back to the last character processed,
1342	spaces are OK */
1343	if (rv && e->value.character.length > format_string_pos)
1344	for (i=e->value.character.length-1;i>format_string_pos-1;i--)
1345	if (e->value.character.string[i] != ' ')
1346	{
1347	format_locus.nextc += format_length + 1;
1348	gfc_warning (opt: 0,
1349	"Extraneous characters in format at %L", &format_locus);
1350	break;
1351	}
1352	return rv;
1353	}
1354
1355
1356	/************ Fortran I/O statement matchers *************/
1357
1358	/* Match a FORMAT statement. This amounts to actually parsing the
1359	format descriptors in order to correctly locate the end of the
1360	format string. */
1361
1362	match
1363	gfc_match_format (void)
1364	{
1365	gfc_expr *e;
1366	locus start;
1367
1368	if (gfc_current_ns->proc_name
1369	&& gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
1370	{
1371	gfc_error ("Format statement in module main block at %C");
1372	return MATCH_ERROR;
1373	}
1374
1375	/* Before parsing the rest of a FORMAT statement, check F2008:c1206. */
1376	if ((gfc_current_state () == COMP_FUNCTION
1377	|| gfc_current_state () == COMP_SUBROUTINE)
1378	&& gfc_state_stack->previous->state == COMP_INTERFACE)
1379	{
1380	gfc_error ("FORMAT statement at %C cannot appear within an INTERFACE");
1381	return MATCH_ERROR;
1382	}
1383
1384	if (gfc_statement_label == NULL)
1385	{
1386	gfc_error ("Missing format label at %C");
1387	return MATCH_ERROR;
1388	}
1389	gfc_gobble_whitespace ();
1390
1391	mode = MODE_FORMAT;
1392	format_length = 0;
1393
1394	start = gfc_current_locus;
1395
1396	if (!check_format (is_input: false))
1397	return MATCH_ERROR;
1398
1399	if (gfc_match_eos () != MATCH_YES)
1400	{
1401	gfc_syntax_error (ST_FORMAT);
1402	return MATCH_ERROR;
1403	}
1404
1405	/* The label doesn't get created until after the statement is done
1406	being matched, so we have to leave the string for later. */
1407
1408	gfc_current_locus = start; /* Back to the beginning */
1409
1410	new_st.loc = start;
1411	new_st.op = EXEC_NOP;
1412
1413	e = gfc_get_character_expr (gfc_default_character_kind, &start,
1414	NULL, len: format_length);
1415	format_string = e->value.character.string;
1416	gfc_statement_label->format = e;
1417
1418	mode = MODE_COPY;
1419	check_format (is_input: false); /* Guaranteed to succeed */
1420	gfc_match_eos (); /* Guaranteed to succeed */
1421
1422	return MATCH_YES;
1423	}
1424
1425
1426	/* Match an expression I/O tag of some sort. */
1427
1428	static match
1429	match_etag (const io_tag *tag, gfc_expr **v)
1430	{
1431	gfc_expr *result;
1432	match m;
1433
1434	m = gfc_match (tag->spec);
1435	if (m != MATCH_YES)
1436	return m;
1437
1438	m = gfc_match (tag->value, &result);
1439	if (m != MATCH_YES)
1440	{
1441	gfc_error ("Invalid value for %s specification at %C", tag->name);
1442	return MATCH_ERROR;
1443	}
1444
1445	if (*v != NULL)
1446	{
1447	gfc_error ("Duplicate %s specification at %C", tag->name);
1448	gfc_free_expr (result);
1449	return MATCH_ERROR;
1450	}
1451
1452	*v = result;
1453	return MATCH_YES;
1454	}
1455
1456
1457	/* Match a variable I/O tag of some sort. */
1458
1459	static match
1460	match_vtag (const io_tag *tag, gfc_expr **v)
1461	{
1462	gfc_expr *result;
1463	match m;
1464
1465	m = gfc_match (tag->spec);
1466	if (m != MATCH_YES)
1467	return m;
1468
1469	m = gfc_match (tag->value, &result);
1470	if (m != MATCH_YES)
1471	{
1472	gfc_error ("Invalid value for %s specification at %C", tag->name);
1473	return MATCH_ERROR;
1474	}
1475
1476	if (*v != NULL)
1477	{
1478	gfc_error ("Duplicate %s specification at %C", tag->name);
1479	gfc_free_expr (result);
1480	return MATCH_ERROR;
1481	}
1482
1483	if (result->symtree)
1484	{
1485	bool impure;
1486
1487	if (result->symtree->n.sym->attr.intent == INTENT_IN)
1488	{
1489	gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag->name);
1490	gfc_free_expr (result);
1491	return MATCH_ERROR;
1492	}
1493
1494	impure = gfc_impure_variable (result->symtree->n.sym);
1495	if (impure && gfc_pure (NULL))
1496	{
1497	gfc_error ("Variable %s cannot be assigned in PURE procedure at %C",
1498	tag->name);
1499	gfc_free_expr (result);
1500	return MATCH_ERROR;
1501	}
1502
1503	if (impure)
1504	gfc_unset_implicit_pure (NULL);
1505	}
1506
1507	*v = result;
1508	return MATCH_YES;
1509	}
1510
1511
1512	/* Match I/O tags that cause variables to become redefined. */
1513
1514	static match
1515	match_out_tag (const io_tag *tag, gfc_expr **result)
1516	{
1517	match m;
1518
1519	m = match_vtag (tag, v: result);
1520	if (m == MATCH_YES)
1521	{
1522	if ((*result)->symtree)
1523	gfc_check_do_variable ((*result)->symtree);
1524
1525	if ((*result)->expr_type == EXPR_CONSTANT)
1526	{
1527	gfc_error ("Expecting a variable at %L", &(*result)->where);
1528	return MATCH_ERROR;
1529	}
1530	}
1531
1532	return m;
1533	}
1534
1535
1536	/* Match a label I/O tag. */
1537
1538	static match
1539	match_ltag (const io_tag *tag, gfc_st_label ** label)
1540	{
1541	match m;
1542	gfc_st_label *old;
1543
1544	old = *label;
1545	m = gfc_match (tag->spec);
1546	if (m != MATCH_YES)
1547	return m;
1548
1549	m = gfc_match (tag->value, label);
1550	if (m != MATCH_YES)
1551	{
1552	gfc_error ("Invalid value for %s specification at %C", tag->name);
1553	return MATCH_ERROR;
1554	}
1555
1556	if (old)
1557	{
1558	gfc_error ("Duplicate %s label specification at %C", tag->name);
1559	return MATCH_ERROR;
1560	}
1561
1562	if (!gfc_reference_st_label (*label, ST_LABEL_TARGET))
1563	return MATCH_ERROR;
1564
1565	return m;
1566	}
1567
1568
1569	/* Match a tag using match_etag, but only if -fdec is enabled. */
1570	static match
1571	match_dec_etag (const io_tag *tag, gfc_expr **e)
1572	{
1573	match m = match_etag (tag, v: e);
1574	if (flag_dec && m != MATCH_NO)
1575	return m;
1576	else if (m != MATCH_NO)
1577	{
1578	gfc_error ("%s at %C is a DEC extension, enable with "
1579	"%<-fdec%>", tag->name);
1580	return MATCH_ERROR;
1581	}
1582	return m;
1583	}
1584
1585
1586	/* Match a tag using match_vtag, but only if -fdec is enabled. */
1587	static match
1588	match_dec_vtag (const io_tag *tag, gfc_expr **e)
1589	{
1590	match m = match_vtag(tag, v: e);
1591	if (flag_dec && m != MATCH_NO)
1592	return m;
1593	else if (m != MATCH_NO)
1594	{
1595	gfc_error ("%s at %C is a DEC extension, enable with "
1596	"%<-fdec%>", tag->name);
1597	return MATCH_ERROR;
1598	}
1599	return m;
1600	}
1601
1602
1603	/* Match a DEC I/O flag tag - a tag with no expression such as READONLY. */
1604
1605	static match
1606	match_dec_ftag (const io_tag *tag, gfc_open *o)
1607	{
1608	match m;
1609
1610	m = gfc_match (tag->spec);
1611	if (m != MATCH_YES)
1612	return m;
1613
1614	if (!flag_dec)
1615	{
1616	gfc_error ("%s at %C is a DEC extension, enable with "
1617	"%<-fdec%>", tag->name);
1618	return MATCH_ERROR;
1619	}
1620
1621	/* Just set the READONLY flag, which we use at runtime to avoid delete on
1622	close. */
1623	if (tag == &tag_readonly)
1624	{
1625	o->readonly |= 1;
1626	return MATCH_YES;
1627	}
1628
1629	/* Interpret SHARED as SHARE='DENYNONE' (read lock). */
1630	else if (tag == &tag_shared)
1631	{
1632	if (o->share != NULL)
1633	{
1634	gfc_error ("Duplicate %s specification at %C", tag->name);
1635	return MATCH_ERROR;
1636	}
1637	o->share = gfc_get_character_expr (gfc_default_character_kind,
1638	&gfc_current_locus, "denynone", len: 8);
1639	return MATCH_YES;
1640	}
1641
1642	/* Interpret NOSHARED as SHARE='DENYRW' (exclusive lock). */
1643	else if (tag == &tag_noshared)
1644	{
1645	if (o->share != NULL)
1646	{
1647	gfc_error ("Duplicate %s specification at %C", tag->name);
1648	return MATCH_ERROR;
1649	}
1650	o->share = gfc_get_character_expr (gfc_default_character_kind,
1651	&gfc_current_locus, "denyrw", len: 6);
1652	return MATCH_YES;
1653	}
1654
1655	/* We handle all DEC tags above. */
1656	gcc_unreachable ();
1657	}
1658
1659
1660	/* Resolution of the FORMAT tag, to be called from resolve_tag. */
1661
1662	static bool
1663	resolve_tag_format (gfc_expr *e)
1664	{
1665	if (e->expr_type == EXPR_CONSTANT
1666	&& (e->ts.type != BT_CHARACTER
1667	|| e->ts.kind != gfc_default_character_kind))
1668	{
1669	gfc_error ("Constant expression in FORMAT tag at %L must be "
1670	"of type default CHARACTER", &e->where);
1671	return false;
1672	}
1673
1674	/* Concatenate a constant character array into a single character
1675	expression. */
1676
1677	if ((e->expr_type == EXPR_ARRAY || e->rank > 0)
1678	&& e->ts.type == BT_CHARACTER
1679	&& gfc_is_constant_expr (e))
1680	{
1681	if (e->expr_type == EXPR_VARIABLE
1682	&& e->symtree->n.sym->attr.flavor == FL_PARAMETER)
1683	gfc_simplify_expr (e, 1);
1684
1685	if (e->expr_type == EXPR_ARRAY)
1686	{
1687	gfc_constructor *c;
1688	gfc_charlen_t n, len;
1689	gfc_expr *r;
1690	gfc_char_t *dest, *src;
1691
1692	if (e->value.constructor == NULL)
1693	{
1694	gfc_error ("FORMAT tag at %L cannot be a zero-sized array",
1695	&e->where);
1696	return false;
1697	}
1698
1699	n = 0;
1700	c = gfc_constructor_first (base: e->value.constructor);
1701	len = c->expr->value.character.length;
1702
1703	for ( ; c; c = gfc_constructor_next (ctor: c))
1704	n += len;
1705
1706	r = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len: n);
1707	dest = r->value.character.string;
1708
1709	for (c = gfc_constructor_first (base: e->value.constructor);
1710	c; c = gfc_constructor_next (ctor: c))
1711	{
1712	src = c->expr->value.character.string;
1713	for (gfc_charlen_t i = 0 ; i < len; i++)
1714	*dest++ = *src++;
1715	}
1716
1717	gfc_replace_expr (e, r);
1718	return true;
1719	}
1720	}
1721
1722	/* If e's rank is zero and e is not an element of an array, it should be
1723	of integer or character type. The integer variable should be
1724	ASSIGNED. */
1725	if (e->rank == 0
1726	&& (e->expr_type != EXPR_VARIABLE
1727	|| e->symtree == NULL
1728	|| e->symtree->n.sym->as == NULL
1729	|| e->symtree->n.sym->as->rank == 0))
1730	{
1731	if ((e->ts.type != BT_CHARACTER
1732	|| e->ts.kind != gfc_default_character_kind)
1733	&& e->ts.type != BT_INTEGER)
1734	{
1735	gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER "
1736	"or of INTEGER", &e->where);
1737	return false;
1738	}
1739	else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
1740	{
1741	if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGNED variable in "
1742	"FORMAT tag at %L", &e->where))
1743	return false;
1744	if (e->symtree->n.sym->attr.assign != 1)
1745	{
1746	gfc_error ("Variable %qs at %L has not been assigned a "
1747	"format label", e->symtree->n.sym->name, &e->where);
1748	return false;
1749	}
1750	}
1751	else if (e->ts.type == BT_INTEGER)
1752	{
1753	gfc_error ("Scalar %qs in FORMAT tag at %L is not an ASSIGNED "
1754	"variable", gfc_basic_typename (e->ts.type), &e->where);
1755	return false;
1756	}
1757
1758	return true;
1759	}
1760
1761	/* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
1762	It may be assigned an Hollerith constant. */
1763	if (e->ts.type != BT_CHARACTER)
1764	{
1765	if (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS
1766	|| e->ts.type == BT_VOID || e->ts.type == BT_UNKNOWN)
1767	{
1768	gfc_error ("Non-character non-Hollerith in FORMAT tag at %L",
1769	&e->where);
1770	return false;
1771	}
1772	if (!gfc_notify_std (GFC_STD_LEGACY, "Non-character in FORMAT tag "
1773	"at %L", &e->where))
1774	return false;
1775
1776	if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)
1777	{
1778	gfc_error ("Non-character assumed shape array element in FORMAT"
1779	" tag at %L", &e->where);
1780	return false;
1781	}
1782
1783	if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
1784	{
1785	gfc_error ("Non-character assumed size array element in FORMAT"
1786	" tag at %L", &e->where);
1787	return false;
1788	}
1789
1790	if (e->rank == 0 && e->symtree->n.sym->attr.pointer)
1791	{
1792	gfc_error ("Non-character pointer array element in FORMAT tag at %L",
1793	&e->where);
1794	return false;
1795	}
1796	}
1797
1798	return true;
1799	}
1800
1801
1802	/* Do expression resolution and type-checking on an expression tag. */
1803
1804	static bool
1805	resolve_tag (const io_tag *tag, gfc_expr *e)
1806	{
1807	if (e == NULL)
1808	return true;
1809
1810	if (!gfc_resolve_expr (e))
1811	return false;
1812
1813	if (tag == &tag_format)
1814	return resolve_tag_format (e);
1815
1816	if (e->ts.type != tag->type)
1817	{
1818	gfc_error ("%s tag at %L must be of type %s", tag->name,
1819	&e->where, gfc_basic_typename (tag->type));
1820	return false;
1821	}
1822
1823	if (e->ts.type == BT_CHARACTER && e->ts.kind != gfc_default_character_kind)
1824	{
1825	gfc_error ("%s tag at %L must be a character string of default kind",
1826	tag->name, &e->where);
1827	return false;
1828	}
1829
1830	if (e->rank != 0)
1831	{
1832	gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
1833	return false;
1834	}
1835
1836	if (tag == &tag_iomsg)
1837	{
1838	if (!gfc_notify_std (GFC_STD_F2003, "IOMSG tag at %L", &e->where))
1839	return false;
1840	}
1841
1842	if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength
1843	|| tag == &tag_number || tag == &tag_nextrec || tag == &tag_s_recl)
1844	&& e->ts.kind != gfc_default_integer_kind)
1845	{
1846	if (!gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
1847	"INTEGER in %s tag at %L", tag->name, &e->where))
1848	return false;
1849	}
1850
1851	if (e->ts.kind != gfc_default_logical_kind &&
1852	(tag == &tag_exist || tag == &tag_named || tag == &tag_opened
1853	|| tag == &tag_pending))
1854	{
1855	if (!gfc_notify_std (GFC_STD_F2008, "Non-default LOGICAL kind "
1856	"in %s tag at %L", tag->name, &e->where))
1857	return false;
1858	}
1859
1860	if (tag == &tag_newunit)
1861	{
1862	if (!gfc_notify_std (GFC_STD_F2008, "NEWUNIT specifier at %L",
1863	&e->where))
1864	return false;
1865	}
1866
1867	/* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */
1868	if (tag == &tag_newunit || tag == &tag_iostat
1869	|| tag == &tag_size || tag == &tag_iomsg)
1870	{
1871	char context[64];
1872
1873	sprintf (s: context, _("%s tag"), tag->name);
1874	if (!gfc_check_vardef_context (e, false, false, false, context))
1875	return false;
1876	}
1877
1878	if (tag == &tag_convert)
1879	{
1880	if (!gfc_notify_std (GFC_STD_GNU, "CONVERT tag at %L", &e->where))
1881	return false;
1882	}
1883
1884	return true;
1885	}
1886
1887
1888	/* Match a single tag of an OPEN statement. */
1889
1890	static match
1891	match_open_element (gfc_open *open)
1892	{
1893	match m;
1894
1895	m = match_etag (tag: &tag_e_async, v: &open->asynchronous);
1896	if (m != MATCH_NO)
1897	return m;
1898	m = match_etag (tag: &tag_unit, v: &open->unit);
1899	if (m != MATCH_NO)
1900	return m;
1901	m = match_etag (tag: &tag_iomsg, v: &open->iomsg);
1902	if (m != MATCH_NO)
1903	return m;
1904	m = match_out_tag (tag: &tag_iostat, result: &open->iostat);
1905	if (m != MATCH_NO)
1906	return m;
1907	m = match_etag (tag: &tag_file, v: &open->file);
1908	if (m != MATCH_NO)
1909	return m;
1910	m = match_etag (tag: &tag_status, v: &open->status);
1911	if (m != MATCH_NO)
1912	return m;
1913	m = match_etag (tag: &tag_e_access, v: &open->access);
1914	if (m != MATCH_NO)
1915	return m;
1916	m = match_etag (tag: &tag_e_form, v: &open->form);
1917	if (m != MATCH_NO)
1918	return m;
1919	m = match_etag (tag: &tag_e_recl, v: &open->recl);
1920	if (m != MATCH_NO)
1921	return m;
1922	m = match_etag (tag: &tag_e_blank, v: &open->blank);
1923	if (m != MATCH_NO)
1924	return m;
1925	m = match_etag (tag: &tag_e_position, v: &open->position);
1926	if (m != MATCH_NO)
1927	return m;
1928	m = match_etag (tag: &tag_e_action, v: &open->action);
1929	if (m != MATCH_NO)
1930	return m;
1931	m = match_etag (tag: &tag_e_delim, v: &open->delim);
1932	if (m != MATCH_NO)
1933	return m;
1934	m = match_etag (tag: &tag_e_pad, v: &open->pad);
1935	if (m != MATCH_NO)
1936	return m;
1937	m = match_etag (tag: &tag_e_decimal, v: &open->decimal);
1938	if (m != MATCH_NO)
1939	return m;
1940	m = match_etag (tag: &tag_e_encoding, v: &open->encoding);
1941	if (m != MATCH_NO)
1942	return m;
1943	m = match_etag (tag: &tag_e_round, v: &open->round);
1944	if (m != MATCH_NO)
1945	return m;
1946	m = match_etag (tag: &tag_e_sign, v: &open->sign);
1947	if (m != MATCH_NO)
1948	return m;
1949	m = match_ltag (tag: &tag_err, label: &open->err);
1950	if (m != MATCH_NO)
1951	return m;
1952	m = match_etag (tag: &tag_convert, v: &open->convert);
1953	if (m != MATCH_NO)
1954	return m;
1955	m = match_out_tag (tag: &tag_newunit, result: &open->newunit);
1956	if (m != MATCH_NO)
1957	return m;
1958
1959	/* The following are extensions enabled with -fdec. */
1960	m = match_dec_etag (tag: &tag_e_share, e: &open->share);
1961	if (m != MATCH_NO)
1962	return m;
1963	m = match_dec_etag (tag: &tag_cc, e: &open->cc);
1964	if (m != MATCH_NO)
1965	return m;
1966	m = match_dec_ftag (tag: &tag_readonly, o: open);
1967	if (m != MATCH_NO)
1968	return m;
1969	m = match_dec_ftag (tag: &tag_shared, o: open);
1970	if (m != MATCH_NO)
1971	return m;
1972	m = match_dec_ftag (tag: &tag_noshared, o: open);
1973	if (m != MATCH_NO)
1974	return m;
1975
1976	return MATCH_NO;
1977	}
1978
1979
1980	/* Free the gfc_open structure and all the expressions it contains. */
1981
1982	void
1983	gfc_free_open (gfc_open *open)
1984	{
1985	if (open == NULL)
1986	return;
1987
1988	gfc_free_expr (open->unit);
1989	gfc_free_expr (open->iomsg);
1990	gfc_free_expr (open->iostat);
1991	gfc_free_expr (open->file);
1992	gfc_free_expr (open->status);
1993	gfc_free_expr (open->access);
1994	gfc_free_expr (open->form);
1995	gfc_free_expr (open->recl);
1996	gfc_free_expr (open->blank);
1997	gfc_free_expr (open->position);
1998	gfc_free_expr (open->action);
1999	gfc_free_expr (open->delim);
2000	gfc_free_expr (open->pad);
2001	gfc_free_expr (open->decimal);
2002	gfc_free_expr (open->encoding);
2003	gfc_free_expr (open->round);
2004	gfc_free_expr (open->sign);
2005	gfc_free_expr (open->convert);
2006	gfc_free_expr (open->asynchronous);
2007	gfc_free_expr (open->newunit);
2008	gfc_free_expr (open->share);
2009	gfc_free_expr (open->cc);
2010	free (ptr: open);
2011	}
2012
2013	static bool
2014	check_open_constraints (gfc_open *open, locus *where);
2015
2016	/* Resolve everything in a gfc_open structure. */
2017
2018	bool
2019	gfc_resolve_open (gfc_open *open, locus *where)
2020	{
2021	RESOLVE_TAG (&tag_unit, open->unit);
2022	RESOLVE_TAG (&tag_iomsg, open->iomsg);
2023	RESOLVE_TAG (&tag_iostat, open->iostat);
2024	RESOLVE_TAG (&tag_file, open->file);
2025	RESOLVE_TAG (&tag_status, open->status);
2026	RESOLVE_TAG (&tag_e_access, open->access);
2027	RESOLVE_TAG (&tag_e_form, open->form);
2028	RESOLVE_TAG (&tag_e_recl, open->recl);
2029	RESOLVE_TAG (&tag_e_blank, open->blank);
2030	RESOLVE_TAG (&tag_e_position, open->position);
2031	RESOLVE_TAG (&tag_e_action, open->action);
2032	RESOLVE_TAG (&tag_e_delim, open->delim);
2033	RESOLVE_TAG (&tag_e_pad, open->pad);
2034	RESOLVE_TAG (&tag_e_decimal, open->decimal);
2035	RESOLVE_TAG (&tag_e_encoding, open->encoding);
2036	RESOLVE_TAG (&tag_e_async, open->asynchronous);
2037	RESOLVE_TAG (&tag_e_round, open->round);
2038	RESOLVE_TAG (&tag_e_sign, open->sign);
2039	RESOLVE_TAG (&tag_convert, open->convert);
2040	RESOLVE_TAG (&tag_newunit, open->newunit);
2041	RESOLVE_TAG (&tag_e_share, open->share);
2042	RESOLVE_TAG (&tag_cc, open->cc);
2043
2044	if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET))
2045	return false;
2046
2047	return check_open_constraints (open, where);
2048	}
2049
2050
2051	/* Check if a given value for a SPECIFIER is either in the list of values
2052	allowed in F95 or F2003, issuing an error message and returning a zero
2053	value if it is not allowed. */
2054
2055
2056	static bool
2057	compare_to_allowed_values (const char *specifier, const char *allowed[],
2058	const char *allowed_f2003[],
2059	const char *allowed_gnu[], gfc_char_t *value,
2060	const char *statement, bool warn, locus *where,
2061	int *num = NULL)
2062	{
2063	int i;
2064	unsigned int len;
2065
2066	len = gfc_wide_strlen (value);
2067	if (len > 0)
2068	{
2069	for (len--; len > 0; len--)
2070	if (value[len] != ' ')
2071	break;
2072	len++;
2073	}
2074
2075	for (i = 0; allowed[i]; i++)
2076	if (len == strlen (s: allowed[i])
2077	&& gfc_wide_strncasecmp (value, allowed[i], strlen (s: allowed[i])) == 0)
2078	{
2079	if (num)
2080	*num = i;
2081	return 1;
2082	}
2083
2084	if (!where)
2085	where = &gfc_current_locus;
2086
2087	for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
2088	if (len == strlen (s: allowed_f2003[i])
2089	&& gfc_wide_strncasecmp (value, allowed_f2003[i],
2090	strlen (s: allowed_f2003[i])) == 0)
2091	{
2092	notification n = gfc_notification_std (GFC_STD_F2003);
2093
2094	if (n == WARNING || (warn && n == ERROR))
2095	{
2096	gfc_warning (opt: 0, "Fortran 2003: %s specifier in %s statement at %L "
2097	"has value %qs", specifier, statement, where,
2098	allowed_f2003[i]);
2099	return 1;
2100	}
2101	else
2102	if (n == ERROR)
2103	{
2104	gfc_notify_std (GFC_STD_F2003, "%s specifier in "
2105	"%s statement at %L has value %qs", specifier,
2106	statement, where, allowed_f2003[i]);
2107	return 0;
2108	}
2109
2110	/* n == SILENT */
2111	return 1;
2112	}
2113
2114	for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
2115	if (len == strlen (s: allowed_gnu[i])
2116	&& gfc_wide_strncasecmp (value, allowed_gnu[i],
2117	strlen (s: allowed_gnu[i])) == 0)
2118	{
2119	notification n = gfc_notification_std (GFC_STD_GNU);
2120
2121	if (n == WARNING || (warn && n == ERROR))
2122	{
2123	gfc_warning (opt: 0, "Extension: %s specifier in %s statement at %L "
2124	"has value %qs", specifier, statement, where,
2125	allowed_gnu[i]);
2126	return 1;
2127	}
2128	else
2129	if (n == ERROR)
2130	{
2131	gfc_notify_std (GFC_STD_GNU, "%s specifier in "
2132	"%s statement at %L has value %qs", specifier,
2133	statement, where, allowed_gnu[i]);
2134	return 0;
2135	}
2136
2137	/* n == SILENT */
2138	return 1;
2139	}
2140
2141	if (warn)
2142	{
2143	char *s = gfc_widechar_to_char (value, -1);
2144	gfc_warning (opt: 0,
2145	"%s specifier in %s statement at %L has invalid value %qs",
2146	specifier, statement, where, s);
2147	free (ptr: s);
2148	return 1;
2149	}
2150	else
2151	{
2152	char *s = gfc_widechar_to_char (value, -1);
2153	gfc_error ("%s specifier in %s statement at %L has invalid value %qs",
2154	specifier, statement, where, s);
2155	free (ptr: s);
2156	return 0;
2157	}
2158	}
2159
2160
2161	/* Check constraints on the OPEN statement.
2162	Similar to check_io_constraints for data transfer statements.
2163	At this point all tags have already been resolved via resolve_tag, which,
2164	among other things, verifies that BT_CHARACTER tags are of default kind. */
2165
2166	static bool
2167	check_open_constraints (gfc_open *open, locus *where)
2168	{
2169	#define warn_or_error(...) \
2170	{ \
2171	if (warn) \
2172	gfc_warning (0, __VA_ARGS__); \
2173	else \
2174	{ \
2175	gfc_error (__VA_ARGS__); \
2176	return false; \
2177	} \
2178	}
2179
2180	bool warn = (open->err || open->iostat) ? true : false;
2181
2182	/* Checks on the ACCESS specifier. */
2183	if (open->access && open->access->expr_type == EXPR_CONSTANT)
2184	{
2185	static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
2186	static const char *access_f2003[] = { "STREAM", NULL };
2187	static const char *access_gnu[] = { "APPEND", NULL };
2188
2189	if (!compare_to_allowed_values (specifier: "ACCESS", allowed: access_f95, allowed_f2003: access_f2003,
2190	allowed_gnu: access_gnu,
2191	value: open->access->value.character.string,
2192	statement: "OPEN", warn, where: &open->access->where))
2193	return false;
2194	}
2195
2196	/* Checks on the ACTION specifier. */
2197	if (open->action && open->action->expr_type == EXPR_CONSTANT)
2198	{
2199	gfc_char_t *str = open->action->value.character.string;
2200	static const char *action[] = { "READ", "WRITE", "READWRITE", NULL };
2201
2202	if (!compare_to_allowed_values (specifier: "ACTION", allowed: action, NULL, NULL,
2203	value: str, statement: "OPEN", warn, where: &open->action->where))
2204	return false;
2205
2206	/* With READONLY, only allow ACTION='READ'. */
2207	if (open->readonly && (gfc_wide_strlen (str) != 4
2208	|| gfc_wide_strncasecmp (str, "READ", 4) != 0))
2209	{
2210	gfc_error ("ACTION type conflicts with READONLY specifier at %L",
2211	&open->action->where);
2212	return false;
2213	}
2214	}
2215
2216	/* If we see READONLY and no ACTION, set ACTION='READ'. */
2217	else if (open->readonly && open->action == NULL)
2218	{
2219	open->action = gfc_get_character_expr (gfc_default_character_kind,
2220	&gfc_current_locus, "read", len: 4);
2221	}
2222
2223	/* Checks on the ASYNCHRONOUS specifier. */
2224	if (open->asynchronous)
2225	{
2226	if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %L "
2227	"not allowed in Fortran 95",
2228	&open->asynchronous->where))
2229	return false;
2230
2231	if (open->asynchronous->expr_type == EXPR_CONSTANT)
2232	{
2233	static const char * asynchronous[] = { "YES", "NO", NULL };
2234
2235	if (!compare_to_allowed_values (specifier: "ASYNCHRONOUS", allowed: asynchronous,
2236	NULL, NULL, value: open->asynchronous->value.character.string,
2237	statement: "OPEN", warn, where: &open->asynchronous->where))
2238	return false;
2239	}
2240	}
2241
2242	/* Checks on the BLANK specifier. */
2243	if (open->blank)
2244	{
2245	if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L "
2246	"not allowed in Fortran 95", &open->blank->where))
2247	return false;
2248
2249	if (open->blank->expr_type == EXPR_CONSTANT)
2250	{
2251	static const char *blank[] = { "ZERO", "NULL", NULL };
2252
2253	if (!compare_to_allowed_values (specifier: "BLANK", allowed: blank, NULL, NULL,
2254	value: open->blank->value.character.string,
2255	statement: "OPEN", warn, where: &open->blank->where))
2256	return false;
2257	}
2258	}
2259
2260	/* Checks on the CARRIAGECONTROL specifier. */
2261	if (open->cc && open->cc->expr_type == EXPR_CONSTANT)
2262	{
2263	static const char *cc[] = { "LIST", "FORTRAN", "NONE", NULL };
2264	if (!compare_to_allowed_values (specifier: "CARRIAGECONTROL", allowed: cc, NULL, NULL,
2265	value: open->cc->value.character.string,
2266	statement: "OPEN", warn, where: &open->cc->where))
2267	return false;
2268	}
2269
2270	/* Checks on the DECIMAL specifier. */
2271	if (open->decimal)
2272	{
2273	if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L "
2274	"not allowed in Fortran 95", &open->decimal->where))
2275	return false;
2276
2277	if (open->decimal->expr_type == EXPR_CONSTANT)
2278	{
2279	static const char * decimal[] = { "COMMA", "POINT", NULL };
2280
2281	if (!compare_to_allowed_values (specifier: "DECIMAL", allowed: decimal, NULL, NULL,
2282	value: open->decimal->value.character.string,
2283	statement: "OPEN", warn, where: &open->decimal->where))
2284	return false;
2285	}
2286	}
2287
2288	/* Checks on the DELIM specifier. */
2289	if (open->delim)
2290	{
2291	if (open->delim->expr_type == EXPR_CONSTANT)
2292	{
2293	static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
2294
2295	if (!compare_to_allowed_values (specifier: "DELIM", allowed: delim, NULL, NULL,
2296	value: open->delim->value.character.string,
2297	statement: "OPEN", warn, where: &open->delim->where))
2298	return false;
2299	}
2300	}
2301
2302	/* Checks on the ENCODING specifier. */
2303	if (open->encoding)
2304	{
2305	if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %L "
2306	"not allowed in Fortran 95", &open->encoding->where))
2307	return false;
2308
2309	if (open->encoding->expr_type == EXPR_CONSTANT)
2310	{
2311	static const char * encoding[] = { "DEFAULT", "UTF-8", NULL };
2312
2313	if (!compare_to_allowed_values (specifier: "ENCODING", allowed: encoding, NULL, NULL,
2314	value: open->encoding->value.character.string,
2315	statement: "OPEN", warn, where: &open->encoding->where))
2316	return false;
2317	}
2318	}
2319
2320	/* Checks on the FORM specifier. */
2321	if (open->form && open->form->expr_type == EXPR_CONSTANT)
2322	{
2323	static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
2324
2325	if (!compare_to_allowed_values (specifier: "FORM", allowed: form, NULL, NULL,
2326	value: open->form->value.character.string,
2327	statement: "OPEN", warn, where: &open->form->where))
2328	return false;
2329	}
2330
2331	/* Checks on the PAD specifier. */
2332	if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
2333	{
2334	static const char *pad[] = { "YES", "NO", NULL };
2335
2336	if (!compare_to_allowed_values (specifier: "PAD", allowed: pad, NULL, NULL,
2337	value: open->pad->value.character.string,
2338	statement: "OPEN", warn, where: &open->pad->where))
2339	return false;
2340	}
2341
2342	/* Checks on the POSITION specifier. */
2343	if (open->position && open->position->expr_type == EXPR_CONSTANT)
2344	{
2345	static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
2346
2347	if (!compare_to_allowed_values (specifier: "POSITION", allowed: position, NULL, NULL,
2348	value: open->position->value.character.string,
2349	statement: "OPEN", warn, where: &open->position->where))
2350	return false;
2351	}
2352
2353	/* Checks on the ROUND specifier. */
2354	if (open->round)
2355	{
2356	if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L "
2357	"not allowed in Fortran 95", &open->round->where))
2358	return false;
2359
2360	if (open->round->expr_type == EXPR_CONSTANT)
2361	{
2362	static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
2363	"COMPATIBLE", "PROCESSOR_DEFINED",
2364	NULL };
2365
2366	if (!compare_to_allowed_values (specifier: "ROUND", allowed: round, NULL, NULL,
2367	value: open->round->value.character.string,
2368	statement: "OPEN", warn, where: &open->round->where))
2369	return false;
2370	}
2371	}
2372
2373	/* Checks on the SHARE specifier. */
2374	if (open->share && open->share->expr_type == EXPR_CONSTANT)
2375	{
2376	static const char *share[] = { "DENYNONE", "DENYRW", NULL };
2377	if (!compare_to_allowed_values (specifier: "SHARE", allowed: share, NULL, NULL,
2378	value: open->share->value.character.string,
2379	statement: "OPEN", warn, where: &open->share->where))
2380	return false;
2381	}
2382
2383	/* Checks on the SIGN specifier. */
2384	if (open->sign)
2385	{
2386	if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %L "
2387	"not allowed in Fortran 95", &open->sign->where))
2388	return false;
2389
2390	if (open->sign->expr_type == EXPR_CONSTANT)
2391	{
2392	static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
2393	NULL };
2394
2395	if (!compare_to_allowed_values (specifier: "SIGN", allowed: sign, NULL, NULL,
2396	value: open->sign->value.character.string,
2397	statement: "OPEN", warn, where: &open->sign->where))
2398	return false;
2399	}
2400	}
2401
2402	/* Checks on the RECL specifier. */
2403	if (open->recl && open->recl->expr_type == EXPR_CONSTANT
2404	&& open->recl->ts.type == BT_INTEGER
2405	&& mpz_sgn (open->recl->value.integer) != 1)
2406	{
2407	warn_or_error (G_("RECL in OPEN statement at %L must be positive"),
2408	&open->recl->where);
2409	}
2410
2411	/* Checks on the STATUS specifier. */
2412	if (open->status && open->status->expr_type == EXPR_CONSTANT)
2413	{
2414	static const char *status[] = { "OLD", "NEW", "SCRATCH",
2415	"REPLACE", "UNKNOWN", NULL };
2416
2417	if (!compare_to_allowed_values (specifier: "STATUS", allowed: status, NULL, NULL,
2418	value: open->status->value.character.string,
2419	statement: "OPEN", warn, where: &open->status->where))
2420	return false;
2421
2422	/* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2423	the FILE= specifier shall appear. */
2424	if (open->file == NULL
2425	&& (gfc_wide_strncasecmp (open->status->value.character.string,
2426	"replace", 7) == 0
2427	|| gfc_wide_strncasecmp (open->status->value.character.string,
2428	"new", 3) == 0))
2429	{
2430	char *s = gfc_widechar_to_char (open->status->value.character.string,
2431	-1);
2432	warn_or_error (G_("The STATUS specified in OPEN statement at %L is "
2433	"%qs and no FILE specifier is present"),
2434	&open->status->where, s);
2435	free (ptr: s);
2436	}
2437
2438	/* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2439	the FILE= specifier shall not appear. */
2440	if (gfc_wide_strncasecmp (open->status->value.character.string,
2441	"scratch", 7) == 0 && open->file)
2442	{
2443	warn_or_error (G_("The STATUS specified in OPEN statement at %L "
2444	"cannot have the value SCRATCH if a FILE specifier "
2445	"is present"), &open->status->where);
2446	}
2447	}
2448
2449	/* Checks on NEWUNIT specifier. */
2450	if (open->newunit)
2451	{
2452	if (open->unit)
2453	{
2454	gfc_error ("UNIT specifier not allowed with NEWUNIT at %L",
2455	&open->newunit->where);
2456	return false;
2457	}
2458
2459	if (!open->file &&
2460	(!open->status ||
2461	(open->status->expr_type == EXPR_CONSTANT
2462	&& gfc_wide_strncasecmp (open->status->value.character.string,
2463	"scratch", 7) != 0)))
2464	{
2465	gfc_error ("NEWUNIT specifier must have FILE= "
2466	"or STATUS='scratch' at %L", &open->newunit->where);
2467	return false;
2468	}
2469	}
2470	else if (!open->unit)
2471	{
2472	gfc_error ("OPEN statement at %L must have UNIT or NEWUNIT specified",
2473	where);
2474	return false;
2475	}
2476
2477	/* Things that are not allowed for unformatted I/O. */
2478	if (open->form && open->form->expr_type == EXPR_CONSTANT
2479	&& (open->delim || open->decimal || open->encoding || open->round
2480	|| open->sign || open->pad || open->blank)
2481	&& gfc_wide_strncasecmp (open->form->value.character.string,
2482	"unformatted", 11) == 0)
2483	{
2484	locus *loc;
2485	const char *spec;
2486	if (open->delim)
2487	{
2488	loc = &open->delim->where;
2489	spec = "DELIM ";
2490	}
2491	else if (open->pad)
2492	{
2493	loc = &open->pad->where;
2494	spec = "PAD ";
2495	}
2496	else if (open->blank)
2497	{
2498	loc = &open->blank->where;
2499	spec = "BLANK ";
2500	}
2501	else
2502	{
2503	loc = where;
2504	spec = "";
2505	}
2506
2507	warn_or_error (G_("%sspecifier at %L not allowed in OPEN statement for "
2508	"unformatted I/O"), spec, loc);
2509	}
2510
2511	if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
2512	&& gfc_wide_strncasecmp (open->access->value.character.string,
2513	"stream", 6) == 0)
2514	{
2515	warn_or_error (G_("RECL specifier not allowed in OPEN statement at %L for "
2516	"stream I/O"), &open->recl->where);
2517	}
2518
2519	if (open->position
2520	&& open->access && open->access->expr_type == EXPR_CONSTANT
2521	&& !(gfc_wide_strncasecmp (open->access->value.character.string,
2522	"sequential", 10) == 0
2523	|| gfc_wide_strncasecmp (open->access->value.character.string,
2524	"stream", 6) == 0
2525	|| gfc_wide_strncasecmp (open->access->value.character.string,
2526	"append", 6) == 0))
2527	{
2528	warn_or_error (G_("POSITION specifier in OPEN statement at %L only allowed "
2529	"for stream or sequential ACCESS"), &open->position->where);
2530	}
2531
2532	return true;
2533	#undef warn_or_error
2534	}
2535
2536
2537	/* Match an OPEN statement. */
2538
2539	match
2540	gfc_match_open (void)
2541	{
2542	gfc_open *open;
2543	match m;
2544
2545	m = gfc_match_char ('(');
2546	if (m == MATCH_NO)
2547	return m;
2548
2549	open = XCNEW (gfc_open);
2550
2551	m = match_open_element (open);
2552
2553	if (m == MATCH_ERROR)
2554	goto cleanup;
2555	if (m == MATCH_NO)
2556	{
2557	m = gfc_match_expr (&open->unit);
2558	if (m == MATCH_ERROR)
2559	goto cleanup;
2560	}
2561
2562	for (;;)
2563	{
2564	if (gfc_match_char (')') == MATCH_YES)
2565	break;
2566	if (gfc_match_char (',') != MATCH_YES)
2567	goto syntax;
2568
2569	m = match_open_element (open);
2570	if (m == MATCH_ERROR)
2571	goto cleanup;
2572	if (m == MATCH_NO)
2573	goto syntax;
2574	}
2575
2576	if (gfc_match_eos () == MATCH_NO)
2577	goto syntax;
2578
2579	if (gfc_pure (NULL))
2580	{
2581	gfc_error ("OPEN statement not allowed in PURE procedure at %C");
2582	goto cleanup;
2583	}
2584
2585	gfc_unset_implicit_pure (NULL);
2586
2587	new_st.op = EXEC_OPEN;
2588	new_st.ext.open = open;
2589	return MATCH_YES;
2590
2591	syntax:
2592	gfc_syntax_error (ST_OPEN);
2593
2594	cleanup:
2595	gfc_free_open (open);
2596	return MATCH_ERROR;
2597	}
2598
2599
2600	/* Free a gfc_close structure an all its expressions. */
2601
2602	void
2603	gfc_free_close (gfc_close *close)
2604	{
2605	if (close == NULL)
2606	return;
2607
2608	gfc_free_expr (close->unit);
2609	gfc_free_expr (close->iomsg);
2610	gfc_free_expr (close->iostat);
2611	gfc_free_expr (close->status);
2612	free (ptr: close);
2613	}
2614
2615
2616	/* Match elements of a CLOSE statement. */
2617
2618	static match
2619	match_close_element (gfc_close *close)
2620	{
2621	match m;
2622
2623	m = match_etag (tag: &tag_unit, v: &close->unit);
2624	if (m != MATCH_NO)
2625	return m;
2626	m = match_etag (tag: &tag_status, v: &close->status);
2627	if (m != MATCH_NO)
2628	return m;
2629	m = match_etag (tag: &tag_iomsg, v: &close->iomsg);
2630	if (m != MATCH_NO)
2631	return m;
2632	m = match_out_tag (tag: &tag_iostat, result: &close->iostat);
2633	if (m != MATCH_NO)
2634	return m;
2635	m = match_ltag (tag: &tag_err, label: &close->err);
2636	if (m != MATCH_NO)
2637	return m;
2638
2639	return MATCH_NO;
2640	}
2641
2642
2643	/* Match a CLOSE statement. */
2644
2645	match
2646	gfc_match_close (void)
2647	{
2648	gfc_close *close;
2649	match m;
2650
2651	m = gfc_match_char ('(');
2652	if (m == MATCH_NO)
2653	return m;
2654
2655	close = XCNEW (gfc_close);
2656
2657	m = match_close_element (close);
2658
2659	if (m == MATCH_ERROR)
2660	goto cleanup;
2661	if (m == MATCH_NO)
2662	{
2663	m = gfc_match_expr (&close->unit);
2664	if (m == MATCH_NO)
2665	goto syntax;
2666	if (m == MATCH_ERROR)
2667	goto cleanup;
2668	}
2669
2670	for (;;)
2671	{
2672	if (gfc_match_char (')') == MATCH_YES)
2673	break;
2674	if (gfc_match_char (',') != MATCH_YES)
2675	goto syntax;
2676
2677	m = match_close_element (close);
2678	if (m == MATCH_ERROR)
2679	goto cleanup;
2680	if (m == MATCH_NO)
2681	goto syntax;
2682	}
2683
2684	if (gfc_match_eos () == MATCH_NO)
2685	goto syntax;
2686
2687	if (gfc_pure (NULL))
2688	{
2689	gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2690	goto cleanup;
2691	}
2692
2693	gfc_unset_implicit_pure (NULL);
2694
2695	new_st.op = EXEC_CLOSE;
2696	new_st.ext.close = close;
2697	return MATCH_YES;
2698
2699	syntax:
2700	gfc_syntax_error (ST_CLOSE);
2701
2702	cleanup:
2703	gfc_free_close (close);
2704	return MATCH_ERROR;
2705	}
2706
2707
2708	static bool
2709	check_close_constraints (gfc_close *close, locus *where)
2710	{
2711	bool warn = (close->iostat || close->err) ? true : false;
2712
2713	if (close->unit == NULL)
2714	{
2715	gfc_error ("CLOSE statement at %L requires a UNIT number", where);
2716	return false;
2717	}
2718
2719	if (close->unit->expr_type == EXPR_CONSTANT
2720	&& close->unit->ts.type == BT_INTEGER
2721	&& mpz_sgn (close->unit->value.integer) < 0)
2722	{
2723	gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2724	&close->unit->where);
2725	}
2726
2727	/* Checks on the STATUS specifier. */
2728	if (close->status && close->status->expr_type == EXPR_CONSTANT)
2729	{
2730	static const char *status[] = { "KEEP", "DELETE", NULL };
2731
2732	if (!compare_to_allowed_values (specifier: "STATUS", allowed: status, NULL, NULL,
2733	value: close->status->value.character.string,
2734	statement: "CLOSE", warn, where: &close->status->where))
2735	return false;
2736	}
2737
2738	return true;
2739	}
2740
2741	/* Resolve everything in a gfc_close structure. */
2742
2743	bool
2744	gfc_resolve_close (gfc_close *close, locus *where)
2745	{
2746	RESOLVE_TAG (&tag_unit, close->unit);
2747	RESOLVE_TAG (&tag_iomsg, close->iomsg);
2748	RESOLVE_TAG (&tag_iostat, close->iostat);
2749	RESOLVE_TAG (&tag_status, close->status);
2750
2751	if (!gfc_reference_st_label (close->err, ST_LABEL_TARGET))
2752	return false;
2753
2754	return check_close_constraints (close, where);
2755	}
2756
2757
2758	/* Free a gfc_filepos structure. */
2759
2760	void
2761	gfc_free_filepos (gfc_filepos *fp)
2762	{
2763	gfc_free_expr (fp->unit);
2764	gfc_free_expr (fp->iomsg);
2765	gfc_free_expr (fp->iostat);
2766	free (ptr: fp);
2767	}
2768
2769
2770	/* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
2771
2772	static match
2773	match_file_element (gfc_filepos *fp)
2774	{
2775	match m;
2776
2777	m = match_etag (tag: &tag_unit, v: &fp->unit);
2778	if (m != MATCH_NO)
2779	return m;
2780	m = match_etag (tag: &tag_iomsg, v: &fp->iomsg);
2781	if (m != MATCH_NO)
2782	return m;
2783	m = match_out_tag (tag: &tag_iostat, result: &fp->iostat);
2784	if (m != MATCH_NO)
2785	return m;
2786	m = match_ltag (tag: &tag_err, label: &fp->err);
2787	if (m != MATCH_NO)
2788	return m;
2789
2790	return MATCH_NO;
2791	}
2792
2793
2794	/* Match the second half of the file-positioning statements, REWIND,
2795	BACKSPACE, ENDFILE, or the FLUSH statement. */
2796
2797	static match
2798	match_filepos (gfc_statement st, gfc_exec_op op)
2799	{
2800	gfc_filepos *fp;
2801	match m;
2802
2803	fp = XCNEW (gfc_filepos);
2804
2805	if (gfc_match_char ('(') == MATCH_NO)
2806	{
2807	m = gfc_match_expr (&fp->unit);
2808	if (m == MATCH_ERROR)
2809	goto cleanup;
2810	if (m == MATCH_NO)
2811	goto syntax;
2812
2813	goto done;
2814	}
2815
2816	m = match_file_element (fp);
2817	if (m == MATCH_ERROR)
2818	goto cleanup;
2819	if (m == MATCH_NO)
2820	{
2821	m = gfc_match_expr (&fp->unit);
2822	if (m == MATCH_ERROR || m == MATCH_NO)
2823	goto syntax;
2824	}
2825
2826	for (;;)
2827	{
2828	if (gfc_match_char (')') == MATCH_YES)
2829	break;
2830	if (gfc_match_char (',') != MATCH_YES)
2831	goto syntax;
2832
2833	m = match_file_element (fp);
2834	if (m == MATCH_ERROR)
2835	goto cleanup;
2836	if (m == MATCH_NO)
2837	goto syntax;
2838	}
2839
2840	done:
2841	if (gfc_match_eos () != MATCH_YES)
2842	goto syntax;
2843
2844	if (gfc_pure (NULL))
2845	{
2846	gfc_error ("%s statement not allowed in PURE procedure at %C",
2847	gfc_ascii_statement (st));
2848
2849	goto cleanup;
2850	}
2851
2852	gfc_unset_implicit_pure (NULL);
2853
2854	new_st.op = op;
2855	new_st.ext.filepos = fp;
2856	return MATCH_YES;
2857
2858	syntax:
2859	gfc_syntax_error (st);
2860
2861	cleanup:
2862	gfc_free_filepos (fp);
2863	return MATCH_ERROR;
2864	}
2865
2866
2867	bool
2868	gfc_resolve_filepos (gfc_filepos *fp, locus *where)
2869	{
2870	RESOLVE_TAG (&tag_unit, fp->unit);
2871	RESOLVE_TAG (&tag_iostat, fp->iostat);
2872	RESOLVE_TAG (&tag_iomsg, fp->iomsg);
2873
2874	if (!fp->unit && (fp->iostat || fp->iomsg || fp->err))
2875	{
2876	gfc_error ("UNIT number missing in statement at %L", where);
2877	return false;
2878	}
2879
2880	if (!gfc_reference_st_label (fp->err, ST_LABEL_TARGET))
2881	return false;
2882
2883	if (fp->unit->expr_type == EXPR_CONSTANT
2884	&& fp->unit->ts.type == BT_INTEGER
2885	&& mpz_sgn (fp->unit->value.integer) < 0)
2886	{
2887	gfc_error ("UNIT number in statement at %L must be non-negative",
2888	&fp->unit->where);
2889	return false;
2890	}
2891
2892	return true;
2893	}
2894
2895
2896	/* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2897	and the FLUSH statement. */
2898
2899	match
2900	gfc_match_endfile (void)
2901	{
2902	return match_filepos (st: ST_END_FILE, op: EXEC_ENDFILE);
2903	}
2904
2905	match
2906	gfc_match_backspace (void)
2907	{
2908	return match_filepos (st: ST_BACKSPACE, op: EXEC_BACKSPACE);
2909	}
2910
2911	match
2912	gfc_match_rewind (void)
2913	{
2914	return match_filepos (st: ST_REWIND, op: EXEC_REWIND);
2915	}
2916
2917	match
2918	gfc_match_flush (void)
2919	{
2920	if (!gfc_notify_std (GFC_STD_F2003, "FLUSH statement at %C"))
2921	return MATCH_ERROR;
2922
2923	return match_filepos (st: ST_FLUSH, op: EXEC_FLUSH);
2924	}
2925
2926	/******************** Data Transfer Statements *********************/
2927
2928	/* Return a default unit number. */
2929
2930	static gfc_expr *
2931	default_unit (io_kind k)
2932	{
2933	int unit;
2934
2935	if (k == M_READ)
2936	unit = 5;
2937	else
2938	unit = 6;
2939
2940	return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit);
2941	}
2942
2943
2944	/* Match a unit specification for a data transfer statement. */
2945
2946	static match
2947	match_dt_unit (io_kind k, gfc_dt *dt)
2948	{
2949	gfc_expr *e;
2950	char c;
2951
2952	if (gfc_match_char ('*') == MATCH_YES)
2953	{
2954	if (dt->io_unit != NULL)
2955	goto conflict;
2956
2957	dt->io_unit = default_unit (k);
2958
2959	c = gfc_peek_ascii_char ();
2960	if (c == ')')
2961	gfc_error_now ("Missing format with default unit at %C");
2962
2963	return MATCH_YES;
2964	}
2965
2966	if (gfc_match_expr (&e) == MATCH_YES)
2967	{
2968	if (dt->io_unit != NULL)
2969	{
2970	gfc_free_expr (e);
2971	goto conflict;
2972	}
2973
2974	dt->io_unit = e;
2975	return MATCH_YES;
2976	}
2977
2978	return MATCH_NO;
2979
2980	conflict:
2981	gfc_error ("Duplicate UNIT specification at %C");
2982	return MATCH_ERROR;
2983	}
2984
2985
2986	/* Match a format specification. */
2987
2988	static match
2989	match_dt_format (gfc_dt *dt)
2990	{
2991	locus where;
2992	gfc_expr *e;
2993	gfc_st_label *label;
2994	match m;
2995
2996	where = gfc_current_locus;
2997
2998	if (gfc_match_char ('*') == MATCH_YES)
2999	{
3000	if (dt->format_expr != NULL || dt->format_label != NULL)
3001	goto conflict;
3002
3003	dt->format_label = &format_asterisk;
3004	return MATCH_YES;
3005	}
3006
3007	if ((m = gfc_match_st_label (&label)) == MATCH_YES)
3008	{
3009	char c;
3010
3011	/* Need to check if the format label is actually either an operand
3012	to a user-defined operator or is a kind type parameter. That is,
3013	print 2.ip.8 ! .ip. is a user-defined operator return CHARACTER.
3014	print 1_'(I0)', i ! 1_'(I0)' is a default character string. */
3015
3016	gfc_gobble_whitespace ();
3017	c = gfc_peek_ascii_char ();
3018	if (c == '.' || c == '_')
3019	gfc_current_locus = where;
3020	else
3021	{
3022	if (dt->format_expr != NULL || dt->format_label != NULL)
3023	{
3024	gfc_free_st_label (label);
3025	goto conflict;
3026	}
3027
3028	if (!gfc_reference_st_label (label, ST_LABEL_FORMAT))
3029	return MATCH_ERROR;
3030
3031	dt->format_label = label;
3032	return MATCH_YES;
3033	}
3034	}
3035	else if (m == MATCH_ERROR)
3036	/* The label was zero or too large. Emit the correct diagnosis. */
3037	return MATCH_ERROR;
3038
3039	if (gfc_match_expr (&e) == MATCH_YES)
3040	{
3041	if (dt->format_expr != NULL || dt->format_label != NULL)
3042	{
3043	gfc_free_expr (e);
3044	goto conflict;
3045	}
3046	dt->format_expr = e;
3047	return MATCH_YES;
3048	}
3049
3050	gfc_current_locus = where; /* The only case where we have to restore */
3051
3052	return MATCH_NO;
3053
3054	conflict:
3055	gfc_error ("Duplicate format specification at %C");
3056	return MATCH_ERROR;
3057	}
3058
3059	/* Check for formatted read and write DTIO procedures. */
3060
3061	static bool
3062	dtio_procs_present (gfc_symbol *sym, io_kind k)
3063	{
3064	gfc_symbol *derived;
3065
3066	if (sym && sym->ts.u.derived)
3067	{
3068	if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
3069	derived = CLASS_DATA (sym)->ts.u.derived;
3070	else if (sym->ts.type == BT_DERIVED)
3071	derived = sym->ts.u.derived;
3072	else
3073	return false;
3074	if ((k == M_WRITE || k == M_PRINT) &&
3075	(gfc_find_specific_dtio_proc (derived, true, true) != NULL))
3076	return true;
3077	if ((k == M_READ) &&
3078	(gfc_find_specific_dtio_proc (derived, false, true) != NULL))
3079	return true;
3080	}
3081	return false;
3082	}
3083
3084	/* Traverse a namelist that is part of a READ statement to make sure
3085	that none of the variables in the namelist are INTENT(IN). Returns
3086	nonzero if we find such a variable. */
3087
3088	static int
3089	check_namelist (gfc_symbol *sym)
3090	{
3091	gfc_namelist *p;
3092
3093	for (p = sym->namelist; p; p = p->next)
3094	if (p->sym->attr.intent == INTENT_IN)
3095	{
3096	gfc_error ("Symbol %qs in namelist %qs is INTENT(IN) at %C",
3097	p->sym->name, sym->name);
3098	return 1;
3099	}
3100
3101	return 0;
3102	}
3103
3104
3105	/* Match a single data transfer element. */
3106
3107	static match
3108	match_dt_element (io_kind k, gfc_dt *dt)
3109	{
3110	char name[GFC_MAX_SYMBOL_LEN + 1];
3111	gfc_symbol *sym;
3112	match m;
3113
3114	if (gfc_match (" unit =") == MATCH_YES)
3115	{
3116	m = match_dt_unit (k, dt);
3117	if (m != MATCH_NO)
3118	return m;
3119	}
3120
3121	if (gfc_match (" fmt =") == MATCH_YES)
3122	{
3123	m = match_dt_format (dt);
3124	if (m != MATCH_NO)
3125	return m;
3126	}
3127
3128	if (gfc_match (" nml = %n", name) == MATCH_YES)
3129	{
3130	if (dt->namelist != NULL)
3131	{
3132	gfc_error ("Duplicate NML specification at %C");
3133	return MATCH_ERROR;
3134	}
3135
3136	if (gfc_find_symbol (name, NULL, 1, &sym))
3137	return MATCH_ERROR;
3138
3139	if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
3140	{
3141	gfc_error ("Symbol %qs at %C must be a NAMELIST group name",
3142	sym != NULL ? sym->name : name);
3143	return MATCH_ERROR;
3144	}
3145
3146	dt->namelist = sym;
3147	if (k == M_READ && check_namelist (sym))
3148	return MATCH_ERROR;
3149
3150	return MATCH_YES;
3151	}
3152
3153	m = match_etag (tag: &tag_e_async, v: &dt->asynchronous);
3154	if (m != MATCH_NO)
3155	return m;
3156	m = match_etag (tag: &tag_e_blank, v: &dt->blank);
3157	if (m != MATCH_NO)
3158	return m;
3159	m = match_etag (tag: &tag_e_delim, v: &dt->delim);
3160	if (m != MATCH_NO)
3161	return m;
3162	m = match_etag (tag: &tag_e_pad, v: &dt->pad);
3163	if (m != MATCH_NO)
3164	return m;
3165	m = match_etag (tag: &tag_e_sign, v: &dt->sign);
3166	if (m != MATCH_NO)
3167	return m;
3168	m = match_etag (tag: &tag_e_round, v: &dt->round);
3169	if (m != MATCH_NO)
3170	return m;
3171	m = match_out_tag (tag: &tag_id, result: &dt->id);
3172	if (m != MATCH_NO)
3173	return m;
3174	m = match_etag (tag: &tag_e_decimal, v: &dt->decimal);
3175	if (m != MATCH_NO)
3176	return m;
3177	m = match_etag (tag: &tag_rec, v: &dt->rec);
3178	if (m != MATCH_NO)
3179	return m;
3180	m = match_etag (tag: &tag_spos, v: &dt->pos);
3181	if (m != MATCH_NO)
3182	return m;
3183	m = match_etag (tag: &tag_iomsg, v: &dt->iomsg);
3184	if (m != MATCH_NO)
3185	return m;
3186
3187	m = match_out_tag (tag: &tag_iostat, result: &dt->iostat);
3188	if (m != MATCH_NO)
3189	return m;
3190	m = match_ltag (tag: &tag_err, label: &dt->err);
3191	if (m == MATCH_YES)
3192	dt->err_where = gfc_current_locus;
3193	if (m != MATCH_NO)
3194	return m;
3195	m = match_etag (tag: &tag_advance, v: &dt->advance);
3196	if (m != MATCH_NO)
3197	return m;
3198	m = match_out_tag (tag: &tag_size, result: &dt->size);
3199	if (m != MATCH_NO)
3200	return m;
3201
3202	m = match_ltag (tag: &tag_end, label: &dt->end);
3203	if (m == MATCH_YES)
3204	{
3205	if (k == M_WRITE)
3206	{
3207	gfc_error ("END tag at %C not allowed in output statement");
3208	return MATCH_ERROR;
3209	}
3210	dt->end_where = gfc_current_locus;
3211	}
3212	if (m != MATCH_NO)
3213	return m;
3214
3215	m = match_ltag (tag: &tag_eor, label: &dt->eor);
3216	if (m == MATCH_YES)
3217	dt->eor_where = gfc_current_locus;
3218	if (m != MATCH_NO)
3219	return m;
3220
3221	return MATCH_NO;
3222	}
3223
3224
3225	/* Free a data transfer structure and everything below it. */
3226
3227	void
3228	gfc_free_dt (gfc_dt *dt)
3229	{
3230	if (dt == NULL)
3231	return;
3232
3233	gfc_free_expr (dt->io_unit);
3234	gfc_free_expr (dt->format_expr);
3235	gfc_free_expr (dt->rec);
3236	gfc_free_expr (dt->advance);
3237	gfc_free_expr (dt->iomsg);
3238	gfc_free_expr (dt->iostat);
3239	gfc_free_expr (dt->size);
3240	gfc_free_expr (dt->pad);
3241	gfc_free_expr (dt->delim);
3242	gfc_free_expr (dt->sign);
3243	gfc_free_expr (dt->round);
3244	gfc_free_expr (dt->blank);
3245	gfc_free_expr (dt->decimal);
3246	gfc_free_expr (dt->pos);
3247	gfc_free_expr (dt->dt_io_kind);
3248	/* dt->extra_comma is a link to dt_io_kind if it is set. */
3249	free (ptr: dt);
3250	}
3251
3252
3253	static const char *
3254	io_kind_name (io_kind k);
3255
3256	static bool
3257	check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
3258	locus *spec_end);
3259
3260	/* Resolve everything in a gfc_dt structure. */
3261
3262	bool
3263	gfc_resolve_dt (gfc_code *dt_code, gfc_dt *dt, locus *loc)
3264	{
3265	gfc_expr *e;
3266	io_kind k;
3267
3268	/* This is set in any case. */
3269	gcc_assert (dt->dt_io_kind);
3270	k = dt->dt_io_kind->value.iokind;
3271
3272	RESOLVE_TAG (&tag_format, dt->format_expr);
3273	RESOLVE_TAG (&tag_rec, dt->rec);
3274	RESOLVE_TAG (&tag_spos, dt->pos);
3275	RESOLVE_TAG (&tag_advance, dt->advance);
3276	RESOLVE_TAG (&tag_id, dt->id);
3277	RESOLVE_TAG (&tag_iomsg, dt->iomsg);
3278	RESOLVE_TAG (&tag_iostat, dt->iostat);
3279	RESOLVE_TAG (&tag_size, dt->size);
3280	RESOLVE_TAG (&tag_e_pad, dt->pad);
3281	RESOLVE_TAG (&tag_e_delim, dt->delim);
3282	RESOLVE_TAG (&tag_e_sign, dt->sign);
3283	RESOLVE_TAG (&tag_e_round, dt->round);
3284	RESOLVE_TAG (&tag_e_blank, dt->blank);
3285	RESOLVE_TAG (&tag_e_decimal, dt->decimal);
3286	RESOLVE_TAG (&tag_e_async, dt->asynchronous);
3287
3288	/* Check I/O constraints.
3289	To validate NAMELIST we need to check if we were also given an I/O list,
3290	which is stored in code->block->next with op EXEC_TRANSFER.
3291	Note that the I/O list was already resolved from resolve_transfer. */
3292	gfc_code *io_code = NULL;
3293	if (dt_code && dt_code->block && dt_code->block->next
3294	&& dt_code->block->next->op == EXEC_TRANSFER)
3295	io_code = dt_code->block->next;
3296
3297	if (!check_io_constraints (k, dt, io_code, spec_end: loc))
3298	return false;
3299
3300	e = dt->io_unit;
3301	if (e == NULL)
3302	{
3303	gfc_error ("UNIT not specified at %L", loc);
3304	return false;
3305	}
3306
3307	if (e->symtree && e->symtree->n.sym->attr.flavor == FL_PARAMETER
3308	&& e->ts.type == BT_CHARACTER)
3309	{
3310	gfc_error ("UNIT specification at %L must "
3311	"not be a character PARAMETER", &e->where);
3312	return false;
3313	}
3314
3315	if (gfc_resolve_expr (e)
3316	&& (e->ts.type != BT_INTEGER
3317	&& (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
3318	{
3319	/* If there is no extra comma signifying the "format" form of the IO
3320	statement, then this must be an error. */
3321	if (!dt->extra_comma)
3322	{
3323	gfc_error ("UNIT specification at %L must be an INTEGER expression "
3324	"or a CHARACTER variable", &e->where);
3325	return false;
3326	}
3327	else
3328	{
3329	/* At this point, we have an extra comma. If io_unit has arrived as
3330	type character, we assume its really the "format" form of the I/O
3331	statement. We set the io_unit to the default unit and format to
3332	the character expression. See F95 Standard section 9.4. */
3333	if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
3334	{
3335	dt->format_expr = dt->io_unit;
3336	dt->io_unit = default_unit (k);
3337
3338	/* Nullify this pointer now so that a warning/error is not
3339	triggered below for the "Extension". */
3340	dt->extra_comma = NULL;
3341	}
3342
3343	if (k == M_WRITE)
3344	{
3345	gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
3346	&dt->extra_comma->where);
3347	return false;
3348	}
3349	}
3350	}
3351
3352	if (e->ts.type == BT_CHARACTER)
3353	{
3354	if (gfc_has_vector_index (e))
3355	{
3356	gfc_error ("Internal unit with vector subscript at %L", &e->where);
3357	return false;
3358	}
3359
3360	/* If we are writing, make sure the internal unit can be changed. */
3361	gcc_assert (k != M_PRINT);
3362	if (k == M_WRITE
3363	&& !gfc_check_vardef_context (e, false, false, false,
3364	_("internal unit in WRITE")))
3365	return false;
3366	}
3367
3368	if (e->rank && e->ts.type != BT_CHARACTER)
3369	{
3370	gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
3371	return false;
3372	}
3373
3374	if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER
3375	&& mpz_sgn (e->value.integer) < 0)
3376	{
3377	gfc_error ("UNIT number in statement at %L must be non-negative",
3378	&e->where);
3379	return false;
3380	}
3381
3382	/* If we are reading and have a namelist, check that all namelist symbols
3383	can appear in a variable definition context. */
3384	if (dt->namelist)
3385	{
3386	gfc_namelist* n;
3387	for (n = dt->namelist->namelist; n; n = n->next)
3388	{
3389	gfc_expr* e;
3390	bool t;
3391
3392	if (k == M_READ)
3393	{
3394	e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
3395	t = gfc_check_vardef_context (e, false, false, false, NULL);
3396	gfc_free_expr (e);
3397
3398	if (!t)
3399	{
3400	gfc_error ("NAMELIST %qs in READ statement at %L contains"
3401	" the symbol %qs which may not appear in a"
3402	" variable definition context",
3403	dt->namelist->name, loc, n->sym->name);
3404	return false;
3405	}
3406	}
3407
3408	t = dtio_procs_present (sym: n->sym, k);
3409
3410	if (n->sym->ts.type == BT_CLASS && !t)
3411	{
3412	gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
3413	"polymorphic and requires a defined input/output "
3414	"procedure", n->sym->name, dt->namelist->name, loc);
3415	return false;
3416	}
3417
3418	if ((n->sym->ts.type == BT_DERIVED)
3419	&& (n->sym->ts.u.derived->attr.alloc_comp
3420	|| n->sym->ts.u.derived->attr.pointer_comp))
3421	{
3422	if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
3423	"namelist %qs at %L with ALLOCATABLE "
3424	"or POINTER components", n->sym->name,
3425	dt->namelist->name, loc))
3426	return false;
3427
3428	if (!t)
3429	{
3430	gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
3431	"ALLOCATABLE or POINTER components and thus requires "
3432	"a defined input/output procedure", n->sym->name,
3433	dt->namelist->name, loc);
3434	return false;
3435	}
3436	}
3437	}
3438	}
3439
3440	if (dt->extra_comma
3441	&& !gfc_notify_std (GFC_STD_LEGACY, "Comma before i/o item list at %L",
3442	&dt->extra_comma->where))
3443	return false;
3444
3445	if (dt->err)
3446	{
3447	if (!gfc_reference_st_label (dt->err, ST_LABEL_TARGET))
3448	return false;
3449	if (dt->err->defined == ST_LABEL_UNKNOWN)
3450	{
3451	gfc_error ("ERR tag label %d at %L not defined",
3452	dt->err->value, &dt->err_where);
3453	return false;
3454	}
3455	}
3456
3457	if (dt->end)
3458	{
3459	if (!gfc_reference_st_label (dt->end, ST_LABEL_TARGET))
3460	return false;
3461	if (dt->end->defined == ST_LABEL_UNKNOWN)
3462	{
3463	gfc_error ("END tag label %d at %L not defined",
3464	dt->end->value, &dt->end_where);
3465	return false;
3466	}
3467	}
3468
3469	if (dt->eor)
3470	{
3471	if (!gfc_reference_st_label (dt->eor, ST_LABEL_TARGET))
3472	return false;
3473	if (dt->eor->defined == ST_LABEL_UNKNOWN)
3474	{
3475	gfc_error ("EOR tag label %d at %L not defined",
3476	dt->eor->value, &dt->eor_where);
3477	return false;
3478	}
3479	}
3480
3481	/* Check the format label actually exists. */
3482	if (dt->format_label && dt->format_label != &format_asterisk
3483	&& dt->format_label->defined == ST_LABEL_UNKNOWN)
3484	{
3485	gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
3486	loc);
3487	return false;
3488	}
3489
3490	return true;
3491	}
3492
3493
3494	/* Given an io_kind, return its name. */
3495
3496	static const char *
3497	io_kind_name (io_kind k)
3498	{
3499	const char *name;
3500
3501	switch (k)
3502	{
3503	case M_READ:
3504	name = "READ";
3505	break;
3506	case M_WRITE:
3507	name = "WRITE";
3508	break;
3509	case M_PRINT:
3510	name = "PRINT";
3511	break;
3512	case M_INQUIRE:
3513	name = "INQUIRE";
3514	break;
3515	default:
3516	gfc_internal_error ("io_kind_name(): bad I/O-kind");
3517	}
3518
3519	return name;
3520	}
3521
3522
3523	/* Match an IO iteration statement of the form:
3524
3525	( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
3526
3527	which is equivalent to a single IO element. This function is
3528	mutually recursive with match_io_element(). */
3529
3530	static match match_io_element (io_kind, gfc_code **);
3531
3532	static match
3533	match_io_iterator (io_kind k, gfc_code **result)
3534	{
3535	gfc_code *head, *tail, *new_code;
3536	gfc_iterator *iter;
3537	locus old_loc;
3538	match m;
3539	int n;
3540
3541	iter = NULL;
3542	head = NULL;
3543	old_loc = gfc_current_locus;
3544
3545	if (gfc_match_char ('(') != MATCH_YES)
3546	return MATCH_NO;
3547
3548	m = match_io_element (k, &head);
3549	tail = head;
3550
3551	if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
3552	{
3553	m = MATCH_NO;
3554	goto cleanup;
3555	}
3556
3557	/* Can't be anything but an IO iterator. Build a list. */
3558	iter = gfc_get_iterator ();
3559
3560	for (n = 1;; n++)
3561	{
3562	m = gfc_match_iterator (iter, 0);
3563	if (m == MATCH_ERROR)
3564	goto cleanup;
3565	if (m == MATCH_YES)
3566	{
3567	gfc_check_do_variable (iter->var->symtree);
3568	break;
3569	}
3570
3571	m = match_io_element (k, &new_code);
3572	if (m == MATCH_ERROR)
3573	goto cleanup;
3574	if (m == MATCH_NO)
3575	{
3576	if (n > 2)
3577	goto syntax;
3578	goto cleanup;
3579	}
3580
3581	tail = gfc_append_code (tail, new_code);
3582
3583	if (gfc_match_char (',') != MATCH_YES)
3584	{
3585	if (n > 2)
3586	goto syntax;
3587	m = MATCH_NO;
3588	goto cleanup;
3589	}
3590	}
3591
3592	if (gfc_match_char (')') != MATCH_YES)
3593	goto syntax;
3594
3595	new_code = gfc_get_code (EXEC_DO);
3596	new_code->ext.iterator = iter;
3597
3598	new_code->block = gfc_get_code (EXEC_DO);
3599	new_code->block->next = head;
3600
3601	*result = new_code;
3602	return MATCH_YES;
3603
3604	syntax:
3605	gfc_error ("Syntax error in I/O iterator at %C");
3606	m = MATCH_ERROR;
3607
3608	cleanup:
3609	gfc_free_iterator (iter, 1);
3610	gfc_free_statements (head);
3611	gfc_current_locus = old_loc;
3612	return m;
3613	}
3614
3615
3616	/* Match a single element of an IO list, which is either a single
3617	expression or an IO Iterator. */
3618
3619	static match
3620	match_io_element (io_kind k, gfc_code **cpp)
3621	{
3622	gfc_expr *expr;
3623	gfc_code *cp;
3624	match m;
3625
3626	expr = NULL;
3627
3628	m = match_io_iterator (k, result: cpp);
3629	if (m == MATCH_YES)
3630	return MATCH_YES;
3631
3632	if (k == M_READ)
3633	{
3634	m = gfc_match_variable (&expr, 0);
3635	if (m == MATCH_NO)
3636	{
3637	gfc_error ("Expecting variable in READ statement at %C");
3638	m = MATCH_ERROR;
3639	}
3640
3641	if (m == MATCH_YES && expr->expr_type == EXPR_CONSTANT)
3642	{
3643	gfc_error ("Expecting variable or io-implied-do in READ statement "
3644	"at %L", &expr->where);
3645	m = MATCH_ERROR;
3646	}
3647
3648	if (m == MATCH_YES
3649	&& expr->expr_type == EXPR_VARIABLE
3650	&& expr->symtree->n.sym->attr.external)
3651	{
3652	gfc_error ("Expecting variable or io-implied-do at %L",
3653	&expr->where);
3654	m = MATCH_ERROR;
3655	}
3656	}
3657	else
3658	{
3659	m = gfc_match_expr (&expr);
3660	if (m == MATCH_NO)
3661	gfc_error ("Expected expression in %s statement at %C",
3662	io_kind_name (k));
3663
3664	if (m == MATCH_YES && expr->ts.type == BT_BOZ)
3665	{
3666	if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in"
3667	" an output IO list"), &gfc_current_locus))
3668	return MATCH_ERROR;
3669	if (!gfc_boz2int (expr, gfc_max_integer_kind))
3670	return MATCH_ERROR;
3671	};
3672	}
3673
3674	if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree))
3675	m = MATCH_ERROR;
3676
3677	if (m != MATCH_YES)
3678	{
3679	gfc_free_expr (expr);
3680	return MATCH_ERROR;
3681	}
3682
3683	cp = gfc_get_code (EXEC_TRANSFER);
3684	cp->expr1 = expr;
3685	if (k != M_INQUIRE)
3686	cp->ext.dt = current_dt;
3687
3688	*cpp = cp;
3689	return MATCH_YES;
3690	}
3691
3692
3693	/* Match an I/O list, building gfc_code structures as we go. */
3694
3695	static match
3696	match_io_list (io_kind k, gfc_code **head_p)
3697	{
3698	gfc_code *head, *tail, *new_code;
3699	match m;
3700
3701	*head_p = head = tail = NULL;
3702	if (gfc_match_eos () == MATCH_YES)
3703	return MATCH_YES;
3704
3705	for (;;)
3706	{
3707	m = match_io_element (k, cpp: &new_code);
3708	if (m == MATCH_ERROR)
3709	goto cleanup;
3710	if (m == MATCH_NO)
3711	goto syntax;
3712
3713	tail = gfc_append_code (tail, new_code);
3714	if (head == NULL)
3715	head = new_code;
3716
3717	if (gfc_match_eos () == MATCH_YES)
3718	break;
3719	if (gfc_match_char (',') != MATCH_YES)
3720	goto syntax;
3721	}
3722
3723	*head_p = head;
3724	return MATCH_YES;
3725
3726	syntax:
3727	gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3728
3729	cleanup:
3730	gfc_free_statements (head);
3731	return MATCH_ERROR;
3732	}
3733
3734
3735	/* Attach the data transfer end node. */
3736
3737	static void
3738	terminate_io (gfc_code *io_code)
3739	{
3740	gfc_code *c;
3741
3742	if (io_code == NULL)
3743	io_code = new_st.block;
3744
3745	c = gfc_get_code (EXEC_DT_END);
3746
3747	/* Point to structure that is already there */
3748	c->ext.dt = new_st.ext.dt;
3749	gfc_append_code (io_code, c);
3750	}
3751
3752
3753	/* Check the constraints for a data transfer statement. The majority of the
3754	constraints appearing in 9.4 of the standard appear here.
3755
3756	Tag expressions are already resolved by resolve_tag, which includes
3757	verifying the type, that they are scalar, and verifying that BT_CHARACTER
3758	tags are of default kind. */
3759
3760	static bool
3761	check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
3762	locus *spec_end)
3763	{
3764	#define io_constraint(condition, msg, arg)\
3765	if (condition) \
3766	{\
3767	if ((arg)->lb != NULL)\
3768	gfc_error ((msg), (arg));\
3769	else\
3770	gfc_error ((msg), spec_end);\
3771	return false;\
3772	}
3773
3774	gfc_expr *expr;
3775	gfc_symbol *sym = NULL;
3776	bool warn, unformatted;
3777
3778	warn = (dt->err || dt->iostat) ? true : false;
3779	unformatted = dt->format_expr == NULL && dt->format_label == NULL
3780	&& dt->namelist == NULL;
3781
3782	expr = dt->io_unit;
3783	if (expr && expr->expr_type == EXPR_VARIABLE
3784	&& expr->ts.type == BT_CHARACTER)
3785	{
3786	sym = expr->symtree->n.sym;
3787
3788	io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
3789	"Internal file at %L must not be INTENT(IN)",
3790	&expr->where);
3791
3792	io_constraint (gfc_has_vector_index (dt->io_unit),
3793	"Internal file incompatible with vector subscript at %L",
3794	&expr->where);
3795
3796	io_constraint (dt->rec != NULL,
3797	"REC tag at %L is incompatible with internal file",
3798	&dt->rec->where);
3799
3800	io_constraint (dt->pos != NULL,
3801	"POS tag at %L is incompatible with internal file",
3802	&dt->pos->where);
3803
3804	io_constraint (unformatted,
3805	"Unformatted I/O not allowed with internal unit at %L",
3806	&dt->io_unit->where);
3807
3808	io_constraint (dt->asynchronous != NULL,
3809	"ASYNCHRONOUS tag at %L not allowed with internal file",
3810	&dt->asynchronous->where);
3811
3812	if (dt->namelist != NULL)
3813	{
3814	if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with "
3815	"namelist", &expr->where))
3816	return false;
3817	}
3818
3819	io_constraint (dt->advance != NULL,
3820	"ADVANCE tag at %L is incompatible with internal file",
3821	&dt->advance->where);
3822	}
3823
3824	if (expr && expr->ts.type != BT_CHARACTER)
3825	{
3826
3827	if (gfc_pure (NULL) && (k == M_READ || k == M_WRITE))
3828	{
3829	gfc_error ("IO UNIT in %s statement at %L must be "
3830	"an internal file in a PURE procedure",
3831	io_kind_name (k), &expr->where);
3832	return false;
3833	}
3834
3835	if (k == M_READ || k == M_WRITE)
3836	gfc_unset_implicit_pure (NULL);
3837	}
3838
3839	if (dt->asynchronous)
3840	{
3841	int num = -1;
3842	static const char * asynchronous[] = { "YES", "NO", NULL };
3843
3844	/* Note: gfc_reduce_init_expr reports an error if not init-expr. */
3845	if (!gfc_reduce_init_expr (expr: dt->asynchronous))
3846	return false;
3847
3848	if (!compare_to_allowed_values
3849	(specifier: "ASYNCHRONOUS", allowed: asynchronous, NULL, NULL,
3850	value: dt->asynchronous->value.character.string,
3851	statement: io_kind_name (k), warn, where: &dt->asynchronous->where, num: &num))
3852	return false;
3853
3854	gcc_checking_assert (num != -1);
3855
3856	/* For "YES", mark related symbols as asynchronous. */
3857	if (num == 0)
3858	{
3859	/* SIZE variable. */
3860	if (dt->size)
3861	dt->size->symtree->n.sym->attr.asynchronous = 1;
3862
3863	/* Variables in a NAMELIST. */
3864	if (dt->namelist)
3865	for (gfc_namelist *nl = dt->namelist->namelist; nl; nl = nl->next)
3866	nl->sym->attr.asynchronous = 1;
3867
3868	/* Variables in an I/O list. */
3869	for (gfc_code *xfer = io_code; xfer && xfer->op == EXEC_TRANSFER;
3870	xfer = xfer->next)
3871	{
3872	gfc_expr *expr = xfer->expr1;
3873	while (expr != NULL && expr->expr_type == EXPR_OP
3874	&& expr->value.op.op == INTRINSIC_PARENTHESES)
3875	expr = expr->value.op.op1;
3876
3877	if (expr && expr->expr_type == EXPR_VARIABLE)
3878	expr->symtree->n.sym->attr.asynchronous = 1;
3879	}
3880	}
3881	}
3882
3883	if (dt->id)
3884	{
3885	bool not_yes
3886	= !dt->asynchronous
3887	|| gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
3888	|| gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
3889	"yes", 3) != 0;
3890	io_constraint (not_yes,
3891	"ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3892	"specifier", &dt->id->where);
3893	}
3894
3895	if (dt->decimal)
3896	{
3897	if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L "
3898	"not allowed in Fortran 95", &dt->decimal->where))
3899	return false;
3900
3901	if (dt->decimal->expr_type == EXPR_CONSTANT)
3902	{
3903	static const char * decimal[] = { "COMMA", "POINT", NULL };
3904
3905	if (!compare_to_allowed_values (specifier: "DECIMAL", allowed: decimal, NULL, NULL,
3906	value: dt->decimal->value.character.string,
3907	statement: io_kind_name (k), warn,
3908	where: &dt->decimal->where))
3909	return false;
3910
3911	io_constraint (unformatted,
3912	"the DECIMAL= specifier at %L must be with an "
3913	"explicit format expression", &dt->decimal->where);
3914	}
3915	}
3916
3917	if (dt->blank)
3918	{
3919	if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L "
3920	"not allowed in Fortran 95", &dt->blank->where))
3921	return false;
3922
3923	if (dt->blank->expr_type == EXPR_CONSTANT)
3924	{
3925	static const char * blank[] = { "NULL", "ZERO", NULL };
3926
3927
3928	if (!compare_to_allowed_values (specifier: "BLANK", allowed: blank, NULL, NULL,
3929	value: dt->blank->value.character.string,
3930	statement: io_kind_name (k), warn,
3931	where: &dt->blank->where))
3932	return false;
3933
3934	io_constraint (unformatted,
3935	"the BLANK= specifier at %L must be with an "
3936	"explicit format expression", &dt->blank->where);
3937	}
3938	}
3939
3940	if (dt->pad)
3941	{
3942	if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %L "
3943	"not allowed in Fortran 95", &dt->pad->where))
3944	return false;
3945
3946	if (dt->pad->expr_type == EXPR_CONSTANT)
3947	{
3948	static const char * pad[] = { "YES", "NO", NULL };
3949
3950	if (!compare_to_allowed_values (specifier: "PAD", allowed: pad, NULL, NULL,
3951	value: dt->pad->value.character.string,
3952	statement: io_kind_name (k), warn,
3953	where: &dt->pad->where))
3954	return false;
3955
3956	io_constraint (unformatted,
3957	"the PAD= specifier at %L must be with an "
3958	"explicit format expression", &dt->pad->where);
3959	}
3960	}
3961
3962	if (dt->round)
3963	{
3964	if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L "
3965	"not allowed in Fortran 95", &dt->round->where))
3966	return false;
3967
3968	if (dt->round->expr_type == EXPR_CONSTANT)
3969	{
3970	static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
3971	"COMPATIBLE", "PROCESSOR_DEFINED",
3972	NULL };
3973
3974	if (!compare_to_allowed_values (specifier: "ROUND", allowed: round, NULL, NULL,
3975	value: dt->round->value.character.string,
3976	statement: io_kind_name (k), warn,
3977	where: &dt->round->where))
3978	return false;
3979	}
3980	}
3981
3982	if (dt->sign)
3983	{
3984	/* When implemented, change the following to use gfc_notify_std F2003.
3985	if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %L "
3986	"not allowed in Fortran 95", &dt->sign->where) == false)
3987	return false; */
3988
3989	if (dt->sign->expr_type == EXPR_CONSTANT)
3990	{
3991	static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3992	NULL };
3993
3994	if (!compare_to_allowed_values (specifier: "SIGN", allowed: sign, NULL, NULL,
3995	value: dt->sign->value.character.string,
3996	statement: io_kind_name (k), warn, where: &dt->sign->where))
3997	return false;
3998
3999	io_constraint (unformatted,
4000	"SIGN= specifier at %L must be with an "
4001	"explicit format expression", &dt->sign->where);
4002
4003	io_constraint (k == M_READ,
4004	"SIGN= specifier at %L not allowed in a "
4005	"READ statement", &dt->sign->where);
4006	}
4007	}
4008
4009	if (dt->delim)
4010	{
4011	if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %L "
4012	"not allowed in Fortran 95", &dt->delim->where))
4013	return false;
4014
4015	if (dt->delim->expr_type == EXPR_CONSTANT)
4016	{
4017	static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
4018
4019	if (!compare_to_allowed_values (specifier: "DELIM", allowed: delim, NULL, NULL,
4020	value: dt->delim->value.character.string,
4021	statement: io_kind_name (k), warn,
4022	where: &dt->delim->where))
4023	return false;
4024
4025	io_constraint (k == M_READ,
4026	"DELIM= specifier at %L not allowed in a "
4027	"READ statement", &dt->delim->where);
4028
4029	io_constraint (dt->format_label != &format_asterisk
4030	&& dt->namelist == NULL,
4031	"DELIM= specifier at %L must have FMT=*",
4032	&dt->delim->where);
4033
4034	io_constraint (unformatted && dt->namelist == NULL,
4035	"DELIM= specifier at %L must be with FMT=* or "
4036	"NML= specifier", &dt->delim->where);
4037	}
4038	}
4039
4040	if (dt->namelist)
4041	{
4042	io_constraint (io_code && dt->namelist,
4043	"NAMELIST cannot be followed by IO-list at %L",
4044	&io_code->loc);
4045
4046	io_constraint (dt->format_expr,
4047	"IO spec-list cannot contain both NAMELIST group name "
4048	"and format specification at %L",
4049	&dt->format_expr->where);
4050
4051	io_constraint (dt->format_label,
4052	"IO spec-list cannot contain both NAMELIST group name "
4053	"and format label at %L", spec_end);
4054
4055	io_constraint (dt->rec,
4056	"NAMELIST IO is not allowed with a REC= specifier "
4057	"at %L", &dt->rec->where);
4058
4059	io_constraint (dt->advance,
4060	"NAMELIST IO is not allowed with a ADVANCE= specifier "
4061	"at %L", &dt->advance->where);
4062	}
4063
4064	if (dt->rec)
4065	{
4066	io_constraint (dt->end,
4067	"An END tag is not allowed with a "
4068	"REC= specifier at %L", &dt->end_where);
4069
4070	io_constraint (dt->format_label == &format_asterisk,
4071	"FMT=* is not allowed with a REC= specifier "
4072	"at %L", spec_end);
4073
4074	io_constraint (dt->pos,
4075	"POS= is not allowed with REC= specifier "
4076	"at %L", &dt->pos->where);
4077	}
4078
4079	if (dt->advance)
4080	{
4081	int not_yes, not_no;
4082	expr = dt->advance;
4083
4084	io_constraint (dt->format_label == &format_asterisk,
4085	"List directed format(*) is not allowed with a "
4086	"ADVANCE= specifier at %L.", &expr->where);
4087
4088	io_constraint (unformatted,
4089	"the ADVANCE= specifier at %L must appear with an "
4090	"explicit format expression", &expr->where);
4091
4092	if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
4093	{
4094	const gfc_char_t *advance = expr->value.character.string;
4095	not_no = gfc_wide_strlen (advance) != 2
4096	|| gfc_wide_strncasecmp (advance, "no", 2) != 0;
4097	not_yes = gfc_wide_strlen (advance) != 3
4098	|| gfc_wide_strncasecmp (advance, "yes", 3) != 0;
4099	}
4100	else
4101	{
4102	not_no = 0;
4103	not_yes = 0;
4104	}
4105
4106	io_constraint (not_no && not_yes,
4107	"ADVANCE= specifier at %L must have value = "
4108	"YES or NO.", &expr->where);
4109
4110	io_constraint (dt->size && not_no && k == M_READ,
4111	"SIZE tag at %L requires an ADVANCE = %<NO%>",
4112	&dt->size->where);
4113
4114	io_constraint (dt->eor && not_no && k == M_READ,
4115	"EOR tag at %L requires an ADVANCE = %<NO%>",
4116	&dt->eor_where);
4117	}
4118
4119	if (k != M_READ)
4120	{
4121	io_constraint (dt->end, "END tag not allowed with output at %L",
4122	&dt->end_where);
4123
4124	io_constraint (dt->eor, "EOR tag not allowed with output at %L",
4125	&dt->eor_where);
4126
4127	io_constraint (dt->blank,
4128	"BLANK= specifier not allowed with output at %L",
4129	&dt->blank->where);
4130
4131	io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
4132	&dt->pad->where);
4133
4134	io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
4135	&dt->size->where);
4136	}
4137	else
4138	{
4139	io_constraint (dt->size && dt->advance == NULL,
4140	"SIZE tag at %L requires an ADVANCE tag",
4141	&dt->size->where);
4142
4143	io_constraint (dt->eor && dt->advance == NULL,
4144	"EOR tag at %L requires an ADVANCE tag",
4145	&dt->eor_where);
4146	}
4147
4148	return true;
4149	#undef io_constraint
4150	}
4151
4152
4153	/* Match a READ, WRITE or PRINT statement. */
4154
4155	static match
4156	match_io (io_kind k)
4157	{
4158	char name[GFC_MAX_SYMBOL_LEN + 1];
4159	gfc_code *io_code;
4160	gfc_symbol *sym;
4161	int comma_flag;
4162	locus where;
4163	locus control;
4164	gfc_dt *dt;
4165	match m;
4166
4167	where = gfc_current_locus;
4168	comma_flag = 0;
4169	current_dt = dt = XCNEW (gfc_dt);
4170	m = gfc_match_char ('(');
4171	if (m == MATCH_NO)
4172	{
4173	where = gfc_current_locus;
4174	if (k == M_WRITE)
4175	goto syntax;
4176	else if (k == M_PRINT)
4177	{
4178	/* Treat the non-standard case of PRINT namelist. */
4179	if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
4180	&& gfc_match_name (name) == MATCH_YES)
4181	{
4182	gfc_find_symbol (name, NULL, 1, &sym);
4183	if (sym && sym->attr.flavor == FL_NAMELIST)
4184	{
4185	if (!gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
4186	"%C is an extension"))
4187	{
4188	m = MATCH_ERROR;
4189	goto cleanup;
4190	}
4191
4192	dt->io_unit = default_unit (k);
4193	dt->namelist = sym;
4194	goto get_io_list;
4195	}
4196	else
4197	gfc_current_locus = where;
4198	}
4199
4200	if (gfc_match_char ('*') == MATCH_YES
4201	&& gfc_match_char(',') == MATCH_YES)
4202	{
4203	locus where2 = gfc_current_locus;
4204	if (gfc_match_eos () == MATCH_YES)
4205	{
4206	gfc_current_locus = where2;
4207	gfc_error ("Comma after * at %C not allowed without I/O list");
4208	m = MATCH_ERROR;
4209	goto cleanup;
4210	}
4211	else
4212	gfc_current_locus = where;
4213	}
4214	else
4215	gfc_current_locus = where;
4216	}
4217
4218	if (gfc_current_form == FORM_FREE)
4219	{
4220	char c = gfc_peek_ascii_char ();
4221	if (c != ' ' && c != '*' && c != '\'' && c != '"')
4222	{
4223	m = MATCH_NO;
4224	goto cleanup;
4225	}
4226	}
4227
4228	m = match_dt_format (dt);
4229	if (m == MATCH_ERROR)
4230	goto cleanup;
4231	if (m == MATCH_NO)
4232	goto syntax;
4233
4234	comma_flag = 1;
4235	dt->io_unit = default_unit (k);
4236	goto get_io_list;
4237	}
4238	else
4239	{
4240	/* Before issuing an error for a malformed 'print (1,*)' type of
4241	error, check for a default-char-expr of the form ('(I0)'). */
4242	if (m == MATCH_YES)
4243	{
4244	control = gfc_current_locus;
4245	if (k == M_PRINT)
4246	{
4247	/* Reset current locus to get the initial '(' in an expression. */
4248	gfc_current_locus = where;
4249	dt->format_expr = NULL;
4250	m = match_dt_format (dt);
4251
4252	if (m == MATCH_ERROR)
4253	goto cleanup;
4254	if (m == MATCH_NO || dt->format_expr == NULL)
4255	goto syntax;
4256
4257	comma_flag = 1;
4258	dt->io_unit = default_unit (k);
4259	goto get_io_list;
4260	}
4261	if (k == M_READ)
4262	{
4263	/* Commit any pending symbols now so that when we undo
4264	symbols later we wont lose them. */
4265	gfc_commit_symbols ();
4266	/* Reset current locus to get the initial '(' in an expression. */
4267	gfc_current_locus = where;
4268	dt->format_expr = NULL;
4269	m = gfc_match_expr (&dt->format_expr);
4270	if (m == MATCH_YES)
4271	{
4272	if (dt->format_expr
4273	&& dt->format_expr->ts.type == BT_CHARACTER)
4274	{
4275	comma_flag = 1;
4276	dt->io_unit = default_unit (k);
4277	goto get_io_list;
4278	}
4279	else
4280	{
4281	gfc_free_expr (dt->format_expr);
4282	dt->format_expr = NULL;
4283	gfc_current_locus = control;
4284	}
4285	}
4286	else
4287	{
4288	gfc_clear_error ();
4289	gfc_undo_symbols ();
4290	gfc_free_expr (dt->format_expr);
4291	dt->format_expr = NULL;
4292	gfc_current_locus = control;
4293	}
4294	}
4295	}
4296	}
4297
4298	/* Match a control list */
4299	if (match_dt_element (k, dt) == MATCH_YES)
4300	goto next;
4301	if (match_dt_unit (k, dt) != MATCH_YES)
4302	goto loop;
4303
4304	if (gfc_match_char (')') == MATCH_YES)
4305	goto get_io_list;
4306	if (gfc_match_char (',') != MATCH_YES)
4307	goto syntax;
4308
4309	m = match_dt_element (k, dt);
4310	if (m == MATCH_YES)
4311	goto next;
4312	if (m == MATCH_ERROR)
4313	goto cleanup;
4314
4315	m = match_dt_format (dt);
4316	if (m == MATCH_YES)
4317	goto next;
4318	if (m == MATCH_ERROR)
4319	goto cleanup;
4320
4321	where = gfc_current_locus;
4322
4323	m = gfc_match_name (name);
4324	if (m == MATCH_YES)
4325	{
4326	gfc_find_symbol (name, NULL, 1, &sym);
4327	if (sym && sym->attr.flavor == FL_NAMELIST)
4328	{
4329	dt->namelist = sym;
4330	if (k == M_READ && check_namelist (sym))
4331	{
4332	m = MATCH_ERROR;
4333	goto cleanup;
4334	}
4335	goto next;
4336	}
4337	}
4338
4339	gfc_current_locus = where;
4340
4341	goto loop; /* No matches, try regular elements */
4342
4343	next:
4344	if (gfc_match_char (')') == MATCH_YES)
4345	goto get_io_list;
4346	if (gfc_match_char (',') != MATCH_YES)
4347	goto syntax;
4348
4349	loop:
4350	for (;;)
4351	{
4352	m = match_dt_element (k, dt);
4353	if (m == MATCH_NO)
4354	goto syntax;
4355	if (m == MATCH_ERROR)
4356	goto cleanup;
4357
4358	if (gfc_match_char (')') == MATCH_YES)
4359	break;
4360	if (gfc_match_char (',') != MATCH_YES)
4361	goto syntax;
4362	}
4363
4364	get_io_list:
4365
4366	/* Save the IO kind for later use. */
4367	dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k);
4368
4369	/* Optional leading comma (non-standard). We use a gfc_expr structure here
4370	to save the locus. This is used later when resolving transfer statements
4371	that might have a format expression without unit number. */
4372	if (!comma_flag && gfc_match_char (',') == MATCH_YES)
4373	dt->extra_comma = dt->dt_io_kind;
4374
4375	io_code = NULL;
4376	if (gfc_match_eos () != MATCH_YES)
4377	{
4378	if (comma_flag && gfc_match_char (',') != MATCH_YES)
4379	{
4380	gfc_error ("Expected comma in I/O list at %C");
4381	m = MATCH_ERROR;
4382	goto cleanup;
4383	}
4384
4385	m = match_io_list (k, head_p: &io_code);
4386	if (m == MATCH_ERROR)
4387	goto cleanup;
4388	if (m == MATCH_NO)
4389	goto syntax;
4390	}
4391
4392	/* See if we want to use defaults for missing exponents in real transfers
4393	and other DEC runtime extensions. */
4394	if (flag_dec_format_defaults)
4395	dt->dec_ext = 1;
4396
4397	/* Check the format string now. */
4398	if (dt->format_expr
4399	&& (!gfc_simplify_expr (dt->format_expr, 0)
4400	|| !check_format_string (e: dt->format_expr, is_input: k == M_READ)))
4401	return MATCH_ERROR;
4402
4403	new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
4404	new_st.ext.dt = dt;
4405	new_st.block = gfc_get_code (new_st.op);
4406	new_st.block->next = io_code;
4407
4408	terminate_io (io_code);
4409
4410	return MATCH_YES;
4411
4412	syntax:
4413	gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
4414	m = MATCH_ERROR;
4415
4416	cleanup:
4417	gfc_free_dt (dt);
4418	return m;
4419	}
4420
4421
4422	match
4423	gfc_match_read (void)
4424	{
4425	return match_io (k: M_READ);
4426	}
4427
4428
4429	match
4430	gfc_match_write (void)
4431	{
4432	return match_io (k: M_WRITE);
4433	}
4434
4435
4436	match
4437	gfc_match_print (void)
4438	{
4439	match m;
4440
4441	m = match_io (k: M_PRINT);
4442	if (m != MATCH_YES)
4443	return m;
4444
4445	if (gfc_pure (NULL))
4446	{
4447	gfc_error ("PRINT statement at %C not allowed within PURE procedure");
4448	return MATCH_ERROR;
4449	}
4450
4451	gfc_unset_implicit_pure (NULL);
4452
4453	return MATCH_YES;
4454	}
4455
4456
4457	/* Free a gfc_inquire structure. */
4458
4459	void
4460	gfc_free_inquire (gfc_inquire *inquire)
4461	{
4462
4463	if (inquire == NULL)
4464	return;
4465
4466	gfc_free_expr (inquire->unit);
4467	gfc_free_expr (inquire->file);
4468	gfc_free_expr (inquire->iomsg);
4469	gfc_free_expr (inquire->iostat);
4470	gfc_free_expr (inquire->exist);
4471	gfc_free_expr (inquire->opened);
4472	gfc_free_expr (inquire->number);
4473	gfc_free_expr (inquire->named);
4474	gfc_free_expr (inquire->name);
4475	gfc_free_expr (inquire->access);
4476	gfc_free_expr (inquire->sequential);
4477	gfc_free_expr (inquire->direct);
4478	gfc_free_expr (inquire->form);
4479	gfc_free_expr (inquire->formatted);
4480	gfc_free_expr (inquire->unformatted);
4481	gfc_free_expr (inquire->recl);
4482	gfc_free_expr (inquire->nextrec);
4483	gfc_free_expr (inquire->blank);
4484	gfc_free_expr (inquire->position);
4485	gfc_free_expr (inquire->action);
4486	gfc_free_expr (inquire->read);
4487	gfc_free_expr (inquire->write);
4488	gfc_free_expr (inquire->readwrite);
4489	gfc_free_expr (inquire->delim);
4490	gfc_free_expr (inquire->encoding);
4491	gfc_free_expr (inquire->pad);
4492	gfc_free_expr (inquire->iolength);
4493	gfc_free_expr (inquire->convert);
4494	gfc_free_expr (inquire->strm_pos);
4495	gfc_free_expr (inquire->asynchronous);
4496	gfc_free_expr (inquire->decimal);
4497	gfc_free_expr (inquire->pending);
4498	gfc_free_expr (inquire->id);
4499	gfc_free_expr (inquire->sign);
4500	gfc_free_expr (inquire->size);
4501	gfc_free_expr (inquire->round);
4502	gfc_free_expr (inquire->share);
4503	gfc_free_expr (inquire->cc);
4504	free (ptr: inquire);
4505	}
4506
4507
4508	/* Match an element of an INQUIRE statement. */
4509
4510	#define RETM if (m != MATCH_NO) return m;
4511
4512	static match
4513	match_inquire_element (gfc_inquire *inquire)
4514	{
4515	match m;
4516
4517	m = match_etag (tag: &tag_unit, v: &inquire->unit);
4518	RETM m = match_etag (tag: &tag_file, v: &inquire->file);
4519	RETM m = match_ltag (tag: &tag_err, label: &inquire->err);
4520	RETM m = match_etag (tag: &tag_iomsg, v: &inquire->iomsg);
4521	RETM m = match_out_tag (tag: &tag_iostat, result: &inquire->iostat);
4522	RETM m = match_vtag (tag: &tag_exist, v: &inquire->exist);
4523	RETM m = match_vtag (tag: &tag_opened, v: &inquire->opened);
4524	RETM m = match_vtag (tag: &tag_named, v: &inquire->named);
4525	RETM m = match_vtag (tag: &tag_name, v: &inquire->name);
4526	RETM m = match_out_tag (tag: &tag_number, result: &inquire->number);
4527	RETM m = match_vtag (tag: &tag_s_access, v: &inquire->access);
4528	RETM m = match_vtag (tag: &tag_sequential, v: &inquire->sequential);
4529	RETM m = match_vtag (tag: &tag_direct, v: &inquire->direct);
4530	RETM m = match_vtag (tag: &tag_s_form, v: &inquire->form);
4531	RETM m = match_vtag (tag: &tag_formatted, v: &inquire->formatted);
4532	RETM m = match_vtag (tag: &tag_unformatted, v: &inquire->unformatted);
4533	RETM m = match_out_tag (tag: &tag_s_recl, result: &inquire->recl);
4534	RETM m = match_out_tag (tag: &tag_nextrec, result: &inquire->nextrec);
4535	RETM m = match_vtag (tag: &tag_s_blank, v: &inquire->blank);
4536	RETM m = match_vtag (tag: &tag_s_position, v: &inquire->position);
4537	RETM m = match_vtag (tag: &tag_s_action, v: &inquire->action);
4538	RETM m = match_vtag (tag: &tag_read, v: &inquire->read);
4539	RETM m = match_vtag (tag: &tag_write, v: &inquire->write);
4540	RETM m = match_vtag (tag: &tag_readwrite, v: &inquire->readwrite);
4541	RETM m = match_vtag (tag: &tag_s_async, v: &inquire->asynchronous);
4542	RETM m = match_vtag (tag: &tag_s_delim, v: &inquire->delim);
4543	RETM m = match_vtag (tag: &tag_s_decimal, v: &inquire->decimal);
4544	RETM m = match_out_tag (tag: &tag_size, result: &inquire->size);
4545	RETM m = match_vtag (tag: &tag_s_encoding, v: &inquire->encoding);
4546	RETM m = match_vtag (tag: &tag_s_round, v: &inquire->round);
4547	RETM m = match_vtag (tag: &tag_s_sign, v: &inquire->sign);
4548	RETM m = match_vtag (tag: &tag_s_pad, v: &inquire->pad);
4549	RETM m = match_out_tag (tag: &tag_iolength, result: &inquire->iolength);
4550	RETM m = match_vtag (tag: &tag_convert, v: &inquire->convert);
4551	RETM m = match_out_tag (tag: &tag_strm_out, result: &inquire->strm_pos);
4552	RETM m = match_vtag (tag: &tag_pending, v: &inquire->pending);
4553	RETM m = match_vtag (tag: &tag_id, v: &inquire->id);
4554	RETM m = match_vtag (tag: &tag_s_iqstream, v: &inquire->iqstream);
4555	RETM m = match_dec_vtag (tag: &tag_v_share, e: &inquire->share);
4556	RETM m = match_dec_vtag (tag: &tag_v_cc, e: &inquire->cc);
4557	RETM return MATCH_NO;
4558	}
4559
4560	#undef RETM
4561
4562
4563	match
4564	gfc_match_inquire (void)
4565	{
4566	gfc_inquire *inquire;
4567	gfc_code *code;
4568	match m;
4569	locus loc;
4570
4571	m = gfc_match_char ('(');
4572	if (m == MATCH_NO)
4573	return m;
4574
4575	inquire = XCNEW (gfc_inquire);
4576
4577	loc = gfc_current_locus;
4578
4579	m = match_inquire_element (inquire);
4580	if (m == MATCH_ERROR)
4581	goto cleanup;
4582	if (m == MATCH_NO)
4583	{
4584	m = gfc_match_expr (&inquire->unit);
4585	if (m == MATCH_ERROR)
4586	goto cleanup;
4587	if (m == MATCH_NO)
4588	goto syntax;
4589	}
4590
4591	/* See if we have the IOLENGTH form of the inquire statement. */
4592	if (inquire->iolength != NULL)
4593	{
4594	if (gfc_match_char (')') != MATCH_YES)
4595	goto syntax;
4596
4597	m = match_io_list (k: M_INQUIRE, head_p: &code);
4598	if (m == MATCH_ERROR)
4599	goto cleanup;
4600	if (m == MATCH_NO)
4601	goto syntax;
4602
4603	for (gfc_code *c = code; c; c = c->next)
4604	if (c->expr1 && c->expr1->expr_type == EXPR_FUNCTION
4605	&& c->expr1->symtree && c->expr1->symtree->n.sym->attr.function
4606	&& !c->expr1->symtree->n.sym->attr.external
4607	&& strcmp (s1: c->expr1->symtree->name, s2: "null") == 0)
4608	{
4609	gfc_error ("NULL() near %L cannot appear in INQUIRE statement",
4610	&c->expr1->where);
4611	goto cleanup;
4612	}
4613
4614	new_st.op = EXEC_IOLENGTH;
4615	new_st.expr1 = inquire->iolength;
4616	new_st.ext.inquire = inquire;
4617
4618	if (gfc_pure (NULL))
4619	{
4620	gfc_free_statements (code);
4621	gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4622	return MATCH_ERROR;
4623	}
4624
4625	gfc_unset_implicit_pure (NULL);
4626
4627	new_st.block = gfc_get_code (EXEC_IOLENGTH);
4628	terminate_io (io_code: code);
4629	new_st.block->next = code;
4630	return MATCH_YES;
4631	}
4632
4633	/* At this point, we have the non-IOLENGTH inquire statement. */
4634	for (;;)
4635	{
4636	if (gfc_match_char (')') == MATCH_YES)
4637	break;
4638	if (gfc_match_char (',') != MATCH_YES)
4639	goto syntax;
4640
4641	m = match_inquire_element (inquire);
4642	if (m == MATCH_ERROR)
4643	goto cleanup;
4644	if (m == MATCH_NO)
4645	goto syntax;
4646
4647	if (inquire->iolength != NULL)
4648	{
4649	gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
4650	goto cleanup;
4651	}
4652	}
4653
4654	if (gfc_match_eos () != MATCH_YES)
4655	goto syntax;
4656
4657	if (inquire->unit != NULL && inquire->file != NULL)
4658	{
4659	gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
4660	"UNIT specifiers", &loc);
4661	goto cleanup;
4662	}
4663
4664	if (inquire->unit == NULL && inquire->file == NULL)
4665	{
4666	gfc_error ("INQUIRE statement at %L requires either FILE or "
4667	"UNIT specifier", &loc);
4668	goto cleanup;
4669	}
4670
4671	if (inquire->unit != NULL && inquire->unit->expr_type == EXPR_CONSTANT
4672	&& inquire->unit->ts.type == BT_INTEGER
4673	&& ((mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT4)
4674	|| (mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT)))
4675	{
4676	gfc_error ("UNIT number in INQUIRE statement at %L cannot "
4677	"be %d", &loc, (int) mpz_get_si (inquire->unit->value.integer));
4678	goto cleanup;
4679	}
4680
4681	if (gfc_pure (NULL))
4682	{
4683	gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
4684	goto cleanup;
4685	}
4686
4687	gfc_unset_implicit_pure (NULL);
4688
4689	if (inquire->id != NULL && inquire->pending == NULL)
4690	{
4691	gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
4692	"the ID= specifier", &loc);
4693	goto cleanup;
4694	}
4695
4696	new_st.op = EXEC_INQUIRE;
4697	new_st.ext.inquire = inquire;
4698	return MATCH_YES;
4699
4700	syntax:
4701	gfc_syntax_error (ST_INQUIRE);
4702
4703	cleanup:
4704	gfc_free_inquire (inquire);
4705	return MATCH_ERROR;
4706	}
4707
4708
4709	/* Resolve everything in a gfc_inquire structure. */
4710
4711	bool
4712	gfc_resolve_inquire (gfc_inquire *inquire)
4713	{
4714	RESOLVE_TAG (&tag_unit, inquire->unit);
4715	RESOLVE_TAG (&tag_file, inquire->file);
4716	RESOLVE_TAG (&tag_id, inquire->id);
4717
4718	/* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
4719	contexts. Thus, use an extended RESOLVE_TAG macro for that. */
4720	#define INQUIRE_RESOLVE_TAG(tag, expr) \
4721	RESOLVE_TAG (tag, expr); \
4722	if (expr) \
4723	{ \
4724	char context[64]; \
4725	sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
4726	if (gfc_check_vardef_context ((expr), false, false, false, \
4727	context) == false) \
4728	return false; \
4729	}
4730	INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
4731	INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat);
4732	INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist);
4733	INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened);
4734	INQUIRE_RESOLVE_TAG (&tag_number, inquire->number);
4735	INQUIRE_RESOLVE_TAG (&tag_named, inquire->named);
4736	INQUIRE_RESOLVE_TAG (&tag_name, inquire->name);
4737	INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access);
4738	INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential);
4739	INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct);
4740	INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form);
4741	INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted);
4742	INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
4743	INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl);
4744	INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
4745	INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank);
4746	INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position);
4747	INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action);
4748	INQUIRE_RESOLVE_TAG (&tag_read, inquire->read);
4749	INQUIRE_RESOLVE_TAG (&tag_write, inquire->write);
4750	INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
4751	INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim);
4752	INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad);
4753	INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
4754	INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4755	INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength);
4756	INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert);
4757	INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
4758	INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
4759	INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign);
4760	INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
4761	INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending);
4762	INQUIRE_RESOLVE_TAG (&tag_size, inquire->size);
4763	INQUIRE_RESOLVE_TAG (&tag_s_decimal, inquire->decimal);
4764	INQUIRE_RESOLVE_TAG (&tag_s_iqstream, inquire->iqstream);
4765	INQUIRE_RESOLVE_TAG (&tag_v_share, inquire->share);
4766	INQUIRE_RESOLVE_TAG (&tag_v_cc, inquire->cc);
4767	#undef INQUIRE_RESOLVE_TAG
4768
4769	if (!gfc_reference_st_label (inquire->err, ST_LABEL_TARGET))
4770	return false;
4771
4772	return true;
4773	}
4774
4775
4776	void
4777	gfc_free_wait (gfc_wait *wait)
4778	{
4779	if (wait == NULL)
4780	return;
4781
4782	gfc_free_expr (wait->unit);
4783	gfc_free_expr (wait->iostat);
4784	gfc_free_expr (wait->iomsg);
4785	gfc_free_expr (wait->id);
4786	free (ptr: wait);
4787	}
4788
4789
4790	bool
4791	gfc_resolve_wait (gfc_wait *wait)
4792	{
4793	RESOLVE_TAG (&tag_unit, wait->unit);
4794	RESOLVE_TAG (&tag_iomsg, wait->iomsg);
4795	RESOLVE_TAG (&tag_iostat, wait->iostat);
4796	RESOLVE_TAG (&tag_id, wait->id);
4797
4798	if (!gfc_reference_st_label (wait->err, ST_LABEL_TARGET))
4799	return false;
4800
4801	if (!gfc_reference_st_label (wait->end, ST_LABEL_TARGET))
4802	return false;
4803
4804	return true;
4805	}
4806
4807	/* Match an element of a WAIT statement. */
4808
4809	#define RETM if (m != MATCH_NO) return m;
4810
4811	static match
4812	match_wait_element (gfc_wait *wait)
4813	{
4814	match m;
4815
4816	m = match_etag (tag: &tag_unit, v: &wait->unit);
4817	RETM m = match_ltag (tag: &tag_err, label: &wait->err);
4818	RETM m = match_ltag (tag: &tag_end, label: &wait->end);
4819	RETM m = match_ltag (tag: &tag_eor, label: &wait->eor);
4820	RETM m = match_etag (tag: &tag_iomsg, v: &wait->iomsg);
4821	RETM m = match_out_tag (tag: &tag_iostat, result: &wait->iostat);
4822	RETM m = match_etag (tag: &tag_id, v: &wait->id);
4823	RETM return MATCH_NO;
4824	}
4825
4826	#undef RETM
4827
4828
4829	match
4830	gfc_match_wait (void)
4831	{
4832	gfc_wait *wait;
4833	match m;
4834
4835	m = gfc_match_char ('(');
4836	if (m == MATCH_NO)
4837	return m;
4838
4839	wait = XCNEW (gfc_wait);
4840
4841	m = match_wait_element (wait);
4842	if (m == MATCH_ERROR)
4843	goto cleanup;
4844	if (m == MATCH_NO)
4845	{
4846	m = gfc_match_expr (&wait->unit);
4847	if (m == MATCH_ERROR)
4848	goto cleanup;
4849	if (m == MATCH_NO)
4850	goto syntax;
4851	}
4852
4853	for (;;)
4854	{
4855	if (gfc_match_char (')') == MATCH_YES)
4856	break;
4857	if (gfc_match_char (',') != MATCH_YES)
4858	goto syntax;
4859
4860	m = match_wait_element (wait);
4861	if (m == MATCH_ERROR)
4862	goto cleanup;
4863	if (m == MATCH_NO)
4864	goto syntax;
4865	}
4866
4867	if (!gfc_notify_std (GFC_STD_F2003, "WAIT at %C "
4868	"not allowed in Fortran 95"))
4869	goto cleanup;
4870
4871	if (gfc_pure (NULL))
4872	{
4873	gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4874	goto cleanup;
4875	}
4876
4877	gfc_unset_implicit_pure (NULL);
4878
4879	new_st.op = EXEC_WAIT;
4880	new_st.ext.wait = wait;
4881
4882	return MATCH_YES;
4883
4884	syntax:
4885	gfc_syntax_error (ST_WAIT);
4886
4887	cleanup:
4888	gfc_free_wait (wait);
4889	return MATCH_ERROR;
4890	}
4891