1	/* Matching subroutines in all sizes, shapes and colors.
2	Copyright (C) 2000-2026 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
29	int gfc_matching_ptr_assignment = 0;
30	int gfc_matching_procptr_assignment = 0;
31	bool gfc_matching_prefix = false;
32
33	/* Stack of SELECT TYPE statements. */
34	gfc_select_type_stack *select_type_stack = NULL;
35
36	/* List of type parameter expressions. */
37	gfc_actual_arglist *type_param_spec_list;
38
39	/* For debugging and diagnostic purposes. Return the textual representation
40	of the intrinsic operator OP. */
41	const char *
42	gfc_op2string (gfc_intrinsic_op op)
43	{
44	switch (op)
45	{
46	case INTRINSIC_UPLUS:
47	case INTRINSIC_PLUS:
48	return "+";
49
50	case INTRINSIC_UMINUS:
51	case INTRINSIC_MINUS:
52	return "-";
53
54	case INTRINSIC_POWER:
55	return "**";
56	case INTRINSIC_CONCAT:
57	return "//";
58	case INTRINSIC_TIMES:
59	return "*";
60	case INTRINSIC_DIVIDE:
61	return "/";
62
63	case INTRINSIC_AND:
64	return ".and.";
65	case INTRINSIC_OR:
66	return ".or.";
67	case INTRINSIC_EQV:
68	return ".eqv.";
69	case INTRINSIC_NEQV:
70	return ".neqv.";
71
72	case INTRINSIC_EQ_OS:
73	return ".eq.";
74	case INTRINSIC_EQ:
75	return "==";
76	case INTRINSIC_NE_OS:
77	return ".ne.";
78	case INTRINSIC_NE:
79	return "/=";
80	case INTRINSIC_GE_OS:
81	return ".ge.";
82	case INTRINSIC_GE:
83	return ">=";
84	case INTRINSIC_LE_OS:
85	return ".le.";
86	case INTRINSIC_LE:
87	return "<=";
88	case INTRINSIC_LT_OS:
89	return ".lt.";
90	case INTRINSIC_LT:
91	return "<";
92	case INTRINSIC_GT_OS:
93	return ".gt.";
94	case INTRINSIC_GT:
95	return ">";
96	case INTRINSIC_NOT:
97	return ".not.";
98
99	case INTRINSIC_ASSIGN:
100	return "=";
101
102	case INTRINSIC_PARENTHESES:
103	return "parens";
104
105	case INTRINSIC_NONE:
106	return "none";
107
108	/* DTIO */
109	case INTRINSIC_FORMATTED:
110	return "formatted";
111	case INTRINSIC_UNFORMATTED:
112	return "unformatted";
113
114	default:
115	break;
116	}
117
118	gfc_internal_error ("gfc_op2string(): Bad code");
119	/* Not reached. */
120	}
121
122
123	/******************** Generic matching subroutines ************************/
124
125	/* Matches a member separator. With standard FORTRAN this is '%', but with
126	DEC structures we must carefully match dot ('.').
127	Because operators are spelled ".op.", a dotted string such as "x.y.z..."
128	can be either a component reference chain or a combination of binary
129	operations.
130	There is no real way to win because the string may be grammatically
131	ambiguous. The following rules help avoid ambiguities - they match
132	some behavior of other (older) compilers. If the rules here are changed
133	the test cases should be updated. If the user has problems with these rules
134	they probably deserve the consequences. Consider "x.y.z":
135	(1) If any user defined operator ".y." exists, this is always y(x,z)
136	(even if ".y." is the wrong type and/or x has a member y).
137	(2) Otherwise if x has a member y, and y is itself a derived type,
138	this is (x->y)->z, even if an intrinsic operator exists which
139	can handle (x,z).
140	(3) If x has no member y or (x->y) is not a derived type but ".y."
141	is an intrinsic operator (such as ".eq."), this is y(x,z).
142	(4) Lastly if there is no operator ".y." and x has no member "y", it is an
143	error.
144	It is worth noting that the logic here does not support mixed use of member
145	accessors within a single string. That is, even if x has component y and y
146	has component z, the following are all syntax errors:
147	"x%y.z" "x.y%z" "(x.y).z" "(x%y)%z"
148	*/
149
150	match
151	gfc_match_member_sep(gfc_symbol *sym)
152	{
153	char name[GFC_MAX_SYMBOL_LEN + 1];
154	locus dot_loc, start_loc;
155	gfc_intrinsic_op iop;
156	match m;
157	gfc_symbol *tsym;
158	gfc_component *c = NULL;
159
160	/* What a relief: '%' is an unambiguous member separator. */
161	if (gfc_match_char ('%') == MATCH_YES)
162	return MATCH_YES;
163
164	/* Beware ye who enter here. */
165	if (!flag_dec_structure || !sym)
166	return MATCH_NO;
167
168	tsym = NULL;
169
170	/* We may be given either a derived type variable or the derived type
171	declaration itself (which actually contains the components);
172	we need the latter to search for components. */
173	if (gfc_fl_struct (sym->attr.flavor))
174	tsym = sym;
175	else if (gfc_bt_struct (sym->ts.type))
176	tsym = sym->ts.u.derived;
177
178	iop = INTRINSIC_NONE;
179	name[0] = '\0';
180	m = MATCH_NO;
181
182	/* If we have to reject come back here later. */
183	start_loc = gfc_current_locus;
184
185	/* Look for a component access next. */
186	if (gfc_match_char ('.') != MATCH_YES)
187	return MATCH_NO;
188
189	/* If we accept, come back here. */
190	dot_loc = gfc_current_locus;
191
192	/* Try to match a symbol name following the dot. */
193	if (gfc_match_name (name) != MATCH_YES)
194	{
195	gfc_error ("Expected structure component or operator name "
196	"after %<.%> at %C");
197	goto error;
198	}
199
200	/* If no dot follows we have "x.y" which should be a component access. */
201	if (gfc_match_char ('.') != MATCH_YES)
202	goto yes;
203
204	/* Now we have a string "x.y.z" which could be a nested member access
205	(x->y)->z or a binary operation y on x and z. */
206
207	/* First use any user-defined operators ".y." */
208	if (gfc_find_uop (name, sym->ns) != NULL)
209	goto no;
210
211	/* Match accesses to existing derived-type components for
212	derived-type vars: "x.y.z" = (x->y)->z */
213	c = gfc_find_component(tsym, name, false, true, NULL);
214	if (c && (gfc_bt_struct (c->ts.type) || c->ts.type == BT_CLASS))
215	goto yes;
216
217	/* If y is not a component or has no members, try intrinsic operators. */
218	gfc_current_locus = start_loc;
219	if (gfc_match_intrinsic_op (&iop) != MATCH_YES)
220	{
221	/* If ".y." is not an intrinsic operator but y was a valid non-
222	structure component, match and leave the trailing dot to be
223	dealt with later. */
224	if (c)
225	goto yes;
226
227	gfc_error ("%qs is neither a defined operator nor a "
228	"structure component in dotted string at %C", name);
229	goto error;
230	}
231
232	/* .y. is an intrinsic operator, overriding any possible member access. */
233	goto no;
234
235	/* Return keeping the current locus consistent with the match result. */
236	error:
237	m = MATCH_ERROR;
238	no:
239	gfc_current_locus = start_loc;
240	return m;
241	yes:
242	gfc_current_locus = dot_loc;
243	return MATCH_YES;
244	}
245
246
247	/* This function scans the current statement counting the opened and closed
248	parenthesis to make sure they are balanced. */
249
250	match
251	gfc_match_parens (void)
252	{
253	locus old_loc, where;
254	int count;
255	gfc_instring instring;
256	gfc_char_t c, quote;
257
258	old_loc = gfc_current_locus;
259	count = 0;
260	instring = NONSTRING;
261	quote = ' ';
262
263	for (;;)
264	{
265	if (count > 0)
266	where = gfc_current_locus;
267	c = gfc_next_char_literal (instring);
268	if (c == '\n')
269	break;
270	if (quote == ' ' && ((c == '\'') || (c == '"')))
271	{
272	quote = c;
273	instring = INSTRING_WARN;
274	continue;
275	}
276	if (quote != ' ' && c == quote)
277	{
278	quote = ' ';
279	instring = NONSTRING;
280	continue;
281	}
282
283	if (c == '(' && quote == ' ')
284	{
285	count++;
286	}
287	if (c == ')' && quote == ' ')
288	{
289	count--;
290	where = gfc_current_locus;
291	}
292	}
293
294	gfc_current_locus = old_loc;
295
296	if (count != 0)
297	{
298	gfc_error ("Missing %qs in statement at or before %L",
299	count > 0? ")":"(", &where);
300	return MATCH_ERROR;
301	}
302
303	return MATCH_YES;
304	}
305
306
307	/* See if the next character is a special character that has
308	escaped by a \ via the -fbackslash option. */
309
310	match
311	gfc_match_special_char (gfc_char_t *res)
312	{
313	int len, i;
314	gfc_char_t c, n;
315	match m;
316
317	m = MATCH_YES;
318
319	switch ((c = gfc_next_char_literal (INSTRING_WARN)))
320	{
321	case 'a':
322	*res = '\a';
323	break;
324	case 'b':
325	*res = '\b';
326	break;
327	case 't':
328	*res = '\t';
329	break;
330	case 'f':
331	*res = '\f';
332	break;
333	case 'n':
334	*res = '\n';
335	break;
336	case 'r':
337	*res = '\r';
338	break;
339	case 'v':
340	*res = '\v';
341	break;
342	case '\\':
343	*res = '\\';
344	break;
345	case '0':
346	*res = '\0';
347	break;
348
349	case 'x':
350	case 'u':
351	case 'U':
352	/* Hexadecimal form of wide characters. */
353	len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8));
354	n = 0;
355	for (i = 0; i < len; i++)
356	{
357	char buf[2] = { '\0', '\0' };
358
359	c = gfc_next_char_literal (INSTRING_WARN);
360	if (!gfc_wide_fits_in_byte (c)
361	|| !gfc_check_digit ((unsigned char) c, 16))
362	return MATCH_NO;
363
364	buf[0] = (unsigned char) c;
365	n = n << 4;
366	n += strtol (nptr: buf, NULL, base: 16);
367	}
368	*res = n;
369	break;
370
371	default:
372	/* Unknown backslash codes are simply not expanded. */
373	m = MATCH_NO;
374	break;
375	}
376
377	return m;
378	}
379
380
381	/* In free form, match at least one space. Always matches in fixed
382	form. */
383
384	match
385	gfc_match_space (void)
386	{
387	locus old_loc;
388	char c;
389
390	if (gfc_current_form == FORM_FIXED)
391	return MATCH_YES;
392
393	old_loc = gfc_current_locus;
394
395	c = gfc_next_ascii_char ();
396	if (!gfc_is_whitespace (c))
397	{
398	gfc_current_locus = old_loc;
399	return MATCH_NO;
400	}
401
402	gfc_gobble_whitespace ();
403
404	return MATCH_YES;
405	}
406
407
408	/* Match an end of statement. End of statement is optional
409	whitespace, followed by a ';' or '\n' or comment '!'. If a
410	semicolon is found, we continue to eat whitespace and semicolons. */
411
412	match
413	gfc_match_eos (void)
414	{
415	locus old_loc;
416	int flag;
417	char c;
418
419	flag = 0;
420
421	for (;;)
422	{
423	old_loc = gfc_current_locus;
424	gfc_gobble_whitespace ();
425
426	c = gfc_next_ascii_char ();
427	switch (c)
428	{
429	case '!':
430	do
431	{
432	c = gfc_next_ascii_char ();
433	}
434	while (c != '\n');
435
436	/* Fall through. */
437
438	case '\n':
439	return MATCH_YES;
440
441	case ';':
442	flag = 1;
443	continue;
444	}
445
446	break;
447	}
448
449	gfc_current_locus = old_loc;
450	return (flag) ? MATCH_YES : MATCH_NO;
451	}
452
453
454	/* Match a literal integer on the input, setting the value on
455	MATCH_YES. Literal ints occur in kind-parameters as well as
456	old-style character length specifications. If cnt is non-NULL it
457	will be set to the number of digits.
458	When gobble_ws is false, do not skip over leading blanks. */
459
460	match
461	gfc_match_small_literal_int (int *value, int *cnt, bool gobble_ws)
462	{
463	locus old_loc;
464	char c;
465	int i, j;
466
467	old_loc = gfc_current_locus;
468
469	*value = -1;
470	if (gobble_ws)
471	gfc_gobble_whitespace ();
472	c = gfc_next_ascii_char ();
473	if (cnt)
474	*cnt = 0;
475
476	if (!ISDIGIT (c))
477	{
478	gfc_current_locus = old_loc;
479	return MATCH_NO;
480	}
481
482	i = c - '0';
483	j = 1;
484
485	for (;;)
486	{
487	old_loc = gfc_current_locus;
488	c = gfc_next_ascii_char ();
489
490	if (!ISDIGIT (c))
491	break;
492
493	i = 10 * i + c - '0';
494	j++;
495
496	if (i > 99999999)
497	{
498	gfc_error ("Integer too large at %C");
499	return MATCH_ERROR;
500	}
501	}
502
503	gfc_current_locus = old_loc;
504
505	*value = i;
506	if (cnt)
507	*cnt = j;
508	return MATCH_YES;
509	}
510
511
512	/* Match a small, constant integer expression, like in a kind
513	statement. On MATCH_YES, 'value' is set. */
514
515	match
516	gfc_match_small_int (int *value)
517	{
518	gfc_expr *expr;
519	match m;
520	int i;
521
522	m = gfc_match_expr (&expr);
523	if (m != MATCH_YES)
524	return m;
525
526	if (gfc_extract_int (expr, &i, 1))
527	m = MATCH_ERROR;
528	gfc_free_expr (expr);
529
530	*value = i;
531	return m;
532	}
533
534
535	/* Matches a statement label. Uses gfc_match_small_literal_int() to
536	do most of the work. */
537
538	match
539	gfc_match_st_label (gfc_st_label **label)
540	{
541	locus old_loc;
542	match m;
543	int i, cnt;
544
545	old_loc = gfc_current_locus;
546
547	m = gfc_match_small_literal_int (value: &i, cnt: &cnt);
548	if (m != MATCH_YES)
549	return m;
550
551	if (cnt > 5)
552	{
553	gfc_error ("Too many digits in statement label at %C");
554	goto cleanup;
555	}
556
557	if (i == 0)
558	{
559	gfc_error ("Statement label at %C is zero");
560	goto cleanup;
561	}
562
563	*label = gfc_get_st_label (i);
564	return MATCH_YES;
565
566	cleanup:
567
568	gfc_current_locus = old_loc;
569	return MATCH_ERROR;
570	}
571
572
573	/* Match and validate a label associated with a named IF, DO or SELECT
574	statement. If the symbol does not have the label attribute, we add
575	it. We also make sure the symbol does not refer to another
576	(active) block. A matched label is pointed to by gfc_new_block. */
577
578	static match
579	gfc_match_label (void)
580	{
581	char name[GFC_MAX_SYMBOL_LEN + 1];
582	match m;
583
584	gfc_new_block = NULL;
585
586	m = gfc_match (" %n :", name);
587	if (m != MATCH_YES)
588	return m;
589
590	if (gfc_get_symbol (name, NULL, &gfc_new_block))
591	{
592	gfc_error ("Label name %qs at %C is ambiguous", name);
593	return MATCH_ERROR;
594	}
595
596	if (gfc_new_block->attr.flavor == FL_LABEL)
597	{
598	gfc_error ("Duplicate construct label %qs at %C", name);
599	return MATCH_ERROR;
600	}
601
602	if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
603	gfc_new_block->name, NULL))
604	return MATCH_ERROR;
605
606	return MATCH_YES;
607	}
608
609
610	/* See if the current input looks like a name of some sort. Modifies
611	the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
612	Note that options.cc restricts max_identifier_length to not more
613	than GFC_MAX_SYMBOL_LEN.
614	When gobble_ws is false, do not skip over leading blanks. */
615
616	match
617	gfc_match_name (char *buffer, bool gobble_ws)
618	{
619	locus old_loc;
620	int i;
621	char c;
622
623	old_loc = gfc_current_locus;
624	if (gobble_ws)
625	gfc_gobble_whitespace ();
626
627	c = gfc_next_ascii_char ();
628	if (!(ISALPHA (c) || (c == '_' && flag_allow_leading_underscore)))
629	{
630	/* Special cases for unary minus and plus, which allows for a sensible
631	error message for code of the form 'c = exp(-a*b) )' where an
632	extra ')' appears at the end of statement. */
633	if (!gfc_error_flag_test () && c != '(' && c != '-' && c != '+')
634	gfc_error ("Invalid character in name at %C");
635	gfc_current_locus = old_loc;
636	return MATCH_NO;
637	}
638
639	i = 0;
640
641	do
642	{
643	buffer[i++] = c;
644
645	if (i > gfc_option.max_identifier_length)
646	{
647	gfc_error ("Name at %C is too long");
648	return MATCH_ERROR;
649	}
650
651	old_loc = gfc_current_locus;
652	c = gfc_next_ascii_char ();
653	}
654	while (ISALNUM (c) || c == '_' || (flag_dollar_ok && c == '$'));
655
656	if (c == '$' && !flag_dollar_ok)
657	{
658	gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to "
659	"allow it as an extension", &old_loc);
660	return MATCH_ERROR;
661	}
662
663	buffer[i] = '\0';
664	gfc_current_locus = old_loc;
665
666	return MATCH_YES;
667	}
668
669
670	/* Match a symbol on the input. Modifies the pointer to the symbol
671	pointer if successful. */
672
673	match
674	gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
675	{
676	char buffer[GFC_MAX_SYMBOL_LEN + 1];
677	match m;
678	int ret;
679
680	locus loc = gfc_current_locus;
681	m = gfc_match_name (buffer);
682	if (m != MATCH_YES)
683	return m;
684	loc = gfc_get_location_range (NULL, 0, &loc, 1, &gfc_current_locus);
685	if (host_assoc)
686	{
687	ret = gfc_get_ha_sym_tree (buffer, matched_symbol, &loc);
688	return ret ? MATCH_ERROR : MATCH_YES;
689	}
690
691	ret = gfc_get_sym_tree (buffer, NULL, matched_symbol, false, &loc);
692	if (ret)
693	return MATCH_ERROR;
694
695	return MATCH_YES;
696	}
697
698
699	match
700	gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
701	{
702	gfc_symtree *st;
703	match m;
704
705	m = gfc_match_sym_tree (matched_symbol: &st, host_assoc);
706
707	if (m == MATCH_YES)
708	{
709	if (st)
710	*matched_symbol = st->n.sym;
711	else
712	*matched_symbol = NULL;
713	}
714	else
715	*matched_symbol = NULL;
716	return m;
717	}
718
719
720	/* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
721	we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
722	in matchexp.cc. */
723
724	match
725	gfc_match_intrinsic_op (gfc_intrinsic_op *result)
726	{
727	locus orig_loc = gfc_current_locus;
728	char ch;
729
730	gfc_gobble_whitespace ();
731	ch = gfc_next_ascii_char ();
732	switch (ch)
733	{
734	case '+':
735	/* Matched "+". */
736	*result = INTRINSIC_PLUS;
737	return MATCH_YES;
738
739	case '-':
740	/* Matched "-". */
741	*result = INTRINSIC_MINUS;
742	return MATCH_YES;
743
744	case '=':
745	if (gfc_next_ascii_char () == '=')
746	{
747	/* Matched "==". */
748	*result = INTRINSIC_EQ;
749	return MATCH_YES;
750	}
751	break;
752
753	case '<':
754	if (gfc_peek_ascii_char () == '=')
755	{
756	/* Matched "<=". */
757	gfc_next_ascii_char ();
758	*result = INTRINSIC_LE;
759	return MATCH_YES;
760	}
761	/* Matched "<". */
762	*result = INTRINSIC_LT;
763	return MATCH_YES;
764
765	case '>':
766	if (gfc_peek_ascii_char () == '=')
767	{
768	/* Matched ">=". */
769	gfc_next_ascii_char ();
770	*result = INTRINSIC_GE;
771	return MATCH_YES;
772	}
773	/* Matched ">". */
774	*result = INTRINSIC_GT;
775	return MATCH_YES;
776
777	case '*':
778	if (gfc_peek_ascii_char () == '*')
779	{
780	/* Matched "**". */
781	gfc_next_ascii_char ();
782	*result = INTRINSIC_POWER;
783	return MATCH_YES;
784	}
785	/* Matched "*". */
786	*result = INTRINSIC_TIMES;
787	return MATCH_YES;
788
789	case '/':
790	ch = gfc_peek_ascii_char ();
791	if (ch == '=')
792	{
793	/* Matched "/=". */
794	gfc_next_ascii_char ();
795	*result = INTRINSIC_NE;
796	return MATCH_YES;
797	}
798	else if (ch == '/')
799	{
800	/* Matched "//". */
801	gfc_next_ascii_char ();
802	*result = INTRINSIC_CONCAT;
803	return MATCH_YES;
804	}
805	/* Matched "/". */
806	*result = INTRINSIC_DIVIDE;
807	return MATCH_YES;
808
809	case '.':
810	ch = gfc_next_ascii_char ();
811	switch (ch)
812	{
813	case 'a':
814	if (gfc_next_ascii_char () == 'n'
815	&& gfc_next_ascii_char () == 'd'
816	&& gfc_next_ascii_char () == '.')
817	{
818	/* Matched ".and.". */
819	*result = INTRINSIC_AND;
820	return MATCH_YES;
821	}
822	break;
823
824	case 'e':
825	if (gfc_next_ascii_char () == 'q')
826	{
827	ch = gfc_next_ascii_char ();
828	if (ch == '.')
829	{
830	/* Matched ".eq.". */
831	*result = INTRINSIC_EQ_OS;
832	return MATCH_YES;
833	}
834	else if (ch == 'v')
835	{
836	if (gfc_next_ascii_char () == '.')
837	{
838	/* Matched ".eqv.". */
839	*result = INTRINSIC_EQV;
840	return MATCH_YES;
841	}
842	}
843	}
844	break;
845
846	case 'g':
847	ch = gfc_next_ascii_char ();
848	if (ch == 'e')
849	{
850	if (gfc_next_ascii_char () == '.')
851	{
852	/* Matched ".ge.". */
853	*result = INTRINSIC_GE_OS;
854	return MATCH_YES;
855	}
856	}
857	else if (ch == 't')
858	{
859	if (gfc_next_ascii_char () == '.')
860	{
861	/* Matched ".gt.". */
862	*result = INTRINSIC_GT_OS;
863	return MATCH_YES;
864	}
865	}
866	break;
867
868	case 'l':
869	ch = gfc_next_ascii_char ();
870	if (ch == 'e')
871	{
872	if (gfc_next_ascii_char () == '.')
873	{
874	/* Matched ".le.". */
875	*result = INTRINSIC_LE_OS;
876	return MATCH_YES;
877	}
878	}
879	else if (ch == 't')
880	{
881	if (gfc_next_ascii_char () == '.')
882	{
883	/* Matched ".lt.". */
884	*result = INTRINSIC_LT_OS;
885	return MATCH_YES;
886	}
887	}
888	break;
889
890	case 'n':
891	ch = gfc_next_ascii_char ();
892	if (ch == 'e')
893	{
894	ch = gfc_next_ascii_char ();
895	if (ch == '.')
896	{
897	/* Matched ".ne.". */
898	*result = INTRINSIC_NE_OS;
899	return MATCH_YES;
900	}
901	else if (ch == 'q')
902	{
903	if (gfc_next_ascii_char () == 'v'
904	&& gfc_next_ascii_char () == '.')
905	{
906	/* Matched ".neqv.". */
907	*result = INTRINSIC_NEQV;
908	return MATCH_YES;
909	}
910	}
911	}
912	else if (ch == 'o')
913	{
914	if (gfc_next_ascii_char () == 't'
915	&& gfc_next_ascii_char () == '.')
916	{
917	/* Matched ".not.". */
918	*result = INTRINSIC_NOT;
919	return MATCH_YES;
920	}
921	}
922	break;
923
924	case 'o':
925	if (gfc_next_ascii_char () == 'r'
926	&& gfc_next_ascii_char () == '.')
927	{
928	/* Matched ".or.". */
929	*result = INTRINSIC_OR;
930	return MATCH_YES;
931	}
932	break;
933
934	case 'x':
935	if (gfc_next_ascii_char () == 'o'
936	&& gfc_next_ascii_char () == 'r'
937	&& gfc_next_ascii_char () == '.')
938	{
939	if (!gfc_notify_std (GFC_STD_LEGACY, ".XOR. operator at %C"))
940	return MATCH_ERROR;
941	/* Matched ".xor." - equivalent to ".neqv.". */
942	*result = INTRINSIC_NEQV;
943	return MATCH_YES;
944	}
945	break;
946
947	default:
948	break;
949	}
950	break;
951
952	default:
953	break;
954	}
955
956	gfc_current_locus = orig_loc;
957	return MATCH_NO;
958	}
959
960
961	/* Match a loop control phrase:
962
963	<LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
964
965	If the final integer expression is not present, a constant unity
966	expression is returned. We don't return MATCH_ERROR until after
967	the equals sign is seen. */
968
969	match
970	gfc_match_iterator (gfc_iterator *iter, int init_flag)
971	{
972	char name[GFC_MAX_SYMBOL_LEN + 1];
973	gfc_expr *var, *e1, *e2, *e3;
974	locus start;
975	match m;
976
977	e1 = e2 = e3 = NULL;
978
979	/* Match the start of an iterator without affecting the symbol table. */
980
981	start = gfc_current_locus;
982	m = gfc_match (" %n =", name);
983	gfc_current_locus = start;
984
985	if (m != MATCH_YES)
986	return MATCH_NO;
987
988	m = gfc_match_variable (&var, 0);
989	if (m != MATCH_YES)
990	return MATCH_NO;
991
992	if (var->symtree->n.sym->attr.dimension)
993	{
994	gfc_error ("Loop variable at %C cannot be an array");
995	goto cleanup;
996	}
997
998	/* F2008, C617 & C565. */
999	if (var->symtree->n.sym->attr.codimension)
1000	{
1001	gfc_error ("Loop variable at %C cannot be a coarray");
1002	goto cleanup;
1003	}
1004
1005	if (var->ref != NULL)
1006	{
1007	gfc_error ("Loop variable at %C cannot be a sub-component");
1008	goto cleanup;
1009	}
1010
1011	gfc_match_char ('=');
1012
1013	var->symtree->n.sym->attr.implied_index = 1;
1014
1015	m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
1016	if (m == MATCH_NO)
1017	goto syntax;
1018	if (m == MATCH_ERROR)
1019	goto cleanup;
1020
1021	if (gfc_match_char (',') != MATCH_YES)
1022	goto syntax;
1023
1024	m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
1025	if (m == MATCH_NO)
1026	goto syntax;
1027	if (m == MATCH_ERROR)
1028	goto cleanup;
1029
1030	if (gfc_match_char (',') != MATCH_YES)
1031	{
1032	e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
1033	goto done;
1034	}
1035
1036	m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
1037	if (m == MATCH_ERROR)
1038	goto cleanup;
1039	if (m == MATCH_NO)
1040	{
1041	gfc_error ("Expected a step value in iterator at %C");
1042	goto cleanup;
1043	}
1044
1045	done:
1046	iter->var = var;
1047	iter->start = e1;
1048	iter->end = e2;
1049	iter->step = e3;
1050	return MATCH_YES;
1051
1052	syntax:
1053	gfc_error ("Syntax error in iterator at %C");
1054
1055	cleanup:
1056	gfc_free_expr (e1);
1057	gfc_free_expr (e2);
1058	gfc_free_expr (e3);
1059
1060	return MATCH_ERROR;
1061	}
1062
1063
1064	/* Tries to match the next non-whitespace character on the input.
1065	This subroutine does not return MATCH_ERROR.
1066	When gobble_ws is false, do not skip over leading blanks. */
1067
1068	match
1069	gfc_match_char (char c, bool gobble_ws)
1070	{
1071	locus where;
1072
1073	where = gfc_current_locus;
1074	if (gobble_ws)
1075	gfc_gobble_whitespace ();
1076
1077	if (gfc_next_ascii_char () == c)
1078	return MATCH_YES;
1079
1080	gfc_current_locus = where;
1081	return MATCH_NO;
1082	}
1083
1084
1085	/* General purpose matching subroutine. The target string is a
1086	scanf-like format string in which spaces correspond to arbitrary
1087	whitespace (including no whitespace), characters correspond to
1088	themselves. The %-codes are:
1089
1090	%% Literal percent sign
1091	%e Expression, pointer to a pointer is set
1092	%s Symbol, pointer to the symbol is set (host_assoc = 0)
1093	%S Symbol, pointer to the symbol is set (host_assoc = 1)
1094	%n Name, character buffer is set to name
1095	%t Matches end of statement.
1096	%o Matches an intrinsic operator, returned as an INTRINSIC enum.
1097	%l Matches a statement label
1098	%v Matches a variable expression (an lvalue, except function references
1099	having a data pointer result)
1100	% Matches a required space (in free form) and optional spaces. */
1101
1102	match
1103	gfc_match (const char *target, ...)
1104	{
1105	gfc_st_label **label;
1106	int matches, *ip;
1107	locus old_loc;
1108	va_list argp;
1109	char c, *np;
1110	match m, n;
1111	void **vp;
1112	const char *p;
1113
1114	old_loc = gfc_current_locus;
1115	va_start (argp, target);
1116	m = MATCH_NO;
1117	matches = 0;
1118	p = target;
1119
1120	loop:
1121	c = *p++;
1122	switch (c)
1123	{
1124	case ' ':
1125	gfc_gobble_whitespace ();
1126	goto loop;
1127	case '\0':
1128	m = MATCH_YES;
1129	break;
1130
1131	case '%':
1132	c = *p++;
1133	switch (c)
1134	{
1135	case 'e':
1136	vp = va_arg (argp, void **);
1137	n = gfc_match_expr ((gfc_expr **) vp);
1138	if (n != MATCH_YES)
1139	{
1140	m = n;
1141	goto not_yes;
1142	}
1143
1144	matches++;
1145	goto loop;
1146
1147	case 'v':
1148	vp = va_arg (argp, void **);
1149	n = gfc_match_variable ((gfc_expr **) vp, 0);
1150	if (n != MATCH_YES)
1151	{
1152	m = n;
1153	goto not_yes;
1154	}
1155
1156	matches++;
1157	goto loop;
1158
1159	case 's':
1160	case 'S':
1161	vp = va_arg (argp, void **);
1162	n = gfc_match_symbol (matched_symbol: (gfc_symbol **) vp, host_assoc: c == 'S');
1163	if (n != MATCH_YES)
1164	{
1165	m = n;
1166	goto not_yes;
1167	}
1168
1169	matches++;
1170	goto loop;
1171
1172	case 'n':
1173	np = va_arg (argp, char *);
1174	n = gfc_match_name (buffer: np);
1175	if (n != MATCH_YES)
1176	{
1177	m = n;
1178	goto not_yes;
1179	}
1180
1181	matches++;
1182	goto loop;
1183
1184	case 'l':
1185	label = va_arg (argp, gfc_st_label **);
1186	n = gfc_match_st_label (label);
1187	if (n != MATCH_YES)
1188	{
1189	m = n;
1190	goto not_yes;
1191	}
1192
1193	matches++;
1194	goto loop;
1195
1196	case 'o':
1197	ip = va_arg (argp, int *);
1198	n = gfc_match_intrinsic_op (result: (gfc_intrinsic_op *) ip);
1199	if (n != MATCH_YES)
1200	{
1201	m = n;
1202	goto not_yes;
1203	}
1204
1205	matches++;
1206	goto loop;
1207
1208	case 't':
1209	if (gfc_match_eos () != MATCH_YES)
1210	{
1211	m = MATCH_NO;
1212	goto not_yes;
1213	}
1214	goto loop;
1215
1216	case ' ':
1217	if (gfc_match_space () == MATCH_YES)
1218	goto loop;
1219	m = MATCH_NO;
1220	goto not_yes;
1221
1222	case '%':
1223	break; /* Fall through to character matcher. */
1224
1225	default:
1226	gfc_internal_error ("gfc_match(): Bad match code %c", c);
1227	}
1228	/* FALLTHRU */
1229
1230	default:
1231
1232	/* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1233	expect an upper case character here! */
1234	gcc_assert (TOLOWER (c) == c);
1235
1236	if (c == gfc_next_ascii_char ())
1237	goto loop;
1238	break;
1239	}
1240
1241	not_yes:
1242	va_end (argp);
1243
1244	if (m != MATCH_YES)
1245	{
1246	/* Clean up after a failed match. */
1247	gfc_current_locus = old_loc;
1248	va_start (argp, target);
1249
1250	p = target;
1251	for (; matches > 0; matches--)
1252	{
1253	while (*p++ != '%');
1254
1255	switch (*p++)
1256	{
1257	case '%':
1258	matches++;
1259	break; /* Skip. */
1260
1261	/* Matches that don't have to be undone */
1262	case 'o':
1263	case 'l':
1264	case 'n':
1265	case 's':
1266	(void) va_arg (argp, void **);
1267	break;
1268
1269	case 'e':
1270	case 'v':
1271	vp = va_arg (argp, void **);
1272	gfc_free_expr ((struct gfc_expr *)*vp);
1273	*vp = NULL;
1274	break;
1275	}
1276	}
1277
1278	va_end (argp);
1279	}
1280
1281	return m;
1282	}
1283
1284
1285	/*********************** Statement level matching **********************/
1286
1287	/* Matches the start of a program unit, which is the program keyword
1288	followed by an obligatory symbol. */
1289
1290	match
1291	gfc_match_program (void)
1292	{
1293	gfc_symbol *sym;
1294	match m;
1295
1296	m = gfc_match (target: "% %s%t", &sym);
1297
1298	if (m == MATCH_NO)
1299	{
1300	gfc_error ("Invalid form of PROGRAM statement at %C");
1301	m = MATCH_ERROR;
1302	}
1303
1304	if (m == MATCH_ERROR)
1305	return m;
1306
1307	if (!gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL))
1308	return MATCH_ERROR;
1309
1310	gfc_new_block = sym;
1311
1312	return MATCH_YES;
1313	}
1314
1315
1316	/* Match a simple assignment statement. */
1317
1318	match
1319	gfc_match_assignment (void)
1320	{
1321	gfc_expr *lvalue, *rvalue;
1322	locus old_loc;
1323	match m;
1324
1325	old_loc = gfc_current_locus;
1326
1327	lvalue = NULL;
1328	m = gfc_match (target: " %v =", &lvalue);
1329	if (m != MATCH_YES)
1330	{
1331	gfc_current_locus = old_loc;
1332	gfc_free_expr (lvalue);
1333	return MATCH_NO;
1334	}
1335
1336	rvalue = NULL;
1337	m = gfc_match (target: " %e%t", &rvalue);
1338
1339	if (m == MATCH_YES
1340	&& rvalue->ts.type == BT_BOZ
1341	&& lvalue->ts.type == BT_CLASS)
1342	{
1343	m = MATCH_ERROR;
1344	gfc_error ("BOZ literal constant at %L is neither a DATA statement "
1345	"value nor an actual argument of INT/REAL/DBLE/CMPLX "
1346	"intrinsic subprogram", &rvalue->where);
1347	}
1348
1349	if (lvalue->expr_type == EXPR_CONSTANT)
1350	{
1351	/* This clobbers %len and %kind. */
1352	m = MATCH_ERROR;
1353	gfc_error ("Assignment to a constant expression at %C");
1354	}
1355
1356	if (m != MATCH_YES)
1357	{
1358	gfc_current_locus = old_loc;
1359	gfc_free_expr (lvalue);
1360	gfc_free_expr (rvalue);
1361	return m;
1362	}
1363
1364	if (!lvalue->symtree)
1365	{
1366	gfc_free_expr (lvalue);
1367	gfc_free_expr (rvalue);
1368	return MATCH_ERROR;
1369	}
1370
1371
1372	gfc_set_sym_referenced (lvalue->symtree->n.sym);
1373
1374	new_st.op = EXEC_ASSIGN;
1375	new_st.expr1 = lvalue;
1376	new_st.expr2 = rvalue;
1377
1378	gfc_check_do_variable (lvalue->symtree);
1379
1380	return MATCH_YES;
1381	}
1382
1383
1384	/* Match a pointer assignment statement. */
1385
1386	match
1387	gfc_match_pointer_assignment (void)
1388	{
1389	gfc_expr *lvalue, *rvalue;
1390	locus old_loc;
1391	match m;
1392
1393	old_loc = gfc_current_locus;
1394
1395	lvalue = rvalue = NULL;
1396	gfc_matching_ptr_assignment = 0;
1397	gfc_matching_procptr_assignment = 0;
1398
1399	m = gfc_match (target: " %v =>", &lvalue);
1400	if (m != MATCH_YES || !lvalue->symtree)
1401	{
1402	m = MATCH_NO;
1403	goto cleanup;
1404	}
1405
1406	if (lvalue->symtree->n.sym->attr.proc_pointer
1407	|| gfc_is_proc_ptr_comp (lvalue))
1408	gfc_matching_procptr_assignment = 1;
1409	else
1410	gfc_matching_ptr_assignment = 1;
1411
1412	m = gfc_match (target: " %e%t", &rvalue);
1413	gfc_matching_ptr_assignment = 0;
1414	gfc_matching_procptr_assignment = 0;
1415	if (m != MATCH_YES)
1416	goto cleanup;
1417
1418	new_st.op = EXEC_POINTER_ASSIGN;
1419	new_st.expr1 = lvalue;
1420	new_st.expr2 = rvalue;
1421
1422	return MATCH_YES;
1423
1424	cleanup:
1425	gfc_current_locus = old_loc;
1426	gfc_free_expr (lvalue);
1427	gfc_free_expr (rvalue);
1428	return m;
1429	}
1430
1431
1432	/* We try to match an easy arithmetic IF statement. This only happens
1433	when just after having encountered a simple IF statement. This code
1434	is really duplicate with parts of the gfc_match_if code, but this is
1435	*much* easier. */
1436
1437	static match
1438	match_arithmetic_if (void)
1439	{
1440	gfc_st_label *l1, *l2, *l3;
1441	gfc_expr *expr;
1442	match m;
1443
1444	m = gfc_match (target: " ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
1445	if (m != MATCH_YES)
1446	return m;
1447
1448	if (!gfc_reference_st_label (l1, ST_LABEL_TARGET)
1449	|| !gfc_reference_st_label (l2, ST_LABEL_TARGET)
1450	|| !gfc_reference_st_label (l3, ST_LABEL_TARGET))
1451	{
1452	gfc_free_expr (expr);
1453	return MATCH_ERROR;
1454	}
1455
1456	if (!gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
1457	"Arithmetic IF statement at %C"))
1458	return MATCH_ERROR;
1459
1460	new_st.op = EXEC_ARITHMETIC_IF;
1461	new_st.expr1 = expr;
1462	new_st.label1 = l1;
1463	new_st.label2 = l2;
1464	new_st.label3 = l3;
1465
1466	return MATCH_YES;
1467	}
1468
1469
1470	/* The IF statement is a bit of a pain. First of all, there are three
1471	forms of it, the simple IF, the IF that starts a block and the
1472	arithmetic IF.
1473
1474	There is a problem with the simple IF and that is the fact that we
1475	only have a single level of undo information on symbols. What this
1476	means is for a simple IF, we must re-match the whole IF statement
1477	multiple times in order to guarantee that the symbol table ends up
1478	in the proper state. */
1479
1480	static match match_simple_forall (void);
1481	static match match_simple_where (void);
1482
1483	match
1484	gfc_match_if (gfc_statement *if_type)
1485	{
1486	gfc_expr *expr;
1487	gfc_st_label *l1, *l2, *l3;
1488	locus old_loc, old_loc2;
1489	gfc_code *p;
1490	match m, n;
1491
1492	n = gfc_match_label ();
1493	if (n == MATCH_ERROR)
1494	return n;
1495
1496	old_loc = gfc_current_locus;
1497
1498	m = gfc_match (target: " if ", &expr);
1499	if (m != MATCH_YES)
1500	return m;
1501
1502	if (gfc_match_char (c: '(') != MATCH_YES)
1503	{
1504	gfc_error ("Missing %<(%> in IF-expression at %C");
1505	return MATCH_ERROR;
1506	}
1507
1508	m = gfc_match (target: "%e", &expr);
1509	if (m != MATCH_YES)
1510	return m;
1511
1512	old_loc2 = gfc_current_locus;
1513	gfc_current_locus = old_loc;
1514
1515	if (gfc_match_parens () == MATCH_ERROR)
1516	return MATCH_ERROR;
1517
1518	gfc_current_locus = old_loc2;
1519
1520	if (gfc_match_char (c: ')') != MATCH_YES)
1521	{
1522	gfc_error ("Syntax error in IF-expression at %C");
1523	gfc_free_expr (expr);
1524	return MATCH_ERROR;
1525	}
1526
1527	m = gfc_match (target: " %l , %l , %l%t", &l1, &l2, &l3);
1528
1529	if (m == MATCH_YES)
1530	{
1531	if (n == MATCH_YES)
1532	{
1533	gfc_error ("Block label not appropriate for arithmetic IF "
1534	"statement at %C");
1535	gfc_free_expr (expr);
1536	return MATCH_ERROR;
1537	}
1538
1539	if (!gfc_reference_st_label (l1, ST_LABEL_TARGET)
1540	|| !gfc_reference_st_label (l2, ST_LABEL_TARGET)
1541	|| !gfc_reference_st_label (l3, ST_LABEL_TARGET))
1542	{
1543	gfc_free_expr (expr);
1544	return MATCH_ERROR;
1545	}
1546
1547	if (!gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
1548	"Arithmetic IF statement at %C"))
1549	return MATCH_ERROR;
1550
1551	new_st.op = EXEC_ARITHMETIC_IF;
1552	new_st.expr1 = expr;
1553	new_st.label1 = l1;
1554	new_st.label2 = l2;
1555	new_st.label3 = l3;
1556
1557	*if_type = ST_ARITHMETIC_IF;
1558	return MATCH_YES;
1559	}
1560
1561	if (gfc_match (target: " then%t") == MATCH_YES)
1562	{
1563	new_st.op = EXEC_IF;
1564	new_st.expr1 = expr;
1565	*if_type = ST_IF_BLOCK;
1566	return MATCH_YES;
1567	}
1568
1569	if (n == MATCH_YES)
1570	{
1571	gfc_error ("Block label is not appropriate for IF statement at %C");
1572	gfc_free_expr (expr);
1573	return MATCH_ERROR;
1574	}
1575
1576	/* At this point the only thing left is a simple IF statement. At
1577	this point, n has to be MATCH_NO, so we don't have to worry about
1578	re-matching a block label. From what we've got so far, try
1579	matching an assignment. */
1580
1581	*if_type = ST_SIMPLE_IF;
1582
1583	m = gfc_match_assignment ();
1584	if (m == MATCH_YES)
1585	goto got_match;
1586
1587	gfc_free_expr (expr);
1588	gfc_undo_symbols ();
1589	gfc_current_locus = old_loc;
1590
1591	/* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1592	assignment was found. For MATCH_NO, continue to call the various
1593	matchers. */
1594	if (m == MATCH_ERROR)
1595	return MATCH_ERROR;
1596
1597	gfc_match (target: " if ( %e ) ", &expr); /* Guaranteed to match. */
1598
1599	m = gfc_match_pointer_assignment ();
1600	if (m == MATCH_YES)
1601	goto got_match;
1602
1603	gfc_free_expr (expr);
1604	gfc_undo_symbols ();
1605	gfc_current_locus = old_loc;
1606
1607	gfc_match (target: " if ( %e ) ", &expr); /* Guaranteed to match. */
1608
1609	/* Look at the next keyword to see which matcher to call. Matching
1610	the keyword doesn't affect the symbol table, so we don't have to
1611	restore between tries. */
1612
1613	#define match(string, subr, statement) \
1614	if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1615
1616	gfc_clear_error ();
1617
1618	match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1619	match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1620	match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1621	match ("call", gfc_match_call, ST_CALL)
1622	match ("change% team", gfc_match_change_team, ST_CHANGE_TEAM)
1623	match ("close", gfc_match_close, ST_CLOSE)
1624	match ("continue", gfc_match_continue, ST_CONTINUE)
1625	match ("cycle", gfc_match_cycle, ST_CYCLE)
1626	match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1627	match ("end file", gfc_match_endfile, ST_END_FILE)
1628	match ("end team", gfc_match_end_team, ST_END_TEAM)
1629	match ("error% stop", gfc_match_error_stop, ST_ERROR_STOP)
1630	match ("event% post", gfc_match_event_post, ST_EVENT_POST)
1631	match ("event% wait", gfc_match_event_wait, ST_EVENT_WAIT)
1632	match ("exit", gfc_match_exit, ST_EXIT)
1633	match ("fail% image", gfc_match_fail_image, ST_FAIL_IMAGE)
1634	match ("flush", gfc_match_flush, ST_FLUSH)
1635	match ("forall", match_simple_forall, ST_FORALL)
1636	match ("form% team", gfc_match_form_team, ST_FORM_TEAM)
1637	match ("go to", gfc_match_goto, ST_GOTO)
1638	match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1639	match ("inquire", gfc_match_inquire, ST_INQUIRE)
1640	match ("lock", gfc_match_lock, ST_LOCK)
1641	match ("nullify", gfc_match_nullify, ST_NULLIFY)
1642	match ("open", gfc_match_open, ST_OPEN)
1643	match ("pause", gfc_match_pause, ST_NONE)
1644	match ("print", gfc_match_print, ST_WRITE)
1645	match ("read", gfc_match_read, ST_READ)
1646	match ("return", gfc_match_return, ST_RETURN)
1647	match ("rewind", gfc_match_rewind, ST_REWIND)
1648	match ("stop", gfc_match_stop, ST_STOP)
1649	match ("wait", gfc_match_wait, ST_WAIT)
1650	match ("sync% all", gfc_match_sync_all, ST_SYNC_CALL);
1651	match ("sync% images", gfc_match_sync_images, ST_SYNC_IMAGES);
1652	match ("sync% memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
1653	match ("sync% team", gfc_match_sync_team, ST_SYNC_TEAM)
1654	match ("unlock", gfc_match_unlock, ST_UNLOCK)
1655	match ("where", match_simple_where, ST_WHERE)
1656	match ("write", gfc_match_write, ST_WRITE)
1657
1658	if (flag_dec)
1659	match ("type", gfc_match_print, ST_WRITE)
1660
1661	/* All else has failed, so give up. See if any of the matchers has
1662	stored an error message of some sort. */
1663	if (!gfc_error_check ())
1664	gfc_error ("Syntax error in IF-clause after %C");
1665
1666	gfc_free_expr (expr);
1667	return MATCH_ERROR;
1668
1669	got_match:
1670	if (m == MATCH_NO)
1671	gfc_error ("Syntax error in IF-clause after %C");
1672	if (m != MATCH_YES)
1673	{
1674	gfc_free_expr (expr);
1675	return MATCH_ERROR;
1676	}
1677
1678	/* At this point, we've matched the single IF and the action clause
1679	is in new_st. Rearrange things so that the IF statement appears
1680	in new_st. */
1681
1682	p = gfc_get_code (EXEC_IF);
1683	p->next = XCNEW (gfc_code);
1684	*p->next = new_st;
1685	p->next->loc = gfc_current_locus;
1686
1687	p->expr1 = expr;
1688
1689	gfc_clear_new_st ();
1690
1691	new_st.op = EXEC_IF;
1692	new_st.block = p;
1693
1694	return MATCH_YES;
1695	}
1696
1697	#undef match
1698
1699
1700	/* Match an ELSE statement. */
1701
1702	match
1703	gfc_match_else (void)
1704	{
1705	char name[GFC_MAX_SYMBOL_LEN + 1];
1706
1707	if (gfc_match_eos () == MATCH_YES)
1708	return MATCH_YES;
1709
1710	if (gfc_match_name (buffer: name) != MATCH_YES
1711	|| gfc_current_block () == NULL
1712	|| gfc_match_eos () != MATCH_YES)
1713	{
1714	gfc_error ("Invalid character(s) in ELSE statement after %C");
1715	return MATCH_ERROR;
1716	}
1717
1718	if (strcmp (s1: name, gfc_current_block ()->name) != 0)
1719	{
1720	gfc_error ("Label %qs at %C doesn't match IF label %qs",
1721	name, gfc_current_block ()->name);
1722	return MATCH_ERROR;
1723	}
1724
1725	return MATCH_YES;
1726	}
1727
1728
1729	/* Match an ELSE IF statement. */
1730
1731	match
1732	gfc_match_elseif (void)
1733	{
1734	char name[GFC_MAX_SYMBOL_LEN + 1];
1735	gfc_expr *expr, *then;
1736	locus where;
1737	match m;
1738
1739	if (gfc_match_char (c: '(') != MATCH_YES)
1740	{
1741	gfc_error ("Missing %<(%> in ELSE IF expression at %C");
1742	return MATCH_ERROR;
1743	}
1744
1745	m = gfc_match (target: " %e ", &expr);
1746	if (m != MATCH_YES)
1747	return m;
1748
1749	if (gfc_match_char (c: ')') != MATCH_YES)
1750	{
1751	gfc_error ("Missing %<)%> in ELSE IF expression at %C");
1752	goto cleanup;
1753	}
1754
1755	m = gfc_match (target: " then ", &then);
1756
1757	where = gfc_current_locus;
1758
1759	if (m == MATCH_YES && (gfc_match_eos () == MATCH_YES
1760	|| (gfc_current_block ()
1761	&& gfc_match_name (buffer: name) == MATCH_YES)))
1762	goto done;
1763
1764	if (gfc_match_eos () == MATCH_YES)
1765	{
1766	gfc_error ("Missing THEN in ELSE IF statement after %L", &where);
1767	goto cleanup;
1768	}
1769
1770	if (gfc_match_name (buffer: name) != MATCH_YES
1771	|| gfc_current_block () == NULL
1772	|| gfc_match_eos () != MATCH_YES)
1773	{
1774	gfc_error ("Syntax error in ELSE IF statement after %L", &where);
1775	goto cleanup;
1776	}
1777
1778	if (strcmp (s1: name, gfc_current_block ()->name) != 0)
1779	{
1780	gfc_error ("Label %qs after %L doesn't match IF label %qs",
1781	name, &where, gfc_current_block ()->name);
1782	goto cleanup;
1783	}
1784
1785	if (m != MATCH_YES)
1786	return m;
1787
1788	done:
1789	new_st.op = EXEC_IF;
1790	new_st.expr1 = expr;
1791	return MATCH_YES;
1792
1793	cleanup:
1794	gfc_free_expr (expr);
1795	return MATCH_ERROR;
1796	}
1797
1798
1799	/* Free a gfc_iterator structure. */
1800
1801	void
1802	gfc_free_iterator (gfc_iterator *iter, int flag)
1803	{
1804
1805	if (iter == NULL)
1806	return;
1807
1808	gfc_free_expr (iter->var);
1809	gfc_free_expr (iter->start);
1810	gfc_free_expr (iter->end);
1811	gfc_free_expr (iter->step);
1812
1813	if (flag)
1814	free (ptr: iter);
1815	}
1816
1817	static match
1818	match_named_arg (const char *pat, const char *name, gfc_expr **e,
1819	gfc_statement st_code)
1820	{
1821	match m;
1822	gfc_expr *tmp;
1823
1824	m = gfc_match (target: pat, &tmp);
1825	if (m == MATCH_ERROR)
1826	{
1827	gfc_syntax_error (st_code);
1828	return m;
1829	}
1830	if (m == MATCH_YES)
1831	{
1832	if (*e)
1833	{
1834	gfc_error ("Duplicate %s attribute in %C", name);
1835	gfc_free_expr (tmp);
1836	return MATCH_ERROR;
1837	}
1838	*e = tmp;
1839
1840	return MATCH_YES;
1841	}
1842	return MATCH_NO;
1843	}
1844
1845	static match
1846	match_stat_errmsg (struct sync_stat *sync_stat, gfc_statement st_code)
1847	{
1848	match m;
1849
1850	m = match_named_arg (pat: " stat = %v", name: "STAT", e: &sync_stat->stat, st_code);
1851	if (m != MATCH_NO)
1852	return m;
1853
1854	m = match_named_arg (pat: " errmsg = %v", name: "ERRMSG", e: &sync_stat->errmsg, st_code);
1855	return m;
1856	}
1857
1858	/* Match a CRITICAL statement. */
1859	match
1860	gfc_match_critical (void)
1861	{
1862	gfc_st_label *label = NULL;
1863	match m;
1864
1865	if (gfc_match_label () == MATCH_ERROR)
1866	return MATCH_ERROR;
1867
1868	if (gfc_match (target: " critical") != MATCH_YES)
1869	return MATCH_NO;
1870
1871	if (gfc_match_st_label (label: &label) == MATCH_ERROR)
1872	return MATCH_ERROR;
1873
1874	if (gfc_match_eos () == MATCH_YES)
1875	goto done;
1876
1877	if (gfc_match_char (c: '(') != MATCH_YES)
1878	goto syntax;
1879
1880	for (;;)
1881	{
1882	m = match_stat_errmsg (sync_stat: &new_st.ext.sync_stat, st_code: ST_CRITICAL);
1883	if (m == MATCH_ERROR)
1884	goto cleanup;
1885
1886	if (gfc_match_char (c: ',') == MATCH_YES)
1887	continue;
1888
1889	break;
1890	}
1891
1892	if (gfc_match (target: " )%t") != MATCH_YES)
1893	goto syntax;
1894
1895	done:
1896
1897	if (gfc_pure (NULL))
1898	{
1899	gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1900	return MATCH_ERROR;
1901	}
1902
1903	if (gfc_find_state (COMP_DO_CONCURRENT))
1904	{
1905	gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1906	"block");
1907	return MATCH_ERROR;
1908	}
1909
1910	gfc_unset_implicit_pure (NULL);
1911
1912	if (!gfc_notify_std (GFC_STD_F2008, "CRITICAL statement at %C"))
1913	return MATCH_ERROR;
1914
1915	if (flag_coarray == GFC_FCOARRAY_NONE)
1916	{
1917	gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1918	"enable");
1919	return MATCH_ERROR;
1920	}
1921
1922	if (gfc_find_state (COMP_CRITICAL))
1923	{
1924	gfc_error ("Nested CRITICAL block at %C");
1925	return MATCH_ERROR;
1926	}
1927
1928	new_st.op = EXEC_CRITICAL;
1929
1930	if (label != NULL && !gfc_reference_st_label (label, ST_LABEL_TARGET))
1931	goto cleanup;
1932
1933	return MATCH_YES;
1934
1935	syntax:
1936	gfc_syntax_error (ST_CRITICAL);
1937
1938	cleanup:
1939	gfc_free_expr (new_st.ext.sync_stat.stat);
1940	gfc_free_expr (new_st.ext.sync_stat.errmsg);
1941	new_st.ext.sync_stat = {NULL, NULL};
1942
1943	return MATCH_ERROR;
1944	}
1945
1946	/* Match a BLOCK statement. */
1947
1948	match
1949	gfc_match_block (void)
1950	{
1951	match m;
1952
1953	if (gfc_match_label () == MATCH_ERROR)
1954	return MATCH_ERROR;
1955
1956	if (gfc_match (target: " block") != MATCH_YES)
1957	return MATCH_NO;
1958
1959	/* For this to be a correct BLOCK statement, the line must end now. */
1960	m = gfc_match_eos ();
1961	if (m == MATCH_ERROR)
1962	return MATCH_ERROR;
1963	if (m == MATCH_NO)
1964	return MATCH_NO;
1965
1966	return MATCH_YES;
1967	}
1968
1969	bool
1970	check_coarray_assoc (const char *name, gfc_association_list *assoc)
1971	{
1972	if (assoc->target->expr_type == EXPR_VARIABLE
1973	&& !strcmp (s1: assoc->target->symtree->name, s2: name))
1974	{
1975	gfc_error ("Codimension decl name %qs in association at %L "
1976	"must not be the same as a selector",
1977	name, &assoc->where);
1978	return false;
1979	}
1980	return true;
1981	}
1982
1983	match
1984	match_association_list (bool for_change_team = false)
1985	{
1986	new_st.ext.block.assoc = NULL;
1987	while (true)
1988	{
1989	gfc_association_list *newAssoc = gfc_get_association_list ();
1990	gfc_association_list *a;
1991	locus pre_name = gfc_current_locus;
1992
1993	/* Match the next association. */
1994	if (gfc_match (target: " %n ", newAssoc->name) != MATCH_YES)
1995	{
1996	gfc_error ("Expected associate name at %C");
1997	goto assocListError;
1998	}
1999
2000	/* Required for an assumed rank target. */
2001	if (!for_change_team && gfc_peek_char () == '(')
2002	{
2003	newAssoc->ar = gfc_get_array_ref ();
2004	if (gfc_match_array_ref (newAssoc->ar, NULL, 0, 0) != MATCH_YES)
2005	{
2006	gfc_error ("Bad bounds remapping list at %C");
2007	goto assocListError;
2008	}
2009	}
2010
2011	if (newAssoc->ar && !(gfc_option.allow_std & GFC_STD_F202Y))
2012	gfc_error_now ("The bounds remapping list at %C is an experimental "
2013	"F202y feature. Use std=f202y to enable");
2014
2015	if (for_change_team && gfc_peek_char () == '[')
2016	{
2017	if (!newAssoc->ar)
2018	newAssoc->ar = gfc_get_array_ref ();
2019	if (gfc_match_array_spec (&newAssoc->ar->as, false, true)
2020	== MATCH_ERROR)
2021	goto assocListError;
2022	}
2023
2024	/* Match the next association. */
2025	if (gfc_match (target: " =>", newAssoc->name) != MATCH_YES)
2026	{
2027	if (for_change_team)
2028	gfc_current_locus = pre_name;
2029
2030	free (ptr: newAssoc);
2031	return MATCH_NO;
2032	}
2033
2034	if (!for_change_team)
2035	{
2036	if (gfc_match (target: " %e", &newAssoc->target) != MATCH_YES)
2037	{
2038	/* Have another go, allowing for procedure pointer selectors. */
2039	gfc_matching_procptr_assignment = 1;
2040	if (gfc_match (target: " %e", &newAssoc->target) != MATCH_YES)
2041	{
2042	gfc_matching_procptr_assignment = 0;
2043	gfc_error ("Invalid association target at %C");
2044	goto assocListError;
2045	}
2046	gfc_matching_procptr_assignment = 0;
2047	}
2048	newAssoc->where = gfc_current_locus;
2049	}
2050	else
2051	{
2052	newAssoc->where = gfc_current_locus;
2053	/* F2018, C1116: A selector in a coarray-association shall be a named
2054	coarray. */
2055	if (gfc_match (target: " %v", &newAssoc->target) != MATCH_YES)
2056	{
2057	gfc_error ("Selector in coarray association as %C shall be a "
2058	"named coarray");
2059	goto assocListError;
2060	}
2061	}
2062
2063	/* Check that the current name is not yet in the list. */
2064	for (a = new_st.ext.block.assoc; a; a = a->next)
2065	if (!strcmp (s1: a->name, s2: newAssoc->name))
2066	{
2067	gfc_error ("Duplicate name %qs in association at %C",
2068	newAssoc->name);
2069	goto assocListError;
2070	}
2071
2072	if (for_change_team)
2073	{
2074	/* F2018, C1113: In a change-team-stmt, a coarray-name in a
2075	codimension-decl shall not be the same as a selector, or another
2076	coarray-name, in that statement.
2077	The latter is already checked for above. So check only the
2078	former.
2079	*/
2080	if (!check_coarray_assoc (name: newAssoc->name, assoc: newAssoc))
2081	goto assocListError;
2082
2083	for (a = new_st.ext.block.assoc; a; a = a->next)
2084	{
2085	if (!check_coarray_assoc (name: newAssoc->name, assoc: a)
2086	|| !check_coarray_assoc (name: a->name, assoc: newAssoc))
2087	goto assocListError;
2088
2089	/* F2018, C1115: No selector shall appear more than once in a
2090	* given change-team-stmt. */
2091	if (!strcmp (s1: newAssoc->target->symtree->name,
2092	s2: a->target->symtree->name))
2093	{
2094	gfc_error ("Selector at %L duplicates selector at %L",
2095	&newAssoc->target->where, &a->target->where);
2096	goto assocListError;
2097	}
2098	}
2099	}
2100
2101	/* The target expression must not be coindexed. */
2102	if (gfc_is_coindexed (newAssoc->target))
2103	{
2104	gfc_error ("Association target at %C must not be coindexed");
2105	goto assocListError;
2106	}
2107
2108	/* The target expression cannot be a BOZ literal constant. */
2109	if (newAssoc->target->ts.type == BT_BOZ)
2110	{
2111	gfc_error ("Association target at %L cannot be a BOZ literal "
2112	"constant", &newAssoc->target->where);
2113	goto assocListError;
2114	}
2115
2116	if (newAssoc->target->expr_type == EXPR_VARIABLE
2117	&& newAssoc->target->symtree->n.sym->as
2118	&& newAssoc->target->symtree->n.sym->as->type == AS_ASSUMED_RANK)
2119	{
2120	bool bounds_remapping_list = true;
2121	if (!newAssoc->ar)
2122	bounds_remapping_list = false;
2123	else
2124	for (int dim = 0; dim < newAssoc->ar->dimen; dim++)
2125	if (!newAssoc->ar->start[dim] || !newAssoc->ar->end[dim]
2126	|| newAssoc->ar->stride[dim] != NULL)
2127	bounds_remapping_list = false;
2128
2129	if (!bounds_remapping_list)
2130	{
2131	gfc_error ("The associate name %s with an assumed rank "
2132	"target at %L must have a bounds remapping list "
2133	"(list of lbound:ubound for each dimension)",
2134	newAssoc->name, &newAssoc->target->where);
2135	goto assocListError;
2136	}
2137
2138	if (!newAssoc->target->symtree->n.sym->attr.contiguous)
2139	{
2140	gfc_error ("The assumed rank target at %C must be contiguous");
2141	goto assocListError;
2142	}
2143	}
2144	else if (newAssoc->target->ts.type == BT_UNKNOWN
2145	&& newAssoc->target->expr_type == EXPR_OP)
2146	{
2147	/* This will work for sure if the operator is type bound to a use
2148	associated derived type. */
2149	gfc_expr *tmp =gfc_copy_expr (newAssoc->target);
2150	if (gfc_extend_expr (tmp) == MATCH_YES)
2151	gfc_replace_expr (newAssoc->target, tmp);
2152	else
2153	gfc_free_expr (tmp);
2154	}
2155
2156	/* The `variable' field is left blank for now; because the target is not
2157	yet resolved, we can't use gfc_has_vector_subscript to determine it
2158	for now. This is set during resolution. */
2159
2160	/* Put it into the list. */
2161	newAssoc->next = new_st.ext.block.assoc;
2162	new_st.ext.block.assoc = newAssoc;
2163
2164	/* Try next one or end if closing parenthesis is found. */
2165	gfc_gobble_whitespace ();
2166	if (gfc_peek_char () == ')')
2167	break;
2168	if (gfc_match_char (c: ',') != MATCH_YES)
2169	{
2170	gfc_error ("Expected %<)%> or %<,%> at %C");
2171	return MATCH_ERROR;
2172	}
2173
2174	continue;
2175
2176	assocListError:
2177	free (ptr: newAssoc);
2178	return MATCH_ERROR;
2179	}
2180
2181	return MATCH_YES;
2182	}
2183
2184	/* Match an ASSOCIATE statement. */
2185
2186	match
2187	gfc_match_associate (void)
2188	{
2189	match m;
2190	if (gfc_match_label () == MATCH_ERROR)
2191	return MATCH_ERROR;
2192
2193	if (gfc_match (target: " associate") != MATCH_YES)
2194	return MATCH_NO;
2195
2196	/* Match the association list. */
2197	if (gfc_match_char (c: '(') != MATCH_YES)
2198	{
2199	gfc_error ("Expected association list at %C");
2200	return MATCH_ERROR;
2201	}
2202
2203	m = match_association_list ();
2204	if (m == MATCH_ERROR)
2205	goto error;
2206	else if (m == MATCH_NO)
2207	{
2208	gfc_error ("Expected association at %C");
2209	goto error;
2210	}
2211
2212	if (gfc_match_char (c: ')') != MATCH_YES)
2213	{
2214	/* This should never happen as we peek above. */
2215	gcc_unreachable ();
2216	}
2217
2218	if (gfc_match_eos () != MATCH_YES)
2219	{
2220	gfc_error ("Junk after ASSOCIATE statement at %C");
2221	goto error;
2222	}
2223
2224	return MATCH_YES;
2225
2226	error:
2227	gfc_free_association_list (new_st.ext.block.assoc);
2228	return MATCH_ERROR;
2229	}
2230
2231
2232	/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
2233	an accessible derived type. */
2234
2235	static match
2236	match_derived_type_spec (gfc_typespec *ts)
2237	{
2238	char name[GFC_MAX_SYMBOL_LEN + 1];
2239	locus old_locus;
2240	gfc_symbol *derived, *der_type;
2241	match m = MATCH_YES;
2242	gfc_actual_arglist *decl_type_param_list = NULL;
2243	bool is_pdt_template = false;
2244
2245	old_locus = gfc_current_locus;
2246
2247	if (gfc_match (target: "%n", name) != MATCH_YES)
2248	{
2249	gfc_current_locus = old_locus;
2250	return MATCH_NO;
2251	}
2252
2253	gfc_find_symbol (name, NULL, 1, &derived);
2254
2255	/* Match the PDT spec list, if there. */
2256	if (derived && derived->attr.flavor == FL_PROCEDURE)
2257	{
2258	gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &der_type);
2259	is_pdt_template = der_type
2260	&& der_type->attr.flavor == FL_DERIVED
2261	&& der_type->attr.pdt_template;
2262	}
2263
2264	if (is_pdt_template)
2265	m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
2266
2267	if (m == MATCH_ERROR)
2268	{
2269	gfc_free_actual_arglist (decl_type_param_list);
2270	return m;
2271	}
2272
2273	if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic)
2274	derived = gfc_find_dt_in_generic (derived);
2275
2276	/* If this is a PDT, find the specific instance. */
2277	if (m == MATCH_YES && is_pdt_template)
2278	{
2279	gfc_namespace *old_ns;
2280
2281	old_ns = gfc_current_ns;
2282	while (gfc_current_ns && gfc_current_ns->parent)
2283	gfc_current_ns = gfc_current_ns->parent;
2284
2285	if (type_param_spec_list)
2286	gfc_free_actual_arglist (type_param_spec_list);
2287	m = gfc_get_pdt_instance (decl_type_param_list, &der_type,
2288	&type_param_spec_list);
2289	gfc_free_actual_arglist (decl_type_param_list);
2290
2291	if (m != MATCH_YES)
2292	return m;
2293	derived = der_type;
2294	gcc_assert (!derived->attr.pdt_template && derived->attr.pdt_type);
2295	gfc_set_sym_referenced (derived);
2296
2297	gfc_current_ns = old_ns;
2298	}
2299
2300	if (derived && derived->attr.flavor == FL_DERIVED)
2301	{
2302	ts->type = BT_DERIVED;
2303	ts->u.derived = derived;
2304	return MATCH_YES;
2305	}
2306
2307	gfc_current_locus = old_locus;
2308	return MATCH_NO;
2309	}
2310
2311
2312	/* Match a Fortran 2003 type-spec (F03:R401). This is similar to
2313	gfc_match_decl_type_spec() from decl.cc, with the following exceptions:
2314	It only includes the intrinsic types from the Fortran 2003 standard
2315	(thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2316	the implicit_flag is not needed, so it was removed. Derived types are
2317	identified by their name alone. */
2318
2319	static match
2320	match_type_spec (gfc_typespec *ts)
2321	{
2322	match m;
2323	locus old_locus;
2324	char c, name[GFC_MAX_SYMBOL_LEN + 1];
2325
2326	gfc_clear_ts (ts);
2327	gfc_gobble_whitespace ();
2328	old_locus = gfc_current_locus;
2329
2330	/* If c isn't [a-z], then return immediately. */
2331	c = gfc_peek_ascii_char ();
2332	if (!ISALPHA(c))
2333	return MATCH_NO;
2334
2335	type_param_spec_list = NULL;
2336
2337	if (match_derived_type_spec (ts) == MATCH_YES)
2338	{
2339	/* Enforce F03:C401. */
2340	if (ts->u.derived->attr.abstract)
2341	{
2342	gfc_error ("Derived type %qs at %L may not be ABSTRACT",
2343	ts->u.derived->name, &old_locus);
2344	return MATCH_ERROR;
2345	}
2346	return MATCH_YES;
2347	}
2348
2349	if (gfc_match (target: "integer") == MATCH_YES)
2350	{
2351	ts->type = BT_INTEGER;
2352	ts->kind = gfc_default_integer_kind;
2353	goto kind_selector;
2354	}
2355
2356	if (flag_unsigned && gfc_match (target: "unsigned") == MATCH_YES)
2357	{
2358	ts->type = BT_UNSIGNED;
2359	ts->kind = gfc_default_integer_kind;
2360	goto kind_selector;
2361	}
2362
2363	if (gfc_match (target: "double precision") == MATCH_YES)
2364	{
2365	ts->type = BT_REAL;
2366	ts->kind = gfc_default_double_kind;
2367	return MATCH_YES;
2368	}
2369
2370	if (gfc_match (target: "complex") == MATCH_YES)
2371	{
2372	ts->type = BT_COMPLEX;
2373	ts->kind = gfc_default_complex_kind;
2374	goto kind_selector;
2375	}
2376
2377	if (gfc_match (target: "character") == MATCH_YES)
2378	{
2379	ts->type = BT_CHARACTER;
2380
2381	m = gfc_match_char_spec (ts);
2382
2383	if (m == MATCH_NO)
2384	m = MATCH_YES;
2385
2386	return m;
2387	}
2388
2389	/* REAL is a real pain because it can be a type, intrinsic subprogram,
2390	or list item in a type-list of an OpenMP reduction clause. Need to
2391	differentiate REAL([KIND]=scalar-int-initialization-expr) from
2392	REAL(A,[KIND]) and REAL(KIND,A). Logically, when this code was
2393	written the use of LOGICAL as a type-spec or intrinsic subprogram
2394	was overlooked. */
2395
2396	m = gfc_match (target: " %n", name);
2397	if (m == MATCH_YES
2398	&& (strcmp (s1: name, s2: "real") == 0 || strcmp (s1: name, s2: "logical") == 0))
2399	{
2400	char c;
2401	gfc_expr *e;
2402	locus where;
2403
2404	if (*name == 'r')
2405	{
2406	ts->type = BT_REAL;
2407	ts->kind = gfc_default_real_kind;
2408	}
2409	else
2410	{
2411	ts->type = BT_LOGICAL;
2412	ts->kind = gfc_default_logical_kind;
2413	}
2414
2415	gfc_gobble_whitespace ();
2416
2417	/* Prevent REAL*4, etc. */
2418	c = gfc_peek_ascii_char ();
2419	if (c == '*')
2420	{
2421	gfc_error ("Invalid type-spec at %C");
2422	return MATCH_ERROR;
2423	}
2424
2425	/* Found leading colon in REAL::, a trailing ')' in for example
2426	TYPE IS (REAL), or REAL, for an OpenMP list-item. */
2427	if (c == ':' || c == ')' || (flag_openmp && c == ','))
2428	return MATCH_YES;
2429
2430	/* Found something other than the opening '(' in REAL(... */
2431	if (c != '(')
2432	return MATCH_NO;
2433	else
2434	gfc_next_char (); /* Burn the '('. */
2435
2436	/* Look for the optional KIND=. */
2437	where = gfc_current_locus;
2438	m = gfc_match (target: "%n", name);
2439	if (m == MATCH_YES)
2440	{
2441	gfc_gobble_whitespace ();
2442	c = gfc_next_char ();
2443	if (c == '=')
2444	{
2445	if (strcmp(s1: name, s2: "a") == 0 || strcmp(s1: name, s2: "l") == 0)
2446	return MATCH_NO;
2447	else if (strcmp(s1: name, s2: "kind") == 0)
2448	goto found;
2449	else
2450	return MATCH_ERROR;
2451	}
2452	else
2453	gfc_current_locus = where;
2454	}
2455	else
2456	gfc_current_locus = where;
2457
2458	found:
2459
2460	m = gfc_match_expr (&e);
2461	if (m == MATCH_NO || m == MATCH_ERROR)
2462	return m;
2463
2464	/* If a comma appears, it is an intrinsic subprogram. */
2465	gfc_gobble_whitespace ();
2466	c = gfc_peek_ascii_char ();
2467	if (c == ',')
2468	{
2469	gfc_free_expr (e);
2470	return MATCH_NO;
2471	}
2472
2473	/* If ')' appears, we have REAL(initialization-expr), here check for
2474	a scalar integer initialization-expr and valid kind parameter. */
2475	if (c == ')')
2476	{
2477	bool ok = true;
2478	if (e->expr_type != EXPR_CONSTANT && e->expr_type != EXPR_VARIABLE)
2479	ok = gfc_reduce_init_expr (expr: e);
2480	if (!ok || e->ts.type != BT_INTEGER || e->rank > 0)
2481	{
2482	gfc_free_expr (e);
2483	return MATCH_NO;
2484	}
2485
2486	if (e->expr_type != EXPR_CONSTANT)
2487	goto ohno;
2488
2489	gfc_next_char (); /* Burn the ')'. */
2490	ts->kind = (int) mpz_get_si (e->value.integer);
2491	if (gfc_validate_kind (ts->type, ts->kind , true) == -1)
2492	{
2493	gfc_error ("Invalid type-spec at %C");
2494	return MATCH_ERROR;
2495	}
2496
2497	gfc_free_expr (e);
2498
2499	return MATCH_YES;
2500	}
2501	}
2502
2503	ohno:
2504
2505	/* If a type is not matched, simply return MATCH_NO. */
2506	gfc_current_locus = old_locus;
2507	return MATCH_NO;
2508
2509	kind_selector:
2510
2511	gfc_gobble_whitespace ();
2512
2513	/* This prevents INTEGER*4, etc. */
2514	if (gfc_peek_ascii_char () == '*')
2515	{
2516	gfc_error ("Invalid type-spec at %C");
2517	return MATCH_ERROR;
2518	}
2519
2520	m = gfc_match_kind_spec (ts, false);
2521
2522	/* No kind specifier found. */
2523	if (m == MATCH_NO)
2524	m = MATCH_YES;
2525
2526	return m;
2527	}
2528
2529
2530	match
2531	gfc_match_type_spec (gfc_typespec *ts)
2532	{
2533	match m;
2534	gfc_namespace *old_ns = gfc_current_ns;
2535	m = match_type_spec (ts);
2536	gfc_current_ns = old_ns;
2537	return m;
2538	}
2539
2540
2541	/******************** FORALL subroutines ********************/
2542
2543	/* Free a list of FORALL iterators. */
2544
2545	void
2546	gfc_free_forall_iterator (gfc_forall_iterator *iter)
2547	{
2548	gfc_forall_iterator *next;
2549
2550	while (iter)
2551	{
2552	next = iter->next;
2553	gfc_free_expr (iter->var);
2554	gfc_free_expr (iter->start);
2555	gfc_free_expr (iter->end);
2556	gfc_free_expr (iter->stride);
2557	free (ptr: iter);
2558	iter = next;
2559	}
2560	}
2561
2562
2563	/* Match an iterator as part of a FORALL statement. The format is:
2564
2565	<var> = <start>:<end>[:<stride>]
2566
2567	On MATCH_NO, the caller tests for the possibility that there is a
2568	scalar mask expression. */
2569
2570	static match
2571	match_forall_iterator (gfc_forall_iterator **result)
2572	{
2573	gfc_forall_iterator *iter;
2574	locus where;
2575	match m;
2576
2577	where = gfc_current_locus;
2578	iter = XCNEW (gfc_forall_iterator);
2579
2580	m = gfc_match_expr (&iter->var);
2581	if (m != MATCH_YES)
2582	goto cleanup;
2583
2584	if (gfc_match_char (c: '=') != MATCH_YES
2585	|| iter->var->expr_type != EXPR_VARIABLE)
2586	{
2587	m = MATCH_NO;
2588	goto cleanup;
2589	}
2590
2591	m = gfc_match_expr (&iter->start);
2592	if (m != MATCH_YES)
2593	goto cleanup;
2594
2595	if (gfc_match_char (c: ':') != MATCH_YES)
2596	goto syntax;
2597
2598	m = gfc_match_expr (&iter->end);
2599	if (m == MATCH_NO)
2600	goto syntax;
2601	if (m == MATCH_ERROR)
2602	goto cleanup;
2603
2604	if (gfc_match_char (c: ':') == MATCH_NO)
2605	iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
2606	else
2607	{
2608	m = gfc_match_expr (&iter->stride);
2609	if (m == MATCH_NO)
2610	goto syntax;
2611	if (m == MATCH_ERROR)
2612	goto cleanup;
2613	}
2614
2615	/* Mark the iteration variable's symbol as used as a FORALL index. */
2616	iter->var->symtree->n.sym->forall_index = true;
2617
2618	*result = iter;
2619	return MATCH_YES;
2620
2621	syntax:
2622	gfc_error ("Syntax error in FORALL iterator at %C");
2623	m = MATCH_ERROR;
2624
2625	cleanup:
2626
2627	gfc_current_locus = where;
2628	gfc_free_forall_iterator (iter);
2629	return m;
2630	}
2631
2632
2633	/* Apply type-spec to iterator and create shadow variable if needed. */
2634
2635	static void
2636	apply_typespec_to_iterator (gfc_forall_iterator *iter, gfc_typespec *ts,
2637	locus *loc)
2638	{
2639	char *name;
2640	gfc_expr *v;
2641	gfc_symtree *st;
2642
2643	/* When a type-spec is provided in DO CONCURRENT/FORALL, F2018 19.4(6)
2644	requires the index-name to have scope limited to the construct,
2645	shadowing any variable with the same name from outer scope.
2646	If the index-name was not previously declared, we can simply set its
2647	type. Otherwise, create a shadow variable with "_" prefix. */
2648	iter->shadow = false;
2649	v = iter->var;
2650	if (v->ts.type == BT_UNKNOWN)
2651	{
2652	/* Variable not declared in outer scope - just set the type. */
2653	v->ts.type = v->symtree->n.sym->ts.type = BT_INTEGER;
2654	v->ts.kind = v->symtree->n.sym->ts.kind = ts->kind;
2655	gfc_set_sym_referenced (v->symtree->n.sym);
2656	}
2657	else
2658	{
2659	/* Variable exists in outer scope - must create shadow to comply
2660	with F2018 19.4(6) scoping rules. */
2661	name = (char *) alloca (strlen (v->symtree->name) + 2);
2662	strcpy (dest: name, src: "_");
2663	strcat (dest: name, src: v->symtree->name);
2664	if (gfc_get_sym_tree (name, NULL, &st, false) != 0)
2665	gfc_internal_error ("Failed to create shadow variable symtree for "
2666	"DO CONCURRENT type-spec at %L", loc);
2667
2668	v = gfc_get_expr ();
2669	v->where = gfc_current_locus;
2670	v->expr_type = EXPR_VARIABLE;
2671	v->ts.type = st->n.sym->ts.type = ts->type;
2672	v->ts.kind = st->n.sym->ts.kind = ts->kind;
2673	st->n.sym->forall_index = true;
2674	v->symtree = st;
2675	gfc_replace_expr (iter->var, v);
2676	iter->shadow = true;
2677	gfc_set_sym_referenced (st->n.sym);
2678	}
2679
2680	/* Convert iterator bounds to the specified type. */
2681	gfc_convert_type (iter->start, ts, 1);
2682	gfc_convert_type (iter->end, ts, 1);
2683	gfc_convert_type (iter->stride, ts, 1);
2684	}
2685
2686
2687	/* Match the header of a FORALL statement. In F2008 and F2018, the form of
2688	the header is:
2689
2690	([ type-spec :: ] concurrent-control-list [, scalar-mask-expr ] )
2691
2692	where type-spec is INTEGER. */
2693
2694	static match
2695	match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
2696	{
2697	gfc_forall_iterator *head, *tail, *new_iter;
2698	gfc_expr *msk;
2699	match m;
2700	gfc_typespec ts;
2701	bool seen_ts = false;
2702	locus loc;
2703
2704	gfc_gobble_whitespace ();
2705
2706	head = tail = NULL;
2707	msk = NULL;
2708
2709	if (gfc_match_char (c: '(') != MATCH_YES)
2710	return MATCH_NO;
2711
2712	/* Check for an optional type-spec. */
2713	gfc_clear_ts (&ts);
2714	loc = gfc_current_locus;
2715	m = gfc_match_type_spec (ts: &ts);
2716	if (m == MATCH_YES)
2717	{
2718	seen_ts = (gfc_match (target: " ::") == MATCH_YES);
2719
2720	if (seen_ts)
2721	{
2722	if (!gfc_notify_std (GFC_STD_F2008, "FORALL or DO CONCURRENT "
2723	"construct includes type specification "
2724	"at %L", &loc))
2725	goto cleanup;
2726
2727	if (ts.type != BT_INTEGER)
2728	{
2729	gfc_error ("Type-spec at %L must be an INTEGER type", &loc);
2730	goto cleanup;
2731	}
2732	}
2733	}
2734	else if (m == MATCH_ERROR)
2735	goto syntax;
2736
2737	m = match_forall_iterator (result: &new_iter);
2738	if (m == MATCH_ERROR)
2739	goto cleanup;
2740	if (m == MATCH_NO)
2741	goto syntax;
2742
2743	if (seen_ts)
2744	apply_typespec_to_iterator (iter: new_iter, ts: &ts, loc: &loc);
2745
2746	head = tail = new_iter;
2747
2748	for (;;)
2749	{
2750	if (gfc_match_char (c: ',') != MATCH_YES)
2751	break;
2752
2753	m = match_forall_iterator (result: &new_iter);
2754	if (m == MATCH_ERROR)
2755	goto cleanup;
2756
2757	if (m == MATCH_YES)
2758	{
2759	if (seen_ts)
2760	apply_typespec_to_iterator (iter: new_iter, ts: &ts, loc: &loc);
2761
2762	tail->next = new_iter;
2763	tail = new_iter;
2764	continue;
2765	}
2766
2767	/* Have to have a mask expression. */
2768
2769	m = gfc_match_expr (&msk);
2770	if (m == MATCH_NO)
2771	goto syntax;
2772	if (m == MATCH_ERROR)
2773	goto cleanup;
2774
2775	break;
2776	}
2777
2778	if (gfc_match_char (c: ')') == MATCH_NO)
2779	goto syntax;
2780
2781	*phead = head;
2782	*mask = msk;
2783	return MATCH_YES;
2784
2785	syntax:
2786	gfc_syntax_error (ST_FORALL);
2787
2788	cleanup:
2789	gfc_free_expr (msk);
2790	gfc_free_forall_iterator (iter: head);
2791
2792	return MATCH_ERROR;
2793	}
2794
2795	/* Match the rest of a simple FORALL statement that follows an
2796	IF statement. */
2797
2798	static match
2799	match_simple_forall (void)
2800	{
2801	gfc_forall_iterator *head;
2802	gfc_expr *mask;
2803	gfc_code *c;
2804	match m;
2805
2806	mask = NULL;
2807	head = NULL;
2808	c = NULL;
2809
2810	m = match_forall_header (phead: &head, mask: &mask);
2811
2812	if (m == MATCH_NO)
2813	goto syntax;
2814	if (m != MATCH_YES)
2815	goto cleanup;
2816
2817	m = gfc_match_assignment ();
2818
2819	if (m == MATCH_ERROR)
2820	goto cleanup;
2821	if (m == MATCH_NO)
2822	{
2823	m = gfc_match_pointer_assignment ();
2824	if (m == MATCH_ERROR)
2825	goto cleanup;
2826	if (m == MATCH_NO)
2827	goto syntax;
2828	}
2829
2830	c = XCNEW (gfc_code);
2831	*c = new_st;
2832	c->loc = gfc_current_locus;
2833
2834	if (gfc_match_eos () != MATCH_YES)
2835	goto syntax;
2836
2837	gfc_clear_new_st ();
2838	new_st.op = EXEC_FORALL;
2839	new_st.expr1 = mask;
2840	new_st.ext.concur.forall_iterator = head;
2841	new_st.block = gfc_get_code (EXEC_FORALL);
2842	new_st.block->next = c;
2843
2844	return MATCH_YES;
2845
2846	syntax:
2847	gfc_syntax_error (ST_FORALL);
2848
2849	cleanup:
2850	gfc_free_forall_iterator (iter: head);
2851	gfc_free_expr (mask);
2852
2853	return MATCH_ERROR;
2854	}
2855
2856
2857	/* Match a FORALL statement. */
2858
2859	match
2860	gfc_match_forall (gfc_statement *st)
2861	{
2862	gfc_forall_iterator *head;
2863	gfc_expr *mask;
2864	gfc_code *c;
2865	match m0, m;
2866
2867	head = NULL;
2868	mask = NULL;
2869	c = NULL;
2870
2871	m0 = gfc_match_label ();
2872	if (m0 == MATCH_ERROR)
2873	return MATCH_ERROR;
2874
2875	m = gfc_match (target: " forall");
2876	if (m != MATCH_YES)
2877	return m;
2878
2879	m = match_forall_header (phead: &head, mask: &mask);
2880	if (m == MATCH_ERROR)
2881	goto cleanup;
2882	if (m == MATCH_NO)
2883	goto syntax;
2884
2885	if (gfc_match_eos () == MATCH_YES)
2886	{
2887	*st = ST_FORALL_BLOCK;
2888	new_st.op = EXEC_FORALL;
2889	new_st.expr1 = mask;
2890	new_st.ext.concur.forall_iterator = head;
2891	return MATCH_YES;
2892	}
2893
2894	m = gfc_match_assignment ();
2895	if (m == MATCH_ERROR)
2896	goto cleanup;
2897	if (m == MATCH_NO)
2898	{
2899	m = gfc_match_pointer_assignment ();
2900	if (m == MATCH_ERROR)
2901	goto cleanup;
2902	if (m == MATCH_NO)
2903	goto syntax;
2904	}
2905
2906	c = XCNEW (gfc_code);
2907	*c = new_st;
2908	c->loc = gfc_current_locus;
2909
2910	gfc_clear_new_st ();
2911	new_st.op = EXEC_FORALL;
2912	new_st.expr1 = mask;
2913	new_st.ext.concur.forall_iterator = head;
2914	new_st.block = gfc_get_code (EXEC_FORALL);
2915	new_st.block->next = c;
2916
2917	*st = ST_FORALL;
2918	return MATCH_YES;
2919
2920	syntax:
2921	gfc_syntax_error (ST_FORALL);
2922
2923	cleanup:
2924	gfc_free_forall_iterator (iter: head);
2925	gfc_free_expr (mask);
2926	gfc_free_statements (c);
2927	return MATCH_NO;
2928	}
2929
2930
2931	/* Match a DO statement. */
2932
2933	match
2934	gfc_match_do (void)
2935	{
2936	gfc_iterator iter, *ip;
2937	locus old_loc;
2938	gfc_st_label *label;
2939	match m;
2940
2941	old_loc = gfc_current_locus;
2942
2943	memset (s: &iter, c: '\0', n: sizeof (gfc_iterator));
2944	label = NULL;
2945
2946	m = gfc_match_label ();
2947	if (m == MATCH_ERROR)
2948	return m;
2949
2950	if (gfc_match (target: " do") != MATCH_YES)
2951	return MATCH_NO;
2952
2953	m = gfc_match_st_label (label: &label);
2954	if (m == MATCH_ERROR)
2955	goto cleanup;
2956
2957	/* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2958
2959	if (gfc_match_eos () == MATCH_YES)
2960	{
2961	iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true);
2962	new_st.op = EXEC_DO_WHILE;
2963	goto done;
2964	}
2965
2966	/* Match an optional comma, if no comma is found, a space is obligatory. */
2967	if (gfc_match_char (c: ',') != MATCH_YES && gfc_match (target: "% ") != MATCH_YES)
2968	return MATCH_NO;
2969
2970	/* Check for balanced parens. */
2971
2972	if (gfc_match_parens () == MATCH_ERROR)
2973	return MATCH_ERROR;
2974
2975	/* Handle DO CONCURRENT construct. */
2976
2977	if (gfc_match (target: " concurrent") == MATCH_YES)
2978	{
2979	gfc_forall_iterator *head = NULL;
2980	gfc_expr_list *local = NULL;
2981	gfc_expr_list *local_tail = NULL;
2982	gfc_expr_list *local_init = NULL;
2983	gfc_expr_list *local_init_tail = NULL;
2984	gfc_expr_list *shared = NULL;
2985	gfc_expr_list *shared_tail = NULL;
2986	gfc_expr_list *reduce = NULL;
2987	gfc_expr_list *reduce_tail = NULL;
2988	bool default_none = false;
2989	gfc_expr *mask;
2990
2991	if (!gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT construct at %C"))
2992	return MATCH_ERROR;
2993
2994
2995	mask = NULL;
2996	head = NULL;
2997	m = match_forall_header (phead: &head, mask: &mask);
2998
2999	if (m == MATCH_NO)
3000	goto match_do_loop;
3001	if (m == MATCH_ERROR)
3002	goto concurr_cleanup;
3003
3004	while (true)
3005	{
3006	gfc_gobble_whitespace ();
3007	locus where = gfc_current_locus;
3008
3009	if (gfc_match_eos () == MATCH_YES)
3010	goto concurr_ok;
3011
3012	else if (gfc_match (target: "local ( ") == MATCH_YES)
3013	{
3014	gfc_expr *e;
3015	while (true)
3016	{
3017	if (gfc_match_variable (&e, 0) != MATCH_YES)
3018	goto concurr_cleanup;
3019
3020	if (local == NULL)
3021	local = local_tail = gfc_get_expr_list ();
3022
3023	else
3024	{
3025	local_tail->next = gfc_get_expr_list ();
3026	local_tail = local_tail->next;
3027	}
3028	local_tail->expr = e;
3029
3030	if (gfc_match_char (c: ',') == MATCH_YES)
3031	continue;
3032	if (gfc_match_char (c: ')') == MATCH_YES)
3033	break;
3034	goto concurr_cleanup;
3035	}
3036	}
3037
3038	else if (gfc_match (target: "local_init ( ") == MATCH_YES)
3039	{
3040	gfc_expr *e;
3041
3042	while (true)
3043	{
3044	if (gfc_match_variable (&e, 0) != MATCH_YES)
3045	goto concurr_cleanup;
3046
3047	if (local_init == NULL)
3048	local_init = local_init_tail = gfc_get_expr_list ();
3049
3050	else
3051	{
3052	local_init_tail->next = gfc_get_expr_list ();
3053	local_init_tail = local_init_tail->next;
3054	}
3055	local_init_tail->expr = e;
3056
3057	if (gfc_match_char (c: ',') == MATCH_YES)
3058	continue;
3059	if (gfc_match_char (c: ')') == MATCH_YES)
3060	break;
3061	goto concurr_cleanup;
3062	}
3063	}
3064
3065	else if (gfc_match (target: "shared ( ") == MATCH_YES)
3066	{
3067	gfc_expr *e;
3068	while (true)
3069	{
3070	if (gfc_match_variable (&e, 0) != MATCH_YES)
3071	goto concurr_cleanup;
3072
3073	if (shared == NULL)
3074	shared = shared_tail = gfc_get_expr_list ();
3075
3076	else
3077	{
3078	shared_tail->next = gfc_get_expr_list ();
3079	shared_tail = shared_tail->next;
3080	}
3081	shared_tail->expr = e;
3082
3083	if (gfc_match_char (c: ',') == MATCH_YES)
3084	continue;
3085	if (gfc_match_char (c: ')') == MATCH_YES)
3086	break;
3087	goto concurr_cleanup;
3088	}
3089	}
3090
3091	else if (gfc_match (target: "default (none)") == MATCH_YES)
3092	{
3093	if (default_none)
3094	{
3095	gfc_error ("DEFAULT (NONE) specified more than once in DO "
3096	"CONCURRENT at %C");
3097	goto concurr_cleanup;
3098	}
3099	default_none = true;
3100	}
3101
3102	else if (gfc_match (target: "reduce ( ") == MATCH_YES)
3103	{
3104	gfc_expr *reduction_expr;
3105	where = gfc_current_locus;
3106
3107	if (gfc_match_char (c: '+') == MATCH_YES)
3108	reduction_expr = gfc_get_operator_expr (&where,
3109	INTRINSIC_PLUS,
3110	NULL, NULL);
3111
3112	else if (gfc_match_char (c: '*') == MATCH_YES)
3113	reduction_expr = gfc_get_operator_expr (&where,
3114	INTRINSIC_TIMES,
3115	NULL, NULL);
3116
3117	else if (gfc_match (target: ".and.") == MATCH_YES)
3118	reduction_expr = gfc_get_operator_expr (&where,
3119	INTRINSIC_AND,
3120	NULL, NULL);
3121
3122	else if (gfc_match (target: ".or.") == MATCH_YES)
3123	reduction_expr = gfc_get_operator_expr (&where,
3124	INTRINSIC_OR,
3125	NULL, NULL);
3126
3127	else if (gfc_match (target: ".eqv.") == MATCH_YES)
3128	reduction_expr = gfc_get_operator_expr (&where,
3129	INTRINSIC_EQV,
3130	NULL, NULL);
3131
3132	else if (gfc_match (target: ".neqv.") == MATCH_YES)
3133	reduction_expr = gfc_get_operator_expr (&where,
3134	INTRINSIC_NEQV,
3135	NULL, NULL);
3136
3137	else if (gfc_match (target: "min") == MATCH_YES)
3138	{
3139	reduction_expr = gfc_get_expr ();
3140	reduction_expr->expr_type = EXPR_FUNCTION;
3141	reduction_expr->value.function.isym
3142	= gfc_intrinsic_function_by_id (GFC_ISYM_MIN);
3143	reduction_expr->where = where;
3144	}
3145
3146	else if (gfc_match (target: "max") == MATCH_YES)
3147	{
3148	reduction_expr = gfc_get_expr ();
3149	reduction_expr->expr_type = EXPR_FUNCTION;
3150	reduction_expr->value.function.isym
3151	= gfc_intrinsic_function_by_id (GFC_ISYM_MAX);
3152	reduction_expr->where = where;
3153	}
3154
3155	else if (gfc_match (target: "iand") == MATCH_YES)
3156	{
3157	reduction_expr = gfc_get_expr ();
3158	reduction_expr->expr_type = EXPR_FUNCTION;
3159	reduction_expr->value.function.isym
3160	= gfc_intrinsic_function_by_id (GFC_ISYM_IAND);
3161	reduction_expr->where = where;
3162	}
3163
3164	else if (gfc_match (target: "ior") == MATCH_YES)
3165	{
3166	reduction_expr = gfc_get_expr ();
3167	reduction_expr->expr_type = EXPR_FUNCTION;
3168	reduction_expr->value.function.isym
3169	= gfc_intrinsic_function_by_id (GFC_ISYM_IOR);
3170	reduction_expr->where = where;
3171	}
3172
3173	else if (gfc_match (target: "ieor") == MATCH_YES)
3174	{
3175	reduction_expr = gfc_get_expr ();
3176	reduction_expr->expr_type = EXPR_FUNCTION;
3177	reduction_expr->value.function.isym
3178	= gfc_intrinsic_function_by_id (GFC_ISYM_IEOR);
3179	reduction_expr->where = where;
3180	}
3181
3182	else
3183	{
3184	gfc_error ("Expected reduction operator or function name "
3185	"at %C");
3186	goto concurr_cleanup;
3187	}
3188
3189	if (!reduce)
3190	{
3191	reduce = reduce_tail = gfc_get_expr_list ();
3192	}
3193	else
3194	{
3195	reduce_tail->next = gfc_get_expr_list ();
3196	reduce_tail = reduce_tail->next;
3197	}
3198	reduce_tail->expr = reduction_expr;
3199
3200	gfc_gobble_whitespace ();
3201
3202	if (gfc_match_char (c: ':') != MATCH_YES)
3203	{
3204	gfc_error ("Expected %<:%> at %C");
3205	goto concurr_cleanup;
3206	}
3207
3208	while (true)
3209	{
3210	gfc_expr *reduction_expr;
3211
3212	if (gfc_match_variable (&reduction_expr, 0) != MATCH_YES)
3213	{
3214	gfc_error ("Expected variable name in reduction list "
3215	"at %C");
3216	goto concurr_cleanup;
3217	}
3218
3219	if (reduce == NULL)
3220	reduce = reduce_tail = gfc_get_expr_list ();
3221	else
3222	{
3223	reduce_tail = reduce_tail->next = gfc_get_expr_list ();
3224	reduce_tail->expr = reduction_expr;
3225	}
3226
3227	if (gfc_match_char (c: ',') == MATCH_YES)
3228	continue;
3229	else if (gfc_match_char (c: ')') == MATCH_YES)
3230	break;
3231	else
3232	{
3233	gfc_error ("Expected ',' or ')' in reduction list "
3234	"at %C");
3235	goto concurr_cleanup;
3236	}
3237	}
3238
3239	if (!gfc_notify_std (GFC_STD_F2023, "REDUCE locality spec at "
3240	"%L", &where))
3241	goto concurr_cleanup;
3242	}
3243	else
3244	goto concurr_cleanup;
3245
3246	if (!gfc_notify_std (GFC_STD_F2018, "Locality spec at %L",
3247	&gfc_current_locus))
3248	goto concurr_cleanup;
3249	}
3250
3251	if (m == MATCH_NO)
3252	return m;
3253	if (m == MATCH_ERROR)
3254	goto concurr_cleanup;
3255
3256	if (gfc_match_eos () != MATCH_YES)
3257	goto concurr_cleanup;
3258
3259	concurr_ok:
3260	if (label != NULL
3261	&& !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
3262	goto concurr_cleanup;
3263
3264	new_st.label1 = label;
3265	new_st.op = EXEC_DO_CONCURRENT;
3266	new_st.expr1 = mask;
3267	new_st.ext.concur.forall_iterator = head;
3268	new_st.ext.concur.locality[LOCALITY_LOCAL] = local;
3269	new_st.ext.concur.locality[LOCALITY_LOCAL_INIT] = local_init;
3270	new_st.ext.concur.locality[LOCALITY_SHARED] = shared;
3271	new_st.ext.concur.locality[LOCALITY_REDUCE] = reduce;
3272	new_st.ext.concur.default_none = default_none;
3273
3274	return MATCH_YES;
3275
3276	concurr_cleanup:
3277	gfc_free_expr (mask);
3278	gfc_free_forall_iterator (iter: head);
3279	gfc_free_expr_list (local);
3280	gfc_free_expr_list (local_init);
3281	gfc_free_expr_list (shared);
3282	gfc_free_expr_list (reduce);
3283
3284	if (!gfc_error_check ())
3285	gfc_syntax_error (ST_DO);
3286
3287	return MATCH_ERROR;
3288	}
3289
3290	/* See if we have a DO WHILE. */
3291	if (gfc_match (target: " while ( %e )%t", &iter.end) == MATCH_YES)
3292	{
3293	new_st.op = EXEC_DO_WHILE;
3294	goto done;
3295	}
3296
3297	match_do_loop:
3298	/* The abortive DO WHILE may have done something to the symbol
3299	table, so we start over. */
3300	gfc_undo_symbols ();
3301	gfc_current_locus = old_loc;
3302
3303	gfc_match_label (); /* This won't error. */
3304	gfc_match (target: " do "); /* This will work. */
3305
3306	gfc_match_st_label (label: &label); /* Can't error out. */
3307	gfc_match_char (c: ','); /* Optional comma. */
3308
3309	m = gfc_match_iterator (iter: &iter, init_flag: 0);
3310	if (m == MATCH_NO)
3311	return MATCH_NO;
3312	if (m == MATCH_ERROR)
3313	goto cleanup;
3314
3315	iter.var->symtree->n.sym->attr.implied_index = 0;
3316	gfc_check_do_variable (iter.var->symtree);
3317
3318	if (gfc_match_eos () != MATCH_YES)
3319	{
3320	gfc_syntax_error (ST_DO);
3321	goto cleanup;
3322	}
3323
3324	new_st.op = EXEC_DO;
3325
3326	done:
3327	if (label != NULL
3328	&& !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
3329	goto cleanup;
3330
3331	new_st.label1 = label;
3332
3333	if (new_st.op == EXEC_DO_WHILE)
3334	new_st.expr1 = iter.end;
3335	else
3336	{
3337	new_st.ext.iterator = ip = gfc_get_iterator ();
3338	*ip = iter;
3339	}
3340
3341	return MATCH_YES;
3342
3343	cleanup:
3344	gfc_free_iterator (iter: &iter, flag: 0);
3345
3346	return MATCH_ERROR;
3347	}
3348
3349
3350	/* Match an EXIT or CYCLE statement. */
3351
3352	static match
3353	match_exit_cycle (gfc_statement st, gfc_exec_op op)
3354	{
3355	gfc_state_data *p, *o;
3356	gfc_symbol *sym;
3357	match m;
3358	int cnt;
3359
3360	if (gfc_match_eos () == MATCH_YES)
3361	sym = NULL;
3362	else
3363	{
3364	char name[GFC_MAX_SYMBOL_LEN + 1];
3365	gfc_symtree* stree;
3366
3367	m = gfc_match (target: "% %n%t", name);
3368	if (m == MATCH_ERROR)
3369	return MATCH_ERROR;
3370	if (m == MATCH_NO)
3371	{
3372	gfc_syntax_error (st);
3373	return MATCH_ERROR;
3374	}
3375
3376	/* Find the corresponding symbol. If there's a BLOCK statement
3377	between here and the label, it is not in gfc_current_ns but a parent
3378	namespace! */
3379	stree = gfc_find_symtree_in_proc (name, gfc_current_ns);
3380	if (!stree)
3381	{
3382	gfc_error ("Name %qs in %s statement at %C is unknown",
3383	name, gfc_ascii_statement (st));
3384	return MATCH_ERROR;
3385	}
3386
3387	sym = stree->n.sym;
3388	if (sym->attr.flavor != FL_LABEL)
3389	{
3390	gfc_error ("Name %qs in %s statement at %C is not a construct name",
3391	name, gfc_ascii_statement (st));
3392	return MATCH_ERROR;
3393	}
3394	}
3395
3396	/* Find the loop specified by the label (or lack of a label). */
3397	for (o = NULL, p = gfc_state_stack; p; p = p->previous)
3398	if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
3399	o = p;
3400	else if (p->state == COMP_CRITICAL)
3401	{
3402	gfc_error("%s statement at %C leaves CRITICAL construct",
3403	gfc_ascii_statement (st));
3404	return MATCH_ERROR;
3405	}
3406	else if (p->state == COMP_DO_CONCURRENT
3407	&& (op == EXEC_EXIT || (sym && sym != p->sym)))
3408	{
3409	/* F2008, C821 & C845. */
3410	gfc_error("%s statement at %C leaves DO CONCURRENT construct",
3411	gfc_ascii_statement (st));
3412	return MATCH_ERROR;
3413	}
3414	else if ((sym && sym == p->sym)
3415	|| (!sym && (p->state == COMP_DO
3416	|| p->state == COMP_DO_CONCURRENT)))
3417	break;
3418
3419	if (p == NULL)
3420	{
3421	if (sym == NULL)
3422	gfc_error ("%s statement at %C is not within a construct",
3423	gfc_ascii_statement (st));
3424	else
3425	gfc_error ("%s statement at %C is not within construct %qs",
3426	gfc_ascii_statement (st), sym->name);
3427
3428	return MATCH_ERROR;
3429	}
3430
3431	/* Special checks for EXIT from non-loop constructs. */
3432	switch (p->state)
3433	{
3434	case COMP_DO:
3435	case COMP_DO_CONCURRENT:
3436	break;
3437
3438	case COMP_CRITICAL:
3439	/* This is already handled above. */
3440	gcc_unreachable ();
3441
3442	case COMP_ASSOCIATE:
3443	case COMP_BLOCK:
3444	case COMP_CHANGE_TEAM:
3445	case COMP_IF:
3446	case COMP_SELECT:
3447	case COMP_SELECT_TYPE:
3448	case COMP_SELECT_RANK:
3449	gcc_assert (sym);
3450	if (op == EXEC_CYCLE)
3451	{
3452	gfc_error ("CYCLE statement at %C is not applicable to non-loop"
3453	" construct %qs", sym->name);
3454	return MATCH_ERROR;
3455	}
3456	gcc_assert (op == EXEC_EXIT);
3457	if (!gfc_notify_std (GFC_STD_F2008, "EXIT statement with no"
3458	" do-construct-name at %C"))
3459	return MATCH_ERROR;
3460	break;
3461
3462	default:
3463	gfc_error ("%s statement at %C is not applicable to construct %qs",
3464	gfc_ascii_statement (st), sym->name);
3465	return MATCH_ERROR;
3466	}
3467
3468	if (o != NULL)
3469	{
3470	gfc_error (is_oacc (p)
3471	? G_("%s statement at %C leaving OpenACC structured block")
3472	: G_("%s statement at %C leaving OpenMP structured block"),
3473	gfc_ascii_statement (st));
3474	return MATCH_ERROR;
3475	}
3476
3477	for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++)
3478	o = o->previous;
3479
3480	int count = 1;
3481	if (cnt > 0
3482	&& o != NULL
3483	&& o->state == COMP_OMP_STRUCTURED_BLOCK)
3484	switch (o->head->op)
3485	{
3486	case EXEC_OACC_LOOP:
3487	case EXEC_OACC_KERNELS_LOOP:
3488	case EXEC_OACC_PARALLEL_LOOP:
3489	case EXEC_OACC_SERIAL_LOOP:
3490	gcc_assert (o->head->next != NULL
3491	&& (o->head->next->op == EXEC_DO
3492	|| o->head->next->op == EXEC_DO_WHILE)
3493	&& o->previous != NULL
3494	&& o->previous->tail->op == o->head->op);
3495	if (o->previous->tail->ext.omp_clauses != NULL)
3496	{
3497	/* Both collapsed and tiled loops are lowered the same way, but are
3498	not compatible. In gfc_trans_omp_do, the tile is prioritized. */
3499	if (o->previous->tail->ext.omp_clauses->tile_list)
3500	{
3501	count = 0;
3502	gfc_expr_list *el
3503	= o->previous->tail->ext.omp_clauses->tile_list;
3504	for ( ; el; el = el->next)
3505	++count;
3506	}
3507	else if (o->previous->tail->ext.omp_clauses->collapse > 1)
3508	count = o->previous->tail->ext.omp_clauses->collapse;
3509	}
3510	if (st == ST_EXIT && cnt <= count)
3511	{
3512	gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
3513	return MATCH_ERROR;
3514	}
3515	if (st == ST_CYCLE && cnt < count)
3516	{
3517	gfc_error (o->previous->tail->ext.omp_clauses->tile_list
3518	? G_("CYCLE statement at %C to non-innermost tiled "
3519	"!$ACC LOOP loop")
3520	: G_("CYCLE statement at %C to non-innermost collapsed "
3521	"!$ACC LOOP loop"));
3522	return MATCH_ERROR;
3523	}
3524	break;
3525	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3526	case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
3527	case EXEC_OMP_TARGET_SIMD:
3528	case EXEC_OMP_TASKLOOP_SIMD:
3529	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
3530	case EXEC_OMP_MASTER_TASKLOOP_SIMD:
3531	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
3532	case EXEC_OMP_MASKED_TASKLOOP_SIMD:
3533	case EXEC_OMP_PARALLEL_DO_SIMD:
3534	case EXEC_OMP_DISTRIBUTE_SIMD:
3535	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
3536	case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
3537	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
3538	case EXEC_OMP_LOOP:
3539	case EXEC_OMP_PARALLEL_LOOP:
3540	case EXEC_OMP_TEAMS_LOOP:
3541	case EXEC_OMP_TARGET_PARALLEL_LOOP:
3542	case EXEC_OMP_TARGET_TEAMS_LOOP:
3543	case EXEC_OMP_DO:
3544	case EXEC_OMP_PARALLEL_DO:
3545	case EXEC_OMP_SIMD:
3546	case EXEC_OMP_DO_SIMD:
3547	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
3548	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
3549	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
3550	case EXEC_OMP_TARGET_PARALLEL_DO:
3551	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3552
3553	gcc_assert (o->head->next != NULL
3554	&& (o->head->next->op == EXEC_DO
3555	|| o->head->next->op == EXEC_DO_WHILE)
3556	&& o->previous != NULL
3557	&& o->previous->tail->op == o->head->op);
3558	if (o->previous->tail->ext.omp_clauses != NULL)
3559	{
3560	if (o->previous->tail->ext.omp_clauses->collapse > 1)
3561	count = o->previous->tail->ext.omp_clauses->collapse;
3562	if (o->previous->tail->ext.omp_clauses->orderedc)
3563	count = o->previous->tail->ext.omp_clauses->orderedc;
3564	}
3565	if (st == ST_EXIT && cnt <= count)
3566	{
3567	gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
3568	return MATCH_ERROR;
3569	}
3570	if (st == ST_CYCLE && cnt < count)
3571	{
3572	gfc_error ("CYCLE statement at %C to non-innermost collapsed "
3573	"!$OMP DO loop");
3574	return MATCH_ERROR;
3575	}
3576	break;
3577	default:
3578	break;
3579	}
3580
3581	/* Save the first statement in the construct - needed by the backend. */
3582	new_st.ext.which_construct = p->construct;
3583
3584	new_st.op = op;
3585
3586	return MATCH_YES;
3587	}
3588
3589
3590	/* Match the EXIT statement. */
3591
3592	match
3593	gfc_match_exit (void)
3594	{
3595	return match_exit_cycle (st: ST_EXIT, op: EXEC_EXIT);
3596	}
3597
3598
3599	/* Match the CYCLE statement. */
3600
3601	match
3602	gfc_match_cycle (void)
3603	{
3604	return match_exit_cycle (st: ST_CYCLE, op: EXEC_CYCLE);
3605	}
3606
3607
3608	/* Match a stop-code after an (ERROR) STOP or PAUSE statement. The
3609	requirements for a stop-code differ in the standards.
3610
3611	Fortran 95 has
3612
3613	R840 stop-stmt is STOP [ stop-code ]
3614	R841 stop-code is scalar-char-constant
3615	or digit [ digit [ digit [ digit [ digit ] ] ] ]
3616
3617	Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850.
3618	Fortran 2008 has
3619
3620	R855 stop-stmt is STOP [ stop-code ]
3621	R856 allstop-stmt is ALL STOP [ stop-code ]
3622	R857 stop-code is scalar-default-char-constant-expr
3623	or scalar-int-constant-expr
3624	Fortran 2018 has
3625
3626	R1160 stop-stmt is STOP [ stop-code ] [ , QUIET = scalar-logical-expr]
3627	R1161 error-stop-stmt is
3628	ERROR STOP [ stop-code ] [ , QUIET = scalar-logical-expr]
3629	R1162 stop-code is scalar-default-char-expr
3630	or scalar-int-expr
3631
3632	For free-form source code, all standards contain a statement of the form:
3633
3634	A blank shall be used to separate names, constants, or labels from
3635	adjacent keywords, names, constants, or labels.
3636
3637	A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003,
3638
3639	STOP123
3640
3641	is valid, but it is invalid Fortran 2008. */
3642
3643	static match
3644	gfc_match_stopcode (gfc_statement st)
3645	{
3646	gfc_expr *e = NULL;
3647	gfc_expr *quiet = NULL;
3648	match m;
3649	bool f95, f03, f08;
3650	char c;
3651
3652	/* Set f95 for -std=f95. */
3653	f95 = (gfc_option.allow_std == GFC_STD_OPT_F95);
3654
3655	/* Set f03 for -std=f2003. */
3656	f03 = (gfc_option.allow_std == GFC_STD_OPT_F03);
3657
3658	/* Set f08 for -std=f2008. */
3659	f08 = (gfc_option.allow_std == GFC_STD_OPT_F08);
3660
3661	/* Plain STOP statement? */
3662	if (gfc_match_eos () == MATCH_YES)
3663	goto checks;
3664
3665	/* Look for a blank between STOP and the stop-code for F2008 or later.
3666	But allow for F2018's ,QUIET= specifier. */
3667	c = gfc_peek_ascii_char ();
3668
3669	if (gfc_current_form != FORM_FIXED && !(f95 || f03) && c != ',')
3670	{
3671	/* Look for end-of-statement. There is no stop-code. */
3672	if (c == '\n' || c == '!' || c == ';')
3673	goto done;
3674
3675	if (c != ' ')
3676	{
3677	gfc_error ("Blank required in %s statement near %C",
3678	gfc_ascii_statement (st));
3679	return MATCH_ERROR;
3680	}
3681	}
3682
3683	if (c == ' ')
3684	{
3685	gfc_gobble_whitespace ();
3686	c = gfc_peek_ascii_char ();
3687	}
3688	if (c != ',')
3689	{
3690	int stopcode;
3691	locus old_locus;
3692
3693	/* First look for the F95 or F2003 digit [...] construct. */
3694	old_locus = gfc_current_locus;
3695	m = gfc_match_small_int (value: &stopcode);
3696	if (m == MATCH_YES && (f95 || f03))
3697	{
3698	if (stopcode < 0)
3699	{
3700	gfc_error ("STOP code at %C cannot be negative");
3701	return MATCH_ERROR;
3702	}
3703
3704	if (stopcode > 99999)
3705	{
3706	gfc_error ("STOP code at %C contains too many digits");
3707	return MATCH_ERROR;
3708	}
3709	}
3710
3711	/* Reset the locus and now load gfc_expr. */
3712	gfc_current_locus = old_locus;
3713	m = gfc_match_expr (&e);
3714	if (m == MATCH_ERROR)
3715	goto cleanup;
3716	if (m == MATCH_NO)
3717	goto syntax;
3718	}
3719
3720	if (gfc_match (target: " , quiet = %e", &quiet) == MATCH_YES)
3721	{
3722	if (!gfc_notify_std (GFC_STD_F2018, "QUIET= specifier for %s at %L",
3723	gfc_ascii_statement (st), &quiet->where))
3724	goto cleanup;
3725	}
3726
3727	if (gfc_match_eos () != MATCH_YES)
3728	goto syntax;
3729
3730	checks:
3731
3732	if (gfc_pure (NULL))
3733	{
3734	if (st == ST_ERROR_STOP)
3735	{
3736	if (!gfc_notify_std (GFC_STD_F2018, "%s statement at %C in PURE "
3737	"procedure", gfc_ascii_statement (st)))
3738	goto cleanup;
3739	}
3740	else
3741	{
3742	gfc_error ("%s statement not allowed in PURE procedure at %C",
3743	gfc_ascii_statement (st));
3744	goto cleanup;
3745	}
3746	}
3747
3748	gfc_unset_implicit_pure (NULL);
3749
3750	if (st == ST_STOP && gfc_find_state (COMP_CRITICAL))
3751	{
3752	gfc_error ("Image control statement STOP at %C in CRITICAL block");
3753	goto cleanup;
3754	}
3755	if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT))
3756	{
3757	gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
3758	goto cleanup;
3759	}
3760
3761	if (e != NULL)
3762	{
3763	if (!gfc_simplify_expr (e, 0))
3764	goto cleanup;
3765
3766	/* Test for F95 and F2003 style STOP stop-code. */
3767	if (e->expr_type != EXPR_CONSTANT && (f95 || f03))
3768	{
3769	gfc_error ("STOP code at %L must be a scalar CHARACTER constant "
3770	"or digit[digit[digit[digit[digit]]]]", &e->where);
3771	goto cleanup;
3772	}
3773
3774	/* Use the machinery for an initialization expression to reduce the
3775	stop-code to a constant. */
3776	gfc_reduce_init_expr (expr: e);
3777
3778	/* Test for F2008 style STOP stop-code. */
3779	if (e->expr_type != EXPR_CONSTANT && f08)
3780	{
3781	gfc_error ("STOP code at %L must be a scalar default CHARACTER or "
3782	"INTEGER constant expression", &e->where);
3783	goto cleanup;
3784	}
3785
3786	if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
3787	{
3788	gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
3789	&e->where);
3790	goto cleanup;
3791	}
3792
3793	if (e->rank != 0)
3794	{
3795	gfc_error ("STOP code at %L must be scalar", &e->where);
3796	goto cleanup;
3797	}
3798
3799	if (e->ts.type == BT_CHARACTER
3800	&& e->ts.kind != gfc_default_character_kind)
3801	{
3802	gfc_error ("STOP code at %L must be default character KIND=%d",
3803	&e->where, (int) gfc_default_character_kind);
3804	goto cleanup;
3805	}
3806
3807	if (e->ts.type == BT_INTEGER && e->ts.kind != gfc_default_integer_kind
3808	&& !gfc_notify_std (GFC_STD_F2018,
3809	"STOP code at %L must be default integer KIND=%d",
3810	&e->where, (int) gfc_default_integer_kind))
3811	goto cleanup;
3812	}
3813
3814	if (quiet != NULL)
3815	{
3816	if (!gfc_simplify_expr (quiet, 0))
3817	goto cleanup;
3818
3819	if (quiet->rank != 0)
3820	{
3821	gfc_error ("QUIET specifier at %L must be a scalar LOGICAL",
3822	&quiet->where);
3823	goto cleanup;
3824	}
3825	}
3826
3827	done:
3828
3829	switch (st)
3830	{
3831	case ST_STOP:
3832	new_st.op = EXEC_STOP;
3833	break;
3834	case ST_ERROR_STOP:
3835	new_st.op = EXEC_ERROR_STOP;
3836	break;
3837	case ST_PAUSE:
3838	new_st.op = EXEC_PAUSE;
3839	break;
3840	default:
3841	gcc_unreachable ();
3842	}
3843
3844	new_st.expr1 = e;
3845	new_st.expr2 = quiet;
3846	new_st.ext.stop_code = -1;
3847
3848	return MATCH_YES;
3849
3850	syntax:
3851	gfc_syntax_error (st);
3852
3853	cleanup:
3854
3855	gfc_free_expr (e);
3856	gfc_free_expr (quiet);
3857	return MATCH_ERROR;
3858	}
3859
3860
3861	/* Match the (deprecated) PAUSE statement. */
3862
3863	match
3864	gfc_match_pause (void)
3865	{
3866	match m;
3867
3868	m = gfc_match_stopcode (st: ST_PAUSE);
3869	if (m == MATCH_YES)
3870	{
3871	if (!gfc_notify_std (GFC_STD_F95_DEL, "PAUSE statement at %C"))
3872	m = MATCH_ERROR;
3873	}
3874	return m;
3875	}
3876
3877
3878	/* Match the STOP statement. */
3879
3880	match
3881	gfc_match_stop (void)
3882	{
3883	return gfc_match_stopcode (st: ST_STOP);
3884	}
3885
3886
3887	/* Match the ERROR STOP statement. */
3888
3889	match
3890	gfc_match_error_stop (void)
3891	{
3892	if (!gfc_notify_std (GFC_STD_F2008, "ERROR STOP statement at %C"))
3893	return MATCH_ERROR;
3894
3895	return gfc_match_stopcode (st: ST_ERROR_STOP);
3896	}
3897
3898	/* Match EVENT POST/WAIT statement. Syntax:
3899	EVENT POST ( event-variable [, sync-stat-list] )
3900	EVENT WAIT ( event-variable [, wait-spec-list] )
3901	with
3902	wait-spec-list is sync-stat-list or until-spec
3903	until-spec is UNTIL_COUNT = scalar-int-expr
3904	sync-stat is STAT= or ERRMSG=. */
3905
3906	static match
3907	event_statement (gfc_statement st)
3908	{
3909	match m;
3910	gfc_expr *tmp, *eventvar, *until_count, *stat, *errmsg;
3911	bool saw_until_count, saw_stat, saw_errmsg;
3912
3913	tmp = eventvar = until_count = stat = errmsg = NULL;
3914	saw_until_count = saw_stat = saw_errmsg = false;
3915
3916	if (gfc_pure (NULL))
3917	{
3918	gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
3919	st == ST_EVENT_POST ? "POST" : "WAIT");
3920	return MATCH_ERROR;
3921	}
3922
3923	gfc_unset_implicit_pure (NULL);
3924
3925	if (flag_coarray == GFC_FCOARRAY_NONE)
3926	{
3927	gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3928	return MATCH_ERROR;
3929	}
3930
3931	if (gfc_find_state (COMP_CRITICAL))
3932	{
3933	gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
3934	st == ST_EVENT_POST ? "POST" : "WAIT");
3935	return MATCH_ERROR;
3936	}
3937
3938	if (gfc_find_state (COMP_DO_CONCURRENT))
3939	{
3940	gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
3941	"block", st == ST_EVENT_POST ? "POST" : "WAIT");
3942	return MATCH_ERROR;
3943	}
3944
3945	if (gfc_match_char (c: '(') != MATCH_YES)
3946	goto syntax;
3947
3948	if (gfc_match (target: "%e", &eventvar) != MATCH_YES)
3949	goto syntax;
3950	m = gfc_match_char (c: ',');
3951	if (m == MATCH_ERROR)
3952	goto syntax;
3953	if (m == MATCH_NO)
3954	{
3955	m = gfc_match_char (c: ')');
3956	if (m == MATCH_YES)
3957	goto done;
3958	goto syntax;
3959	}
3960
3961	for (;;)
3962	{
3963	m = gfc_match (target: " stat = %v", &tmp);
3964	if (m == MATCH_ERROR)
3965	goto syntax;
3966	if (m == MATCH_YES)
3967	{
3968	if (saw_stat)
3969	{
3970	gfc_error ("Redundant STAT tag found at %L", &tmp->where);
3971	goto cleanup;
3972	}
3973	stat = tmp;
3974	saw_stat = true;
3975
3976	m = gfc_match_char (c: ',');
3977	if (m == MATCH_YES)
3978	continue;
3979
3980	tmp = NULL;
3981	break;
3982	}
3983
3984	m = gfc_match (target: " errmsg = %v", &tmp);
3985	if (m == MATCH_ERROR)
3986	goto syntax;
3987	if (m == MATCH_YES)
3988	{
3989	if (saw_errmsg)
3990	{
3991	gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
3992	goto cleanup;
3993	}
3994	errmsg = tmp;
3995	saw_errmsg = true;
3996
3997	m = gfc_match_char (c: ',');
3998	if (m == MATCH_YES)
3999	continue;
4000
4001	tmp = NULL;
4002	break;
4003	}
4004
4005	m = gfc_match (target: " until_count = %e", &tmp);
4006	if (m == MATCH_ERROR || st == ST_EVENT_POST)
4007	goto syntax;
4008	if (m == MATCH_YES)
4009	{
4010	if (saw_until_count)
4011	{
4012	gfc_error ("Redundant UNTIL_COUNT tag found at %L",
4013	&tmp->where);
4014	goto cleanup;
4015	}
4016	until_count = tmp;
4017	saw_until_count = true;
4018
4019	m = gfc_match_char (c: ',');
4020	if (m == MATCH_YES)
4021	continue;
4022
4023	tmp = NULL;
4024	break;
4025	}
4026
4027	break;
4028	}
4029
4030	if (m == MATCH_ERROR)
4031	goto syntax;
4032
4033	if (gfc_match (target: " )%t") != MATCH_YES)
4034	goto syntax;
4035
4036	done:
4037	switch (st)
4038	{
4039	case ST_EVENT_POST:
4040	new_st.op = EXEC_EVENT_POST;
4041	break;
4042	case ST_EVENT_WAIT:
4043	new_st.op = EXEC_EVENT_WAIT;
4044	break;
4045	default:
4046	gcc_unreachable ();
4047	}
4048
4049	new_st.expr1 = eventvar;
4050	new_st.expr2 = stat;
4051	new_st.expr3 = errmsg;
4052	new_st.expr4 = until_count;
4053
4054	return MATCH_YES;
4055
4056	syntax:
4057	gfc_syntax_error (st);
4058
4059	cleanup:
4060	if (until_count != tmp)
4061	gfc_free_expr (until_count);
4062	if (errmsg != tmp)
4063	gfc_free_expr (errmsg);
4064	if (stat != tmp)
4065	gfc_free_expr (stat);
4066
4067	gfc_free_expr (tmp);
4068	gfc_free_expr (eventvar);
4069
4070	return MATCH_ERROR;
4071
4072	}
4073
4074
4075	match
4076	gfc_match_event_post (void)
4077	{
4078	if (!gfc_notify_std (GFC_STD_F2018, "EVENT POST statement at %C"))
4079	return MATCH_ERROR;
4080
4081	return event_statement (st: ST_EVENT_POST);
4082	}
4083
4084
4085	match
4086	gfc_match_event_wait (void)
4087	{
4088	if (!gfc_notify_std (GFC_STD_F2018, "EVENT WAIT statement at %C"))
4089	return MATCH_ERROR;
4090
4091	return event_statement (st: ST_EVENT_WAIT);
4092	}
4093
4094
4095	/* Match a FAIL IMAGE statement. */
4096
4097	match
4098	gfc_match_fail_image (void)
4099	{
4100	if (!gfc_notify_std (GFC_STD_F2018, "FAIL IMAGE statement at %C"))
4101	return MATCH_ERROR;
4102
4103	if (gfc_match_char (c: '(') == MATCH_YES)
4104	goto syntax;
4105
4106	new_st.op = EXEC_FAIL_IMAGE;
4107
4108	return MATCH_YES;
4109
4110	syntax:
4111	gfc_syntax_error (ST_FAIL_IMAGE);
4112
4113	return MATCH_ERROR;
4114	}
4115
4116	/* Match a FORM TEAM statement. */
4117
4118	match
4119	gfc_match_form_team (void)
4120	{
4121	match m;
4122	gfc_expr *teamid, *team, *new_index;
4123
4124	teamid = team = new_index = NULL;
4125
4126	if (!gfc_notify_std (GFC_STD_F2018, "FORM TEAM statement at %C"))
4127	return MATCH_ERROR;
4128
4129	if (gfc_match_char (c: '(') == MATCH_NO)
4130	goto syntax;
4131
4132	new_st.op = EXEC_FORM_TEAM;
4133
4134	if (gfc_match (target: "%e", &teamid) != MATCH_YES)
4135	goto syntax;
4136	m = gfc_match_char (c: ',');
4137	if (m == MATCH_ERROR)
4138	goto syntax;
4139	if (gfc_match (target: "%e", &team) != MATCH_YES)
4140	goto syntax;
4141
4142	m = gfc_match_char (c: ',');
4143	if (m == MATCH_ERROR)
4144	goto syntax;
4145	if (m == MATCH_NO)
4146	{
4147	m = gfc_match_char (c: ')');
4148	if (m == MATCH_YES)
4149	goto done;
4150	goto syntax;
4151	}
4152
4153	for (;;)
4154	{
4155	m = match_stat_errmsg (sync_stat: &new_st.ext.sync_stat, st_code: ST_FORM_TEAM);
4156	if (m == MATCH_ERROR)
4157	goto cleanup;
4158
4159	m = match_named_arg (pat: " new_index = %e", name: "NEW_INDEX", e: &new_index,
4160	st_code: ST_FORM_TEAM);
4161	if (m == MATCH_ERROR)
4162	goto cleanup;
4163
4164	m = gfc_match_char (c: ',');
4165	if (m == MATCH_YES)
4166	continue;
4167
4168	break;
4169	}
4170
4171	if (m == MATCH_ERROR)
4172	goto syntax;
4173
4174	if (gfc_match (target: " )%t") != MATCH_YES)
4175	goto syntax;
4176
4177	done:
4178
4179	new_st.expr1 = teamid;
4180	new_st.expr2 = team;
4181	new_st.expr3 = new_index;
4182
4183	return MATCH_YES;
4184
4185	syntax:
4186	gfc_syntax_error (ST_FORM_TEAM);
4187
4188	cleanup:
4189	gfc_free_expr (new_index);
4190	gfc_free_expr (new_st.ext.sync_stat.stat);
4191	gfc_free_expr (new_st.ext.sync_stat.errmsg);
4192	new_st.ext.sync_stat = {NULL, NULL};
4193
4194	gfc_free_expr (team);
4195	gfc_free_expr (teamid);
4196
4197	return MATCH_ERROR;
4198	}
4199
4200	/* Match a CHANGE TEAM statement. */
4201
4202	match
4203	gfc_match_change_team (void)
4204	{
4205	match m;
4206	gfc_expr *team = NULL;
4207
4208	if (gfc_match_label () == MATCH_ERROR)
4209	return MATCH_ERROR;
4210
4211	if (gfc_match (target: " change% team") != MATCH_YES)
4212	return MATCH_NO;
4213
4214	if (!gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM statement at %C"))
4215	return MATCH_ERROR;
4216
4217	if (gfc_match_char (c: '(') == MATCH_NO)
4218	goto syntax;
4219
4220	if (gfc_match (target: "%e", &team) != MATCH_YES)
4221	goto syntax;
4222
4223	m = gfc_match_char (c: ',');
4224	if (m == MATCH_ERROR)
4225	goto syntax;
4226	if (m == MATCH_NO)
4227	{
4228	m = gfc_match_char (c: ')');
4229	if (m == MATCH_YES)
4230	goto done;
4231	goto syntax;
4232	}
4233
4234	m = match_association_list (for_change_team: true);
4235	if (m == MATCH_ERROR)
4236	goto cleanup;
4237	else if (m == MATCH_NO)
4238	for (;;)
4239	{
4240	m = match_stat_errmsg (sync_stat: &new_st.ext.block.sync_stat, st_code: ST_CHANGE_TEAM);
4241	if (m == MATCH_ERROR)
4242	goto cleanup;
4243
4244	if (gfc_match_char (c: ',') == MATCH_YES)
4245	continue;
4246
4247	break;
4248	}
4249
4250	if (gfc_match (target: " )%t") != MATCH_YES)
4251	goto syntax;
4252
4253	done:
4254
4255	new_st.expr1 = team;
4256
4257	return MATCH_YES;
4258
4259	syntax:
4260	gfc_syntax_error (ST_CHANGE_TEAM);
4261
4262	cleanup:
4263	gfc_free_expr (new_st.ext.block.sync_stat.stat);
4264	gfc_free_expr (new_st.ext.block.sync_stat.errmsg);
4265	new_st.ext.block.sync_stat = {NULL, NULL};
4266	gfc_free_association_list (new_st.ext.block.assoc);
4267	new_st.ext.block.assoc = NULL;
4268	gfc_free_expr (team);
4269
4270	return MATCH_ERROR;
4271	}
4272
4273	/* Match an END TEAM statement. */
4274
4275	match
4276	gfc_match_end_team (void)
4277	{
4278	if (gfc_match_eos () == MATCH_YES)
4279	goto done;
4280
4281	if (gfc_match_char (c: '(') != MATCH_YES)
4282	{
4283	/* There could be a team-construct-name following. Let caller decide
4284	about error. */
4285	new_st.op = EXEC_END_TEAM;
4286	return MATCH_NO;
4287	}
4288
4289	for (;;)
4290	{
4291	if (match_stat_errmsg (sync_stat: &new_st.ext.sync_stat, st_code: ST_END_TEAM) == MATCH_ERROR)
4292	goto cleanup;
4293
4294	if (gfc_match_char (c: ',') == MATCH_YES)
4295	continue;
4296
4297	break;
4298	}
4299
4300	if (gfc_match_char (c: ')') != MATCH_YES)
4301	goto syntax;
4302
4303	done:
4304
4305	new_st.op = EXEC_END_TEAM;
4306
4307	return MATCH_YES;
4308
4309	syntax:
4310	gfc_syntax_error (ST_END_TEAM);
4311
4312	cleanup:
4313	gfc_free_expr (new_st.ext.sync_stat.stat);
4314	gfc_free_expr (new_st.ext.sync_stat.errmsg);
4315	new_st.ext.sync_stat = {NULL, NULL};
4316
4317	/* Try to match the closing bracket to allow error recovery. */
4318	gfc_match_char (c: ')');
4319
4320	return MATCH_ERROR;
4321	}
4322
4323	/* Match a SYNC TEAM statement. */
4324
4325	match
4326	gfc_match_sync_team (void)
4327	{
4328	match m;
4329	gfc_expr *team = NULL;
4330
4331	if (!gfc_notify_std (GFC_STD_F2018, "SYNC TEAM statement at %C"))
4332	return MATCH_ERROR;
4333
4334	if (gfc_match_char (c: '(') == MATCH_NO)
4335	goto syntax;
4336
4337	new_st.op = EXEC_SYNC_TEAM;
4338
4339	if (gfc_match (target: "%e", &team) != MATCH_YES)
4340	goto syntax;
4341
4342	m = gfc_match_char (c: ',');
4343	if (m == MATCH_ERROR)
4344	goto syntax;
4345	if (m == MATCH_NO)
4346	{
4347	m = gfc_match_char (c: ')');
4348	if (m == MATCH_YES)
4349	goto done;
4350	goto syntax;
4351	}
4352
4353	for (;;)
4354	{
4355	m = match_stat_errmsg (sync_stat: &new_st.ext.sync_stat, st_code: ST_SYNC_TEAM);
4356	if (m == MATCH_ERROR)
4357	goto cleanup;
4358
4359	if (gfc_match_char (c: ',') == MATCH_YES)
4360	continue;
4361
4362	break;
4363	}
4364
4365	if (gfc_match (target: " )%t") != MATCH_YES)
4366	goto syntax;
4367
4368	done:
4369
4370	new_st.expr1 = team;
4371
4372	return MATCH_YES;
4373
4374	syntax:
4375	gfc_syntax_error (ST_SYNC_TEAM);
4376
4377	cleanup:
4378	gfc_free_expr (new_st.ext.sync_stat.stat);
4379	gfc_free_expr (new_st.ext.sync_stat.errmsg);
4380	new_st.ext.sync_stat = {NULL, NULL};
4381
4382	gfc_free_expr (team);
4383
4384	return MATCH_ERROR;
4385	}
4386
4387	/* Match LOCK/UNLOCK statement. Syntax:
4388	LOCK ( lock-variable [ , lock-stat-list ] )
4389	UNLOCK ( lock-variable [ , sync-stat-list ] )
4390	where lock-stat is ACQUIRED_LOCK or sync-stat
4391	and sync-stat is STAT= or ERRMSG=. */
4392
4393	static match
4394	lock_unlock_statement (gfc_statement st)
4395	{
4396	match m;
4397	gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg;
4398	bool saw_acq_lock, saw_stat, saw_errmsg;
4399
4400	tmp = lockvar = acq_lock = stat = errmsg = NULL;
4401	saw_acq_lock = saw_stat = saw_errmsg = false;
4402
4403	if (gfc_pure (NULL))
4404	{
4405	gfc_error ("Image control statement %s at %C in PURE procedure",
4406	st == ST_LOCK ? "LOCK" : "UNLOCK");
4407	return MATCH_ERROR;
4408	}
4409
4410	gfc_unset_implicit_pure (NULL);
4411
4412	if (flag_coarray == GFC_FCOARRAY_NONE)
4413	{
4414	gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
4415	return MATCH_ERROR;
4416	}
4417
4418	if (gfc_find_state (COMP_CRITICAL))
4419	{
4420	gfc_error ("Image control statement %s at %C in CRITICAL block",
4421	st == ST_LOCK ? "LOCK" : "UNLOCK");
4422	return MATCH_ERROR;
4423	}
4424
4425	if (gfc_find_state (COMP_DO_CONCURRENT))
4426	{
4427	gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
4428	st == ST_LOCK ? "LOCK" : "UNLOCK");
4429	return MATCH_ERROR;
4430	}
4431
4432	if (gfc_match_char (c: '(') != MATCH_YES)
4433	goto syntax;
4434
4435	if (gfc_match (target: "%e", &lockvar) != MATCH_YES)
4436	goto syntax;
4437	m = gfc_match_char (c: ',');
4438	if (m == MATCH_ERROR)
4439	goto syntax;
4440	if (m == MATCH_NO)
4441	{
4442	m = gfc_match_char (c: ')');
4443	if (m == MATCH_YES)
4444	goto done;
4445	goto syntax;
4446	}
4447
4448	for (;;)
4449	{
4450	m = gfc_match (target: " stat = %v", &tmp);
4451	if (m == MATCH_ERROR)
4452	goto syntax;
4453	if (m == MATCH_YES)
4454	{
4455	if (saw_stat)
4456	{
4457	gfc_error ("Redundant STAT tag found at %L", &tmp->where);
4458	goto cleanup;
4459	}
4460	stat = tmp;
4461	saw_stat = true;
4462
4463	m = gfc_match_char (c: ',');
4464	if (m == MATCH_YES)
4465	continue;
4466
4467	tmp = NULL;
4468	break;
4469	}
4470
4471	m = gfc_match (target: " errmsg = %v", &tmp);
4472	if (m == MATCH_ERROR)
4473	goto syntax;
4474	if (m == MATCH_YES)
4475	{
4476	if (saw_errmsg)
4477	{
4478	gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
4479	goto cleanup;
4480	}
4481	errmsg = tmp;
4482	saw_errmsg = true;
4483
4484	m = gfc_match_char (c: ',');
4485	if (m == MATCH_YES)
4486	continue;
4487
4488	tmp = NULL;
4489	break;
4490	}
4491
4492	m = gfc_match (target: " acquired_lock = %v", &tmp);
4493	if (m == MATCH_ERROR || st == ST_UNLOCK)
4494	goto syntax;
4495	if (m == MATCH_YES)
4496	{
4497	if (saw_acq_lock)
4498	{
4499	gfc_error ("Redundant ACQUIRED_LOCK tag found at %L",
4500	&tmp->where);
4501	goto cleanup;
4502	}
4503	acq_lock = tmp;
4504	saw_acq_lock = true;
4505
4506	m = gfc_match_char (c: ',');
4507	if (m == MATCH_YES)
4508	continue;
4509
4510	tmp = NULL;
4511	break;
4512	}
4513
4514	break;
4515	}
4516
4517	if (m == MATCH_ERROR)
4518	goto syntax;
4519
4520	if (gfc_match (target: " )%t") != MATCH_YES)
4521	goto syntax;
4522
4523	done:
4524	switch (st)
4525	{
4526	case ST_LOCK:
4527	new_st.op = EXEC_LOCK;
4528	break;
4529	case ST_UNLOCK:
4530	new_st.op = EXEC_UNLOCK;
4531	break;
4532	default:
4533	gcc_unreachable ();
4534	}
4535
4536	new_st.expr1 = lockvar;
4537	new_st.expr2 = stat;
4538	new_st.expr3 = errmsg;
4539	new_st.expr4 = acq_lock;
4540
4541	return MATCH_YES;
4542
4543	syntax:
4544	gfc_syntax_error (st);
4545
4546	cleanup:
4547	if (acq_lock != tmp)
4548	gfc_free_expr (acq_lock);
4549	if (errmsg != tmp)
4550	gfc_free_expr (errmsg);
4551	if (stat != tmp)
4552	gfc_free_expr (stat);
4553
4554	gfc_free_expr (tmp);
4555	gfc_free_expr (lockvar);
4556
4557	return MATCH_ERROR;
4558	}
4559
4560
4561	match
4562	gfc_match_lock (void)
4563	{
4564	if (!gfc_notify_std (GFC_STD_F2008, "LOCK statement at %C"))
4565	return MATCH_ERROR;
4566
4567	return lock_unlock_statement (st: ST_LOCK);
4568	}
4569
4570
4571	match
4572	gfc_match_unlock (void)
4573	{
4574	if (!gfc_notify_std (GFC_STD_F2008, "UNLOCK statement at %C"))
4575	return MATCH_ERROR;
4576
4577	return lock_unlock_statement (st: ST_UNLOCK);
4578	}
4579
4580
4581	/* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
4582	SYNC ALL [(sync-stat-list)]
4583	SYNC MEMORY [(sync-stat-list)]
4584	SYNC IMAGES (image-set [, sync-stat-list] )
4585	with sync-stat is int-expr or *. */
4586
4587	static match
4588	sync_statement (gfc_statement st)
4589	{
4590	match m;
4591	gfc_expr *tmp, *imageset, *stat, *errmsg;
4592	bool saw_stat, saw_errmsg;
4593
4594	tmp = imageset = stat = errmsg = NULL;
4595	saw_stat = saw_errmsg = false;
4596
4597	if (gfc_pure (NULL))
4598	{
4599	gfc_error ("Image control statement SYNC at %C in PURE procedure");
4600	return MATCH_ERROR;
4601	}
4602
4603	gfc_unset_implicit_pure (NULL);
4604
4605	if (!gfc_notify_std (GFC_STD_F2008, "SYNC statement at %C"))
4606	return MATCH_ERROR;
4607
4608	if (flag_coarray == GFC_FCOARRAY_NONE)
4609	{
4610	gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
4611	"enable");
4612	return MATCH_ERROR;
4613	}
4614
4615	if (gfc_find_state (COMP_CRITICAL))
4616	{
4617	gfc_error ("Image control statement SYNC at %C in CRITICAL block");
4618	return MATCH_ERROR;
4619	}
4620
4621	if (gfc_find_state (COMP_DO_CONCURRENT))
4622	{
4623	gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
4624	return MATCH_ERROR;
4625	}
4626
4627	if (gfc_match_eos () == MATCH_YES)
4628	{
4629	if (st == ST_SYNC_IMAGES)
4630	goto syntax;
4631	goto done;
4632	}
4633
4634	if (gfc_match_char (c: '(') != MATCH_YES)
4635	goto syntax;
4636
4637	if (st == ST_SYNC_IMAGES)
4638	{
4639	/* Denote '*' as imageset == NULL. */
4640	m = gfc_match_char (c: '*');
4641	if (m == MATCH_ERROR)
4642	goto syntax;
4643	if (m == MATCH_NO)
4644	{
4645	if (gfc_match (target: "%e", &imageset) != MATCH_YES)
4646	goto syntax;
4647	}
4648	m = gfc_match_char (c: ',');
4649	if (m == MATCH_ERROR)
4650	goto syntax;
4651	if (m == MATCH_NO)
4652	{
4653	m = gfc_match_char (c: ')');
4654	if (m == MATCH_YES)
4655	goto done;
4656	goto syntax;
4657	}
4658	}
4659
4660	for (;;)
4661	{
4662	m = gfc_match (target: " stat = %e", &tmp);
4663	if (m == MATCH_ERROR)
4664	goto syntax;
4665	if (m == MATCH_YES)
4666	{
4667	if (saw_stat)
4668	{
4669	gfc_error ("Redundant STAT tag found at %L", &tmp->where);
4670	goto cleanup;
4671	}
4672	stat = tmp;
4673	saw_stat = true;
4674
4675	if (gfc_match_char (c: ',') == MATCH_YES)
4676	continue;
4677
4678	tmp = NULL;
4679	break;
4680	}
4681
4682	m = gfc_match (target: " errmsg = %e", &tmp);
4683	if (m == MATCH_ERROR)
4684	goto syntax;
4685	if (m == MATCH_YES)
4686	{
4687	if (saw_errmsg)
4688	{
4689	gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
4690	goto cleanup;
4691	}
4692	errmsg = tmp;
4693	saw_errmsg = true;
4694
4695	if (gfc_match_char (c: ',') == MATCH_YES)
4696	continue;
4697
4698	tmp = NULL;
4699	break;
4700	}
4701
4702	break;
4703	}
4704
4705	if (gfc_match (target: " )%t") != MATCH_YES)
4706	goto syntax;
4707
4708	done:
4709	switch (st)
4710	{
4711	case ST_SYNC_ALL:
4712	new_st.op = EXEC_SYNC_ALL;
4713	break;
4714	case ST_SYNC_IMAGES:
4715	new_st.op = EXEC_SYNC_IMAGES;
4716	break;
4717	case ST_SYNC_MEMORY:
4718	new_st.op = EXEC_SYNC_MEMORY;
4719	break;
4720	default:
4721	gcc_unreachable ();
4722	}
4723
4724	new_st.expr1 = imageset;
4725	new_st.expr2 = stat;
4726	new_st.expr3 = errmsg;
4727
4728	return MATCH_YES;
4729
4730	syntax:
4731	gfc_syntax_error (st);
4732
4733	cleanup:
4734	if (stat != tmp)
4735	gfc_free_expr (stat);
4736	if (errmsg != tmp)
4737	gfc_free_expr (errmsg);
4738
4739	gfc_free_expr (tmp);
4740	gfc_free_expr (imageset);
4741
4742	return MATCH_ERROR;
4743	}
4744
4745
4746	/* Match SYNC ALL statement. */
4747
4748	match
4749	gfc_match_sync_all (void)
4750	{
4751	return sync_statement (st: ST_SYNC_ALL);
4752	}
4753
4754
4755	/* Match SYNC IMAGES statement. */
4756
4757	match
4758	gfc_match_sync_images (void)
4759	{
4760	return sync_statement (st: ST_SYNC_IMAGES);
4761	}
4762
4763
4764	/* Match SYNC MEMORY statement. */
4765
4766	match
4767	gfc_match_sync_memory (void)
4768	{
4769	return sync_statement (st: ST_SYNC_MEMORY);
4770	}
4771
4772
4773	/* Match a CONTINUE statement. */
4774
4775	match
4776	gfc_match_continue (void)
4777	{
4778	if (gfc_match_eos () != MATCH_YES)
4779	{
4780	gfc_syntax_error (ST_CONTINUE);
4781	return MATCH_ERROR;
4782	}
4783
4784	new_st.op = EXEC_CONTINUE;
4785	return MATCH_YES;
4786	}
4787
4788
4789	/* Match the (deprecated) ASSIGN statement. */
4790
4791	match
4792	gfc_match_assign (void)
4793	{
4794	gfc_expr *expr;
4795	gfc_st_label *label;
4796
4797	if (gfc_match (target: " %l", &label) == MATCH_YES)
4798	{
4799	if (!gfc_reference_st_label (label, ST_LABEL_UNKNOWN))
4800	return MATCH_ERROR;
4801	if (gfc_match (target: " to %v%t", &expr) == MATCH_YES)
4802	{
4803	if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGN statement at %C"))
4804	return MATCH_ERROR;
4805
4806	expr->symtree->n.sym->attr.assign = 1;
4807
4808	new_st.op = EXEC_LABEL_ASSIGN;
4809	new_st.label1 = label;
4810	new_st.expr1 = expr;
4811	return MATCH_YES;
4812	}
4813	}
4814	return MATCH_NO;
4815	}
4816
4817
4818	/* Match the GO TO statement. As a computed GOTO statement is
4819	matched, it is transformed into an equivalent SELECT block. No
4820	tree is necessary, and the resulting jumps-to-jumps are
4821	specifically optimized away by the back end. */
4822
4823	match
4824	gfc_match_goto (void)
4825	{
4826	gfc_code *head, *tail;
4827	gfc_expr *expr;
4828	gfc_case *cp;
4829	gfc_st_label *label;
4830	int i;
4831	match m;
4832
4833	if (gfc_match (target: " %l%t", &label) == MATCH_YES)
4834	{
4835	if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
4836	return MATCH_ERROR;
4837
4838	new_st.op = EXEC_GOTO;
4839	new_st.label1 = label;
4840	return MATCH_YES;
4841	}
4842
4843	/* The assigned GO TO statement. */
4844
4845	if (gfc_match_variable (&expr, 0) == MATCH_YES)
4846	{
4847	if (!gfc_notify_std (GFC_STD_F95_DEL, "Assigned GOTO statement at %C"))
4848	return MATCH_ERROR;
4849
4850	new_st.op = EXEC_GOTO;
4851	new_st.expr1 = expr;
4852
4853	if (gfc_match_eos () == MATCH_YES)
4854	return MATCH_YES;
4855
4856	/* Match label list. */
4857	gfc_match_char (c: ',');
4858	if (gfc_match_char (c: '(') != MATCH_YES)
4859	{
4860	gfc_syntax_error (ST_GOTO);
4861	return MATCH_ERROR;
4862	}
4863	head = tail = NULL;
4864
4865	do
4866	{
4867	m = gfc_match_st_label (label: &label);
4868	if (m != MATCH_YES)
4869	goto syntax;
4870
4871	if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
4872	goto cleanup;
4873
4874	if (head == NULL)
4875	head = tail = gfc_get_code (EXEC_GOTO);
4876	else
4877	{
4878	tail->block = gfc_get_code (EXEC_GOTO);
4879	tail = tail->block;
4880	}
4881
4882	tail->label1 = label;
4883	}
4884	while (gfc_match_char (c: ',') == MATCH_YES);
4885
4886	if (gfc_match (target: " )%t") != MATCH_YES)
4887	goto syntax;
4888
4889	if (head == NULL)
4890	{
4891	gfc_error ("Statement label list in GOTO at %C cannot be empty");
4892	goto syntax;
4893	}
4894	new_st.block = head;
4895
4896	return MATCH_YES;
4897	}
4898
4899	/* Last chance is a computed GO TO statement. */
4900	if (gfc_match_char (c: '(') != MATCH_YES)
4901	{
4902	gfc_syntax_error (ST_GOTO);
4903	return MATCH_ERROR;
4904	}
4905
4906	head = tail = NULL;
4907	i = 1;
4908
4909	do
4910	{
4911	m = gfc_match_st_label (label: &label);
4912	if (m != MATCH_YES)
4913	goto syntax;
4914
4915	if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
4916	goto cleanup;
4917
4918	if (head == NULL)
4919	head = tail = gfc_get_code (EXEC_SELECT);
4920	else
4921	{
4922	tail->block = gfc_get_code (EXEC_SELECT);
4923	tail = tail->block;
4924	}
4925
4926	cp = gfc_get_case ();
4927	cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
4928	NULL, i++);
4929
4930	tail->ext.block.case_list = cp;
4931
4932	tail->next = gfc_get_code (EXEC_GOTO);
4933	tail->next->label1 = label;
4934	}
4935	while (gfc_match_char (c: ',') == MATCH_YES);
4936
4937	if (gfc_match_char (c: ')') != MATCH_YES)
4938	goto syntax;
4939
4940	if (head == NULL)
4941	{
4942	gfc_error ("Statement label list in GOTO at %C cannot be empty");
4943	goto syntax;
4944	}
4945
4946	/* Get the rest of the statement. */
4947	gfc_match_char (c: ',');
4948
4949	if (gfc_match (target: " %e%t", &expr) != MATCH_YES)
4950	goto syntax;
4951
4952	if (!gfc_notify_std (GFC_STD_F95_OBS, "Computed GOTO at %C"))
4953	return MATCH_ERROR;
4954
4955	/* At this point, a computed GOTO has been fully matched and an
4956	equivalent SELECT statement constructed. */
4957
4958	new_st.op = EXEC_SELECT;
4959	new_st.expr1 = NULL;
4960
4961	/* Hack: For a "real" SELECT, the expression is in expr. We put
4962	it in expr2 so we can distinguish then and produce the correct
4963	diagnostics. */
4964	new_st.expr2 = expr;
4965	new_st.block = head;
4966	return MATCH_YES;
4967
4968	syntax:
4969	gfc_syntax_error (ST_GOTO);
4970	cleanup:
4971	gfc_free_statements (head);
4972	return MATCH_ERROR;
4973	}
4974
4975
4976	/* Frees a list of gfc_alloc structures. */
4977
4978	void
4979	gfc_free_alloc_list (gfc_alloc *p)
4980	{
4981	gfc_alloc *q;
4982
4983	for (; p; p = q)
4984	{
4985	q = p->next;
4986	gfc_free_expr (p->expr);
4987	free (ptr: p);
4988	}
4989	}
4990
4991
4992	/* Match an ALLOCATE statement. */
4993
4994	match
4995	gfc_match_allocate (void)
4996	{
4997	gfc_alloc *head, *tail;
4998	gfc_expr *stat, *errmsg, *tmp, *source, *mold;
4999	gfc_typespec ts;
5000	gfc_symbol *sym;
5001	match m;
5002	locus old_locus, deferred_locus, assumed_locus;
5003	bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
5004	bool saw_unlimited = false, saw_assumed = false;
5005
5006	head = tail = NULL;
5007	stat = errmsg = source = mold = tmp = NULL;
5008	saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
5009
5010	if (gfc_match_char (c: '(') != MATCH_YES)
5011	{
5012	gfc_syntax_error (ST_ALLOCATE);
5013	return MATCH_ERROR;
5014	}
5015
5016	/* Match an optional type-spec. */
5017	old_locus = gfc_current_locus;
5018	m = gfc_match_type_spec (ts: &ts);
5019	if (m == MATCH_ERROR)
5020	goto cleanup;
5021	else if (m == MATCH_NO)
5022	{
5023	char name[GFC_MAX_SYMBOL_LEN + 3];
5024
5025	if (gfc_match (target: "%n :: ", name) == MATCH_YES)
5026	{
5027	gfc_error ("Error in type-spec at %L", &old_locus);
5028	goto cleanup;
5029	}
5030
5031	ts.type = BT_UNKNOWN;
5032	}
5033	else
5034	{
5035	/* Needed for the F2008:C631 check below. */
5036	assumed_locus = gfc_current_locus;
5037
5038	if (gfc_match (target: " :: ") == MATCH_YES)
5039	{
5040	if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L",
5041	&old_locus))
5042	goto cleanup;
5043
5044	if (ts.deferred)
5045	{
5046	gfc_error ("Type-spec at %L cannot contain a deferred "
5047	"type parameter", &old_locus);
5048	goto cleanup;
5049	}
5050
5051	if (ts.type == BT_CHARACTER)
5052	{
5053	if (!ts.u.cl->length)
5054	saw_assumed = true;
5055	else
5056	ts.u.cl->length_from_typespec = true;
5057	}
5058
5059	if (type_param_spec_list
5060	&& gfc_spec_list_type (type_param_spec_list, NULL)
5061	== SPEC_DEFERRED)
5062	{
5063	gfc_error ("The type parameter spec list in the type-spec at "
5064	"%L cannot contain DEFERRED parameters", &old_locus);
5065	goto cleanup;
5066	}
5067	}
5068	else
5069	{
5070	ts.type = BT_UNKNOWN;
5071	gfc_current_locus = old_locus;
5072	}
5073	}
5074
5075	for (;;)
5076	{
5077	if (head == NULL)
5078	head = tail = gfc_get_alloc ();
5079	else
5080	{
5081	tail->next = gfc_get_alloc ();
5082	tail = tail->next;
5083	}
5084
5085	m = gfc_match_variable (&tail->expr, 0);
5086	if (m == MATCH_NO)
5087	goto syntax;
5088	if (m == MATCH_ERROR)
5089	goto cleanup;
5090
5091	if (tail->expr->expr_type == EXPR_CONSTANT)
5092	{
5093	gfc_error ("Unexpected constant at %C");
5094	goto cleanup;
5095	}
5096
5097	if (gfc_check_do_variable (tail->expr->symtree))
5098	goto cleanup;
5099
5100	bool impure = gfc_impure_variable (tail->expr->symtree->n.sym);
5101	if (impure && gfc_pure (NULL))
5102	{
5103	gfc_error ("Bad allocate-object at %C for a PURE procedure");
5104	goto cleanup;
5105	}
5106
5107	if (impure)
5108	gfc_unset_implicit_pure (NULL);
5109
5110	/* F2008:C631 (R626) A type-param-value in a type-spec shall be an
5111	asterisk if and only if each allocate-object is a dummy argument
5112	for which the corresponding type parameter is assumed. */
5113	if (saw_assumed
5114	&& (tail->expr->ts.deferred
5115	|| (tail->expr->ts.u.cl && tail->expr->ts.u.cl->length)
5116	|| tail->expr->symtree->n.sym->attr.dummy == 0))
5117	{
5118	gfc_error ("Incompatible allocate-object at %C for CHARACTER "
5119	"type-spec at %L", &assumed_locus);
5120	goto cleanup;
5121	}
5122
5123	if (tail->expr->ts.deferred)
5124	{
5125	saw_deferred = true;
5126	deferred_locus = tail->expr->where;
5127	}
5128
5129	if (gfc_find_state (COMP_DO_CONCURRENT)
5130	|| gfc_find_state (COMP_CRITICAL))
5131	{
5132	gfc_ref *ref;
5133	bool coarray = tail->expr->symtree->n.sym->attr.codimension;
5134	for (ref = tail->expr->ref; ref; ref = ref->next)
5135	if (ref->type == REF_COMPONENT)
5136	coarray = ref->u.c.component->attr.codimension;
5137
5138	if (coarray && gfc_find_state (COMP_DO_CONCURRENT))
5139	{
5140	gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
5141	goto cleanup;
5142	}
5143	if (coarray && gfc_find_state (COMP_CRITICAL))
5144	{
5145	gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
5146	goto cleanup;
5147	}
5148	}
5149
5150	/* Check for F08:C628. */
5151	sym = tail->expr->symtree->n.sym;
5152	b1 = !(tail->expr->ref
5153	&& (tail->expr->ref->type == REF_COMPONENT
5154	|| tail->expr->ref->type == REF_ARRAY));
5155	if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok)
5156	b2 = !(CLASS_DATA (sym)->attr.allocatable
5157	|| CLASS_DATA (sym)->attr.class_pointer);
5158	else
5159	b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
5160	|| sym->attr.proc_pointer);
5161	b3 = sym && sym->ns && sym->ns->proc_name
5162	&& (sym->ns->proc_name->attr.allocatable
5163	|| sym->ns->proc_name->attr.pointer
5164	|| sym->ns->proc_name->attr.proc_pointer);
5165	if (b1 && b2 && !b3)
5166	{
5167	gfc_error ("Allocate-object at %L is neither a data pointer "
5168	"nor an allocatable variable", &tail->expr->where);
5169	goto cleanup;
5170	}
5171
5172	/* The ALLOCATE statement had an optional typespec. Check the
5173	constraints. */
5174	if (ts.type != BT_UNKNOWN)
5175	{
5176	/* Enforce F03:C624. */
5177	if (!gfc_type_compatible (&tail->expr->ts, &ts))
5178	{
5179	gfc_error ("Type of entity at %L is type incompatible with "
5180	"typespec", &tail->expr->where);
5181	goto cleanup;
5182	}
5183
5184	/* Enforce F03:C627. */
5185	if (ts.kind != tail->expr->ts.kind && !UNLIMITED_POLY (tail->expr))
5186	{
5187	gfc_error ("Kind type parameter for entity at %L differs from "
5188	"the kind type parameter of the typespec",
5189	&tail->expr->where);
5190	goto cleanup;
5191	}
5192	}
5193
5194	if (tail->expr->ts.type == BT_DERIVED)
5195	tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
5196
5197	if (type_param_spec_list)
5198	tail->expr->param_list = gfc_copy_actual_arglist (type_param_spec_list);
5199
5200	saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr);
5201
5202	if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
5203	{
5204	gfc_error ("Shape specification for allocatable scalar at %C");
5205	goto cleanup;
5206	}
5207
5208	if (gfc_match_char (c: ',') != MATCH_YES)
5209	break;
5210
5211	alloc_opt_list:
5212
5213	m = gfc_match (target: " stat = %e", &tmp);
5214	if (m == MATCH_ERROR)
5215	goto cleanup;
5216	if (m == MATCH_YES)
5217	{
5218	/* Enforce C630. */
5219	if (saw_stat)
5220	{
5221	gfc_error ("Redundant STAT tag found at %L", &tmp->where);
5222	goto cleanup;
5223	}
5224
5225	stat = tmp;
5226	tmp = NULL;
5227	saw_stat = true;
5228
5229	if (stat->expr_type == EXPR_CONSTANT)
5230	{
5231	gfc_error ("STAT tag at %L cannot be a constant", &stat->where);
5232	goto cleanup;
5233	}
5234
5235	if (gfc_check_do_variable (stat->symtree))
5236	goto cleanup;
5237
5238	if (gfc_match_char (c: ',') == MATCH_YES)
5239	goto alloc_opt_list;
5240	}
5241
5242	m = gfc_match (target: " errmsg = %e", &tmp);
5243	if (m == MATCH_ERROR)
5244	goto cleanup;
5245	if (m == MATCH_YES)
5246	{
5247	if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG tag at %L", &tmp->where))
5248	goto cleanup;
5249
5250	/* Enforce C630. */
5251	if (saw_errmsg)
5252	{
5253	gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
5254	goto cleanup;
5255	}
5256
5257	errmsg = tmp;
5258	tmp = NULL;
5259	saw_errmsg = true;
5260
5261	if (gfc_match_char (c: ',') == MATCH_YES)
5262	goto alloc_opt_list;
5263	}
5264
5265	m = gfc_match (target: " source = %e", &tmp);
5266	if (m == MATCH_ERROR)
5267	goto cleanup;
5268	if (m == MATCH_YES)
5269	{
5270	if (!gfc_notify_std (GFC_STD_F2003, "SOURCE tag at %L", &tmp->where))
5271	goto cleanup;
5272
5273	/* Enforce C630. */
5274	if (saw_source)
5275	{
5276	gfc_error ("Redundant SOURCE tag found at %L", &tmp->where);
5277	goto cleanup;
5278	}
5279
5280	/* The next 2 conditionals check C631. */
5281	if (ts.type != BT_UNKNOWN)
5282	{
5283	gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
5284	&tmp->where, &old_locus);
5285	goto cleanup;
5286	}
5287
5288	if (head->next
5289	&& !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L"
5290	" with more than a single allocate object",
5291	&tmp->where))
5292	goto cleanup;
5293
5294	source = tmp;
5295	tmp = NULL;
5296	saw_source = true;
5297
5298	if (gfc_match_char (c: ',') == MATCH_YES)
5299	goto alloc_opt_list;
5300	}
5301
5302	m = gfc_match (target: " mold = %e", &tmp);
5303	if (m == MATCH_ERROR)
5304	goto cleanup;
5305	if (m == MATCH_YES)
5306	{
5307	if (!gfc_notify_std (GFC_STD_F2008, "MOLD tag at %L", &tmp->where))
5308	goto cleanup;
5309
5310	/* Check F08:C636. */
5311	if (saw_mold)
5312	{
5313	gfc_error ("Redundant MOLD tag found at %L", &tmp->where);
5314	goto cleanup;
5315	}
5316
5317	/* Check F08:C637. */
5318	if (ts.type != BT_UNKNOWN)
5319	{
5320	gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
5321	&tmp->where, &old_locus);
5322	goto cleanup;
5323	}
5324
5325	mold = tmp;
5326	tmp = NULL;
5327	saw_mold = true;
5328	mold->mold = 1;
5329
5330	if (gfc_match_char (c: ',') == MATCH_YES)
5331	goto alloc_opt_list;
5332	}
5333
5334	gfc_gobble_whitespace ();
5335
5336	if (gfc_peek_char () == ')')
5337	break;
5338	}
5339
5340	if (gfc_match (target: " )%t") != MATCH_YES)
5341	goto syntax;
5342
5343	/* Check F08:C637. */
5344	if (source && mold)
5345	{
5346	gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
5347	&mold->where, &source->where);
5348	goto cleanup;
5349	}
5350
5351	/* Check F03:C623, */
5352	if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold)
5353	{
5354	gfc_error ("Allocate-object at %L with a deferred type parameter "
5355	"requires either a type-spec or SOURCE tag or a MOLD tag",
5356	&deferred_locus);
5357	goto cleanup;
5358	}
5359
5360	/* Check F03:C625, */
5361	if (saw_unlimited && ts.type == BT_UNKNOWN && !source && !mold)
5362	{
5363	for (tail = head; tail; tail = tail->next)
5364	{
5365	if (UNLIMITED_POLY (tail->expr))
5366	gfc_error ("Unlimited polymorphic allocate-object at %L "
5367	"requires either a type-spec or SOURCE tag "
5368	"or a MOLD tag", &tail->expr->where);
5369	}
5370	goto cleanup;
5371	}
5372
5373	new_st.op = EXEC_ALLOCATE;
5374	new_st.expr1 = stat;
5375	new_st.expr2 = errmsg;
5376	if (source)
5377	new_st.expr3 = source;
5378	else
5379	new_st.expr3 = mold;
5380	new_st.ext.alloc.list = head;
5381	new_st.ext.alloc.ts = ts;
5382
5383	if (type_param_spec_list)
5384	gfc_free_actual_arglist (type_param_spec_list);
5385
5386	return MATCH_YES;
5387
5388	syntax:
5389	gfc_syntax_error (ST_ALLOCATE);
5390
5391	cleanup:
5392	gfc_free_expr (errmsg);
5393	gfc_free_expr (source);
5394	gfc_free_expr (stat);
5395	gfc_free_expr (mold);
5396	if (tmp && tmp->expr_type) gfc_free_expr (tmp);
5397	gfc_free_alloc_list (p: head);
5398	if (type_param_spec_list)
5399	gfc_free_actual_arglist (type_param_spec_list);
5400	return MATCH_ERROR;
5401	}
5402
5403
5404	/* Match a NULLIFY statement. A NULLIFY statement is transformed into
5405	a set of pointer assignments to intrinsic NULL(). */
5406
5407	match
5408	gfc_match_nullify (void)
5409	{
5410	gfc_code *tail;
5411	gfc_expr *e, *p = NULL;
5412	match m;
5413
5414	tail = NULL;
5415
5416	if (gfc_match_char (c: '(') != MATCH_YES)
5417	goto syntax;
5418
5419	for (;;)
5420	{
5421	m = gfc_match_variable (&p, 0);
5422	if (m == MATCH_ERROR)
5423	goto cleanup;
5424	if (m == MATCH_NO)
5425	goto syntax;
5426
5427	if (gfc_check_do_variable (p->symtree))
5428	goto cleanup;
5429
5430	/* F2008, C1242. */
5431	if (gfc_is_coindexed (p))
5432	{
5433	gfc_error ("Pointer object at %C shall not be coindexed");
5434	goto cleanup;
5435	}
5436
5437	/* Check for valid array pointer object. Bounds remapping is not
5438	allowed with NULLIFY. */
5439	if (p->ref)
5440	{
5441	gfc_ref *remap = p->ref;
5442	for (; remap; remap = remap->next)
5443	if (!remap->next && remap->type == REF_ARRAY
5444	&& remap->u.ar.type != AR_FULL)
5445	break;
5446	if (remap)
5447	{
5448	gfc_error ("NULLIFY does not allow bounds remapping for "
5449	"pointer object at %C");
5450	goto cleanup;
5451	}
5452	}
5453
5454	/* build ' => NULL() '. */
5455	e = gfc_get_null_expr (&gfc_current_locus);
5456
5457	/* Chain to list. */
5458	if (tail == NULL)
5459	{
5460	tail = &new_st;
5461	tail->op = EXEC_POINTER_ASSIGN;
5462	}
5463	else
5464	{
5465	tail->next = gfc_get_code (EXEC_POINTER_ASSIGN);
5466	tail = tail->next;
5467	}
5468
5469	tail->expr1 = p;
5470	tail->expr2 = e;
5471
5472	if (gfc_match (target: " )%t") == MATCH_YES)
5473	break;
5474	if (gfc_match_char (c: ',') != MATCH_YES)
5475	goto syntax;
5476	}
5477
5478	return MATCH_YES;
5479
5480	syntax:
5481	gfc_syntax_error (ST_NULLIFY);
5482
5483	cleanup:
5484	gfc_free_statements (new_st.next);
5485	new_st.next = NULL;
5486	gfc_free_expr (new_st.expr1);
5487	new_st.expr1 = NULL;
5488	gfc_free_expr (new_st.expr2);
5489	new_st.expr2 = NULL;
5490	gfc_free_expr (p);
5491	return MATCH_ERROR;
5492	}
5493
5494
5495	/* Match a DEALLOCATE statement. */
5496
5497	match
5498	gfc_match_deallocate (void)
5499	{
5500	gfc_alloc *head, *tail;
5501	gfc_expr *stat, *errmsg, *tmp;
5502	gfc_symbol *sym;
5503	match m;
5504	bool saw_stat, saw_errmsg, b1, b2;
5505
5506	head = tail = NULL;
5507	stat = errmsg = tmp = NULL;
5508	saw_stat = saw_errmsg = false;
5509
5510	if (gfc_match_char (c: '(') != MATCH_YES)
5511	goto syntax;
5512
5513	for (;;)
5514	{
5515	if (head == NULL)
5516	head = tail = gfc_get_alloc ();
5517	else
5518	{
5519	tail->next = gfc_get_alloc ();
5520	tail = tail->next;
5521	}
5522
5523	m = gfc_match_variable (&tail->expr, 0);
5524	if (m == MATCH_ERROR)
5525	goto cleanup;
5526	if (m == MATCH_NO)
5527	goto syntax;
5528
5529	if (tail->expr->expr_type == EXPR_CONSTANT)
5530	{
5531	gfc_error ("Unexpected constant at %C");
5532	goto cleanup;
5533	}
5534
5535	if (gfc_check_do_variable (tail->expr->symtree))
5536	goto cleanup;
5537
5538	sym = tail->expr->symtree->n.sym;
5539
5540	bool impure = gfc_impure_variable (sym);
5541	if (impure && gfc_pure (NULL))
5542	{
5543	gfc_error ("Illegal allocate-object at %C for a PURE procedure");
5544	goto cleanup;
5545	}
5546
5547	if (impure)
5548	gfc_unset_implicit_pure (NULL);
5549
5550	if (gfc_is_coarray (tail->expr)
5551	&& gfc_find_state (COMP_DO_CONCURRENT))
5552	{
5553	gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
5554	goto cleanup;
5555	}
5556
5557	if (gfc_is_coarray (tail->expr)
5558	&& gfc_find_state (COMP_CRITICAL))
5559	{
5560	gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
5561	goto cleanup;
5562	}
5563
5564	/* FIXME: disable the checking on derived types. */
5565	b1 = !(tail->expr->ref
5566	&& (tail->expr->ref->type == REF_COMPONENT
5567	|| tail->expr->ref->type == REF_ARRAY));
5568	if (sym && sym->ts.type == BT_CLASS)
5569	b2 = !(CLASS_DATA (sym) && (CLASS_DATA (sym)->attr.allocatable
5570	|| CLASS_DATA (sym)->attr.class_pointer));
5571	else
5572	b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
5573	|| sym->attr.proc_pointer);
5574	if (b1 && b2)
5575	{
5576	gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
5577	"nor an allocatable variable");
5578	goto cleanup;
5579	}
5580
5581	if (gfc_match_char (c: ',') != MATCH_YES)
5582	break;
5583
5584	dealloc_opt_list:
5585
5586	m = gfc_match (target: " stat = %e", &tmp);
5587	if (m == MATCH_ERROR)
5588	goto cleanup;
5589	if (m == MATCH_YES)
5590	{
5591	if (saw_stat)
5592	{
5593	gfc_error ("Redundant STAT tag found at %L", &tmp->where);
5594	gfc_free_expr (tmp);
5595	goto cleanup;
5596	}
5597
5598	stat = tmp;
5599	saw_stat = true;
5600
5601	if (gfc_check_do_variable (stat->symtree))
5602	goto cleanup;
5603
5604	if (gfc_match_char (c: ',') == MATCH_YES)
5605	goto dealloc_opt_list;
5606	}
5607
5608	m = gfc_match (target: " errmsg = %e", &tmp);
5609	if (m == MATCH_ERROR)
5610	goto cleanup;
5611	if (m == MATCH_YES)
5612	{
5613	if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG at %L", &tmp->where))
5614	goto cleanup;
5615
5616	if (saw_errmsg)
5617	{
5618	gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
5619	gfc_free_expr (tmp);
5620	goto cleanup;
5621	}
5622
5623	errmsg = tmp;
5624	saw_errmsg = true;
5625
5626	if (gfc_match_char (c: ',') == MATCH_YES)
5627	goto dealloc_opt_list;
5628	}
5629
5630	gfc_gobble_whitespace ();
5631
5632	if (gfc_peek_char () == ')')
5633	break;
5634	}
5635
5636	if (gfc_match (target: " )%t") != MATCH_YES)
5637	goto syntax;
5638
5639	new_st.op = EXEC_DEALLOCATE;
5640	new_st.expr1 = stat;
5641	new_st.expr2 = errmsg;
5642	new_st.ext.alloc.list = head;
5643
5644	return MATCH_YES;
5645
5646	syntax:
5647	gfc_syntax_error (ST_DEALLOCATE);
5648
5649	cleanup:
5650	gfc_free_expr (errmsg);
5651	gfc_free_expr (stat);
5652	gfc_free_alloc_list (p: head);
5653	return MATCH_ERROR;
5654	}
5655
5656
5657	/* Match a RETURN statement. */
5658
5659	match
5660	gfc_match_return (void)
5661	{
5662	gfc_expr *e;
5663	match m;
5664	gfc_compile_state s;
5665
5666	e = NULL;
5667
5668	if (gfc_find_state (COMP_CRITICAL))
5669	{
5670	gfc_error ("Image control statement RETURN at %C in CRITICAL block");
5671	return MATCH_ERROR;
5672	}
5673
5674	if (gfc_find_state (COMP_DO_CONCURRENT))
5675	{
5676	gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
5677	return MATCH_ERROR;
5678	}
5679
5680	if (gfc_find_state (COMP_CHANGE_TEAM))
5681	{
5682	/* F2018, C1111: A RETURN statement shall not appear within a CHANGE TEAM
5683	construct. */
5684	gfc_error (
5685	"Image control statement RETURN at %C in CHANGE TEAM-END TEAM block");
5686	return MATCH_ERROR;
5687	}
5688
5689	if (gfc_match_eos () == MATCH_YES)
5690	goto done;
5691
5692	if (!gfc_find_state (COMP_SUBROUTINE))
5693	{
5694	gfc_error ("Alternate RETURN statement at %C is only allowed within "
5695	"a SUBROUTINE");
5696	goto cleanup;
5697	}
5698
5699	if (gfc_current_form == FORM_FREE)
5700	{
5701	/* The following are valid, so we can't require a blank after the
5702	RETURN keyword:
5703	return+1
5704	return(1) */
5705	char c = gfc_peek_ascii_char ();
5706	if (ISALPHA (c) || ISDIGIT (c))
5707	return MATCH_NO;
5708	}
5709
5710	m = gfc_match (target: " %e%t", &e);
5711	if (m == MATCH_YES)
5712	goto done;
5713	if (m == MATCH_ERROR)
5714	goto cleanup;
5715
5716	gfc_syntax_error (ST_RETURN);
5717
5718	cleanup:
5719	gfc_free_expr (e);
5720	return MATCH_ERROR;
5721
5722	done:
5723	gfc_enclosing_unit (&s);
5724	if (s == COMP_PROGRAM
5725	&& !gfc_notify_std (GFC_STD_GNU, "RETURN statement in "
5726	"main program at %C"))
5727	return MATCH_ERROR;
5728
5729	new_st.op = EXEC_RETURN;
5730	new_st.expr1 = e;
5731
5732	return MATCH_YES;
5733	}
5734
5735
5736	/* Match the call of a type-bound procedure, if CALL%var has already been
5737	matched and var found to be a derived-type variable. */
5738
5739	static match
5740	match_typebound_call (gfc_symtree* varst)
5741	{
5742	gfc_expr* base;
5743	match m;
5744
5745	base = gfc_get_expr ();
5746	base->expr_type = EXPR_VARIABLE;
5747	base->symtree = varst;
5748	base->where = gfc_current_locus;
5749	gfc_set_sym_referenced (varst->n.sym);
5750
5751	m = gfc_match_varspec (base, 0, true, true);
5752	if (m == MATCH_NO)
5753	gfc_error ("Expected component reference at %C");
5754	if (m != MATCH_YES)
5755	{
5756	gfc_free_expr (base);
5757	return MATCH_ERROR;
5758	}
5759
5760	if (gfc_match_eos () != MATCH_YES)
5761	{
5762	gfc_error ("Junk after CALL at %C");
5763	gfc_free_expr (base);
5764	return MATCH_ERROR;
5765	}
5766
5767	if (base->expr_type == EXPR_COMPCALL)
5768	new_st.op = EXEC_COMPCALL;
5769	else if (base->expr_type == EXPR_PPC)
5770	new_st.op = EXEC_CALL_PPC;
5771	else
5772	{
5773	gfc_error ("Expected type-bound procedure or procedure pointer component "
5774	"at %C");
5775	gfc_free_expr (base);
5776	return MATCH_ERROR;
5777	}
5778	new_st.expr1 = base;
5779
5780	return MATCH_YES;
5781	}
5782
5783
5784	/* Match a CALL statement. The tricky part here are possible
5785	alternate return specifiers. We handle these by having all
5786	"subroutines" actually return an integer via a register that gives
5787	the return number. If the call specifies alternate returns, we
5788	generate code for a SELECT statement whose case clauses contain
5789	GOTOs to the various labels. */
5790
5791	match
5792	gfc_match_call (void)
5793	{
5794	char name[GFC_MAX_SYMBOL_LEN + 1];
5795	gfc_actual_arglist *a, *arglist;
5796	gfc_case *new_case;
5797	gfc_symbol *sym;
5798	gfc_symtree *st;
5799	gfc_code *c;
5800	match m;
5801	int i;
5802
5803	arglist = NULL;
5804
5805	m = gfc_match (target: "% %n", name);
5806	if (m == MATCH_NO)
5807	goto syntax;
5808	if (m != MATCH_YES)
5809	return m;
5810
5811	if (gfc_get_ha_sym_tree (name, &st))
5812	return MATCH_ERROR;
5813
5814	sym = st->n.sym;
5815
5816	/* If this is a variable of derived-type, it probably starts a type-bound
5817	procedure call. Associate variable targets have to be resolved for the
5818	target type. */
5819	if (((sym->attr.flavor != FL_PROCEDURE
5820	|| gfc_is_function_return_value (sym, gfc_current_ns))
5821	&& (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
5822	||
5823	(sym->assoc && sym->assoc->target
5824	&& gfc_resolve_expr (sym->assoc->target)
5825	&& (sym->assoc->target->ts.type == BT_DERIVED
5826	|| sym->assoc->target->ts.type == BT_CLASS)))
5827	return match_typebound_call (varst: st);
5828
5829	/* If it does not seem to be callable (include functions so that the
5830	right association is made. They are thrown out in resolution.)
5831	... */
5832	if (!sym->attr.generic
5833	&& !sym->attr.proc_pointer
5834	&& !sym->attr.subroutine
5835	&& !sym->attr.function)
5836	{
5837	if (!(sym->attr.external && !sym->attr.referenced))
5838	{
5839	/* ...create a symbol in this scope... */
5840	if (sym->ns != gfc_current_ns
5841	&& gfc_get_sym_tree (name, NULL, &st, false) == 1)
5842	return MATCH_ERROR;
5843
5844	if (sym != st->n.sym)
5845	sym = st->n.sym;
5846	}
5847
5848	/* ...and then to try to make the symbol into a subroutine. */
5849	if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
5850	return MATCH_ERROR;
5851	}
5852
5853	gfc_set_sym_referenced (sym);
5854
5855	if (gfc_match_eos () != MATCH_YES)
5856	{
5857	m = gfc_match_actual_arglist (1, &arglist);
5858	if (m == MATCH_NO)
5859	goto syntax;
5860	if (m == MATCH_ERROR)
5861	goto cleanup;
5862
5863	if (gfc_match_eos () != MATCH_YES)
5864	goto syntax;
5865	}
5866
5867	/* Walk the argument list looking for invalid BOZ. */
5868	for (a = arglist; a; a = a->next)
5869	if (a->expr && a->expr->ts.type == BT_BOZ)
5870	{
5871	gfc_error ("A BOZ literal constant at %L cannot appear as an actual "
5872	"argument in a subroutine reference", &a->expr->where);
5873	goto cleanup;
5874	}
5875
5876
5877	/* If any alternate return labels were found, construct a SELECT
5878	statement that will jump to the right place. */
5879
5880	i = 0;
5881	for (a = arglist; a; a = a->next)
5882	if (a->expr == NULL)
5883	{
5884	i = 1;
5885	break;
5886	}
5887
5888	if (i)
5889	{
5890	gfc_symtree *select_st;
5891	gfc_symbol *select_sym;
5892	char name[GFC_MAX_SYMBOL_LEN + 1];
5893
5894	new_st.next = c = gfc_get_code (EXEC_SELECT);
5895	sprintf (s: name, format: "_result_%s", sym->name);
5896	gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */
5897
5898	select_sym = select_st->n.sym;
5899	select_sym->ts.type = BT_INTEGER;
5900	select_sym->ts.kind = gfc_default_integer_kind;
5901	gfc_set_sym_referenced (select_sym);
5902	c->expr1 = gfc_get_expr ();
5903	c->expr1->expr_type = EXPR_VARIABLE;
5904	c->expr1->symtree = select_st;
5905	c->expr1->ts = select_sym->ts;
5906	c->expr1->where = gfc_current_locus;
5907
5908	i = 0;
5909	for (a = arglist; a; a = a->next)
5910	{
5911	if (a->expr != NULL)
5912	continue;
5913
5914	if (!gfc_reference_st_label (a->label, ST_LABEL_TARGET))
5915	continue;
5916
5917	i++;
5918
5919	c->block = gfc_get_code (EXEC_SELECT);
5920	c = c->block;
5921
5922	new_case = gfc_get_case ();
5923	new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
5924	new_case->low = new_case->high;
5925	c->ext.block.case_list = new_case;
5926
5927	c->next = gfc_get_code (EXEC_GOTO);
5928	c->next->label1 = a->label;
5929	}
5930	}
5931
5932	new_st.op = EXEC_CALL;
5933	new_st.symtree = st;
5934	new_st.ext.actual = arglist;
5935
5936	return MATCH_YES;
5937
5938	syntax:
5939	gfc_syntax_error (ST_CALL);
5940
5941	cleanup:
5942	gfc_free_actual_arglist (arglist);
5943	return MATCH_ERROR;
5944	}
5945
5946
5947	/* Given a name, return a pointer to the common head structure,
5948	creating it if it does not exist. If FROM_MODULE is nonzero, we
5949	mangle the name so that it doesn't interfere with commons defined
5950	in the using namespace.
5951	TODO: Add to global symbol tree. */
5952
5953	gfc_common_head *
5954	gfc_get_common (const char *name, int from_module)
5955	{
5956	gfc_symtree *st;
5957	static int serial = 0;
5958	char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
5959
5960	if (from_module)
5961	{
5962	/* A use associated common block is only needed to correctly layout
5963	the variables it contains. */
5964	snprintf (s: mangled_name, GFC_MAX_SYMBOL_LEN, format: "_%d_%s", serial++, name);
5965	st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
5966	}
5967	else
5968	{
5969	st = gfc_find_symtree (gfc_current_ns->common_root, name);
5970
5971	if (st == NULL)
5972	st = gfc_new_symtree (&gfc_current_ns->common_root, name);
5973	}
5974
5975	if (st->n.common == NULL)
5976	{
5977	st->n.common = gfc_get_common_head ();
5978	st->n.common->where = gfc_current_locus;
5979	strcpy (dest: st->n.common->name, src: name);
5980	}
5981
5982	return st->n.common;
5983	}
5984
5985
5986	/* Match a common block name. */
5987
5988	match
5989	gfc_match_common_name (char *name)
5990	{
5991	match m;
5992
5993	if (gfc_match_char (c: '/') == MATCH_NO)
5994	{
5995	name[0] = '\0';
5996	return MATCH_YES;
5997	}
5998
5999	if (gfc_match_char (c: '/') == MATCH_YES)
6000	{
6001	name[0] = '\0';
6002	return MATCH_YES;
6003	}
6004
6005	m = gfc_match_name (buffer: name);
6006
6007	if (m == MATCH_ERROR)
6008	return MATCH_ERROR;
6009	if (m == MATCH_YES && gfc_match_char (c: '/') == MATCH_YES)
6010	return MATCH_YES;
6011
6012	gfc_error ("Syntax error in common block name at %C");
6013	return MATCH_ERROR;
6014	}
6015
6016
6017	/* Match a COMMON statement. */
6018
6019	match
6020	gfc_match_common (void)
6021	{
6022	gfc_symbol *sym, **head, *tail, *other;
6023	char name[GFC_MAX_SYMBOL_LEN + 1];
6024	gfc_common_head *t;
6025	gfc_array_spec *as;
6026	gfc_equiv *e1, *e2;
6027	match m;
6028	char c;
6029
6030	/* COMMON has been matched. In free form source code, the next character
6031	needs to be whitespace or '/'. Check that here. Fixed form source
6032	code needs to be checked below. */
6033	c = gfc_peek_ascii_char ();
6034	if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c) && c != '/')
6035	return MATCH_NO;
6036
6037	as = NULL;
6038
6039	for (;;)
6040	{
6041	m = gfc_match_common_name (name);
6042	if (m == MATCH_ERROR)
6043	goto cleanup;
6044
6045	if (name[0] == '\0')
6046	{
6047	t = &gfc_current_ns->blank_common;
6048	if (t->head == NULL)
6049	t->where = gfc_current_locus;
6050	}
6051	else
6052	{
6053	t = gfc_get_common (name, from_module: 0);
6054	}
6055	head = &t->head;
6056
6057	if (*head == NULL)
6058	tail = NULL;
6059	else
6060	{
6061	tail = *head;
6062	while (tail->common_next)
6063	tail = tail->common_next;
6064	}
6065
6066	/* Grab the list of symbols. */
6067	for (;;)
6068	{
6069	m = gfc_match_symbol (matched_symbol: &sym, host_assoc: 0);
6070	if (m == MATCH_ERROR)
6071	goto cleanup;
6072	if (m == MATCH_NO)
6073	goto syntax;
6074
6075	/* See if we know the current common block is bind(c), and if
6076	so, then see if we can check if the symbol is (which it'll
6077	need to be). This can happen if the bind(c) attr stmt was
6078	applied to the common block, and the variable(s) already
6079	defined, before declaring the common block. */
6080	if (t->is_bind_c == 1)
6081	{
6082	if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
6083	{
6084	/* If we find an error, just print it and continue,
6085	cause it's just semantic, and we can see if there
6086	are more errors. */
6087	gfc_error_now ("Variable %qs at %L in common block %qs "
6088	"at %C must be declared with a C "
6089	"interoperable kind since common block "
6090	"%qs is bind(c)",
6091	sym->name, &(sym->declared_at), t->name,
6092	t->name);
6093	}
6094
6095	if (sym->attr.is_bind_c == 1)
6096	gfc_error_now ("Variable %qs in common block %qs at %C cannot "
6097	"be bind(c) since it is not global", sym->name,
6098	t->name);
6099	}
6100
6101	if (sym->attr.in_common)
6102	{
6103	gfc_error ("Symbol %qs at %C is already in a COMMON block",
6104	sym->name);
6105	goto cleanup;
6106	}
6107
6108	if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
6109	|| sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
6110	{
6111	if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol %qs at "
6112	"%C can only be COMMON in BLOCK DATA",
6113	sym->name))
6114	goto cleanup;
6115	}
6116
6117	/* F2018:R874: common-block-object is variable-name [ (array-spec) ]
6118	F2018:C8121: A variable-name shall not be a name made accessible
6119	by use association. */
6120	if (sym->attr.use_assoc)
6121	{
6122	gfc_error ("Symbol %qs at %C is USE associated from module %qs "
6123	"and cannot occur in COMMON", sym->name, sym->module);
6124	goto cleanup;
6125	}
6126
6127	/* Deal with an optional array specification after the
6128	symbol name. */
6129	m = gfc_match_array_spec (&as, true, true);
6130	if (m == MATCH_ERROR)
6131	goto cleanup;
6132
6133	if (m == MATCH_YES)
6134	{
6135	if (as->type != AS_EXPLICIT)
6136	{
6137	gfc_error ("Array specification for symbol %qs in COMMON "
6138	"at %C must be explicit", sym->name);
6139	goto cleanup;
6140	}
6141
6142	if (as->corank)
6143	{
6144	gfc_error ("Symbol %qs in COMMON at %C cannot be a "
6145	"coarray", sym->name);
6146	goto cleanup;
6147	}
6148
6149	if (!gfc_add_dimension (&sym->attr, sym->name, NULL))
6150	goto cleanup;
6151
6152	if (sym->attr.pointer)
6153	{
6154	gfc_error ("Symbol %qs in COMMON at %C cannot be a "
6155	"POINTER array", sym->name);
6156	goto cleanup;
6157	}
6158
6159	sym->as = as;
6160	as = NULL;
6161
6162	}
6163
6164	/* Add the in_common attribute, but ignore the reported errors
6165	if any, and continue matching. */
6166	gfc_add_in_common (&sym->attr, sym->name, NULL);
6167
6168	sym->common_block = t;
6169	sym->common_block->refs++;
6170
6171	if (tail != NULL)
6172	tail->common_next = sym;
6173	else
6174	*head = sym;
6175
6176	tail = sym;
6177
6178	sym->common_head = t;
6179
6180	/* Check to see if the symbol is already in an equivalence group.
6181	If it is, set the other members as being in common. */
6182	if (sym->attr.in_equivalence)
6183	{
6184	for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
6185	{
6186	for (e2 = e1; e2; e2 = e2->eq)
6187	if (e2->expr->symtree->n.sym == sym)
6188	goto equiv_found;
6189
6190	continue;
6191
6192	equiv_found:
6193
6194	for (e2 = e1; e2; e2 = e2->eq)
6195	{
6196	other = e2->expr->symtree->n.sym;
6197	if (other->common_head
6198	&& other->common_head != sym->common_head)
6199	{
6200	gfc_error ("Symbol %qs, in COMMON block %qs at "
6201	"%C is being indirectly equivalenced to "
6202	"another COMMON block %qs",
6203	sym->name, sym->common_head->name,
6204	other->common_head->name);
6205	goto cleanup;
6206	}
6207	other->attr.in_common = 1;
6208	other->common_head = t;
6209	}
6210	}
6211	}
6212
6213
6214	gfc_gobble_whitespace ();
6215	if (gfc_match_eos () == MATCH_YES)
6216	goto done;
6217	c = gfc_peek_ascii_char ();
6218	if (c == '/')
6219	break;
6220	if (c != ',')
6221	{
6222	/* In Fixed form source code, gfortran can end up here for an
6223	expression of the form COMMONI = RHS. This may not be an
6224	error, so return MATCH_NO. */
6225	if (gfc_current_form == FORM_FIXED && c == '=')
6226	{
6227	gfc_free_array_spec (as);
6228	return MATCH_NO;
6229	}
6230	goto syntax;
6231	}
6232	else
6233	gfc_match_char (c: ',');
6234
6235	gfc_gobble_whitespace ();
6236	if (gfc_peek_ascii_char () == '/')
6237	break;
6238	}
6239	}
6240
6241	done:
6242	return MATCH_YES;
6243
6244	syntax:
6245	gfc_syntax_error (ST_COMMON);
6246
6247	cleanup:
6248	gfc_free_array_spec (as);
6249	return MATCH_ERROR;
6250	}
6251
6252
6253	/* Match a BLOCK DATA program unit. */
6254
6255	match
6256	gfc_match_block_data (void)
6257	{
6258	char name[GFC_MAX_SYMBOL_LEN + 1];
6259	gfc_symbol *sym;
6260	match m;
6261
6262	if (!gfc_notify_std (GFC_STD_F2018_OBS, "BLOCK DATA construct at %L",
6263	&gfc_current_locus))
6264	return MATCH_ERROR;
6265
6266	if (gfc_match_eos () == MATCH_YES)
6267	{
6268	gfc_new_block = NULL;
6269	return MATCH_YES;
6270	}
6271
6272	m = gfc_match (target: "% %n%t", name);
6273	if (m != MATCH_YES)
6274	return MATCH_ERROR;
6275
6276	if (gfc_get_symbol (name, NULL, &sym))
6277	return MATCH_ERROR;
6278
6279	if (!gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL))
6280	return MATCH_ERROR;
6281
6282	gfc_new_block = sym;
6283
6284	return MATCH_YES;
6285	}
6286
6287
6288	/* Free a namelist structure. */
6289
6290	void
6291	gfc_free_namelist (gfc_namelist *name)
6292	{
6293	gfc_namelist *n;
6294
6295	for (; name; name = n)
6296	{
6297	n = name->next;
6298	free (ptr: name);
6299	}
6300	}
6301
6302
6303	/* Free an OpenMP namelist structure. */
6304
6305	void
6306	gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
6307	bool free_align_allocator,
6308	bool free_mem_traits_space, bool free_init)
6309	{
6310	gfc_omp_namelist *n;
6311	gfc_expr *last_allocator = NULL;
6312	char *last_init_interop = NULL;
6313
6314	for (; name; name = n)
6315	{
6316	gfc_free_expr (name->expr);
6317	if (free_align_allocator)
6318	gfc_free_expr (name->u.align);
6319	else if (free_mem_traits_space)
6320	{ } /* name->u.memspace_sym: shall not call gfc_free_symbol here. */
6321
6322	if (free_ns)
6323	gfc_free_namespace (name->u2.ns);
6324	else if (free_align_allocator)
6325	{
6326	if (last_allocator != name->u2.allocator)
6327	{
6328	last_allocator = name->u2.allocator;
6329	gfc_free_expr (name->u2.allocator);
6330	}
6331	}
6332	else if (free_mem_traits_space)
6333	{ } /* name->u2.traits_sym: shall not call gfc_free_symbol here. */
6334	else if (free_init)
6335	{
6336	if (name->u2.init_interop != last_init_interop)
6337	{
6338	last_init_interop = name->u2.init_interop;
6339	free (ptr: name->u2.init_interop);
6340	}
6341	}
6342	else if (name->u2.udr)
6343	{
6344	if (name->u2.udr->combiner)
6345	gfc_free_statement (name->u2.udr->combiner);
6346	if (name->u2.udr->initializer)
6347	gfc_free_statement (name->u2.udr->initializer);
6348	free (ptr: name->u2.udr);
6349	}
6350	n = name->next;
6351	free (ptr: name);
6352	}
6353	}
6354
6355
6356	/* Match a NAMELIST statement. */
6357
6358	match
6359	gfc_match_namelist (void)
6360	{
6361	gfc_symbol *group_name, *sym;
6362	gfc_namelist *nl;
6363	match m, m2;
6364
6365	m = gfc_match (target: " / %s /", &group_name);
6366	if (m == MATCH_NO)
6367	goto syntax;
6368	if (m == MATCH_ERROR)
6369	goto error;
6370
6371	for (;;)
6372	{
6373	if (group_name->ts.type != BT_UNKNOWN)
6374	{
6375	gfc_error ("Namelist group name %qs at %C already has a basic "
6376	"type of %s", group_name->name,
6377	gfc_typename (&group_name->ts));
6378	return MATCH_ERROR;
6379	}
6380
6381	/* A use associated name shall not be used as a namelist group name
6382	(e.g. F2003:C581). It is only supported as a legacy extension. */
6383	if (group_name->attr.flavor == FL_NAMELIST
6384	&& group_name->attr.use_assoc
6385	&& !gfc_notify_std (GFC_STD_LEGACY, "Namelist group name %qs "
6386	"at %C already is USE associated and can"
6387	"not be respecified.", group_name->name))
6388	return MATCH_ERROR;
6389
6390	if (group_name->attr.flavor != FL_NAMELIST
6391	&& !gfc_add_flavor (&group_name->attr, FL_NAMELIST,
6392	group_name->name, NULL))
6393	return MATCH_ERROR;
6394
6395	for (;;)
6396	{
6397	m = gfc_match_symbol (matched_symbol: &sym, host_assoc: 1);
6398	if (m == MATCH_NO)
6399	goto syntax;
6400	if (m == MATCH_ERROR)
6401	goto error;
6402
6403	if (sym->ts.type == BT_UNKNOWN)
6404	{
6405	if (gfc_current_ns->seen_implicit_none)
6406	{
6407	/* It is required that members of a namelist be declared
6408	before the namelist. We check this by checking if the
6409	symbol has a defined type for IMPLICIT NONE. */
6410	gfc_error ("Symbol %qs in namelist %qs at %C must be "
6411	"declared before the namelist is declared.",
6412	sym->name, group_name->name);
6413	gfc_error_check ();
6414	}
6415	else
6416	{
6417	/* Before the symbol is given an implicit type, check to
6418	see if the symbol is already available in the namespace,
6419	possibly through host association. Importantly, the
6420	symbol may be a user defined type. */
6421
6422	gfc_symbol *tmp;
6423
6424	gfc_find_symbol (sym->name, NULL, 1, &tmp);
6425	if (tmp && tmp->attr.generic
6426	&& (tmp = gfc_find_dt_in_generic (tmp)))
6427	{
6428	if (tmp->attr.flavor == FL_DERIVED)
6429	{
6430	gfc_error ("Derived type %qs at %L conflicts with "
6431	"namelist object %qs at %C",
6432	tmp->name, &tmp->declared_at, sym->name);
6433	goto error;
6434	}
6435	}
6436
6437	/* Set type of the symbol to its implicit default type. It is
6438	not allowed to set it later to any other type. */
6439	gfc_set_default_type (sym, 0, gfc_current_ns);
6440	}
6441	}
6442	if (sym->attr.in_namelist == 0
6443	&& !gfc_add_in_namelist (&sym->attr, sym->name, NULL))
6444	goto error;
6445
6446	/* Use gfc_error_check here, rather than goto error, so that
6447	these are the only errors for the next two lines. */
6448	if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
6449	{
6450	gfc_error ("Assumed size array %qs in namelist %qs at "
6451	"%C is not allowed", sym->name, group_name->name);
6452	gfc_error_check ();
6453	}
6454
6455	nl = gfc_get_namelist ();
6456	nl->sym = sym;
6457	sym->refs++;
6458
6459	if (group_name->namelist == NULL)
6460	group_name->namelist = group_name->namelist_tail = nl;
6461	else
6462	{
6463	group_name->namelist_tail->next = nl;
6464	group_name->namelist_tail = nl;
6465	}
6466
6467	if (gfc_match_eos () == MATCH_YES)
6468	goto done;
6469
6470	m = gfc_match_char (c: ',');
6471
6472	if (gfc_match_char (c: '/') == MATCH_YES)
6473	{
6474	m2 = gfc_match (target: " %s /", &group_name);
6475	if (m2 == MATCH_YES)
6476	break;
6477	if (m2 == MATCH_ERROR)
6478	goto error;
6479	goto syntax;
6480	}
6481
6482	if (m != MATCH_YES)
6483	goto syntax;
6484	}
6485	}
6486
6487	done:
6488	return MATCH_YES;
6489
6490	syntax:
6491	gfc_syntax_error (ST_NAMELIST);
6492
6493	error:
6494	return MATCH_ERROR;
6495	}
6496
6497
6498	/* Match a MODULE statement. */
6499
6500	match
6501	gfc_match_module (void)
6502	{
6503	match m;
6504
6505	m = gfc_match (target: " %s%t", &gfc_new_block);
6506	if (m != MATCH_YES)
6507	return m;
6508
6509	if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
6510	gfc_new_block->name, NULL))
6511	return MATCH_ERROR;
6512
6513	return MATCH_YES;
6514	}
6515
6516
6517	/* Free equivalence sets and lists. Recursively is the easiest way to
6518	do this. */
6519
6520	void
6521	gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop)
6522	{
6523	if (eq == stop)
6524	return;
6525
6526	gfc_free_equiv (eq->eq);
6527	gfc_free_equiv_until (eq: eq->next, stop);
6528	gfc_free_expr (eq->expr);
6529	free (ptr: eq);
6530	}
6531
6532
6533	void
6534	gfc_free_equiv (gfc_equiv *eq)
6535	{
6536	gfc_free_equiv_until (eq, NULL);
6537	}
6538
6539
6540	/* Match an EQUIVALENCE statement. */
6541
6542	match
6543	gfc_match_equivalence (void)
6544	{
6545	gfc_equiv *eq, *set, *tail;
6546	gfc_ref *ref;
6547	gfc_symbol *sym;
6548	match m;
6549	gfc_common_head *common_head = NULL;
6550	bool common_flag;
6551	int cnt;
6552	char c;
6553
6554	/* EQUIVALENCE has been matched. After gobbling any possible whitespace,
6555	the next character needs to be '('. Check that here, and return
6556	MATCH_NO for a variable of the form equivalence. */
6557	gfc_gobble_whitespace ();
6558	c = gfc_peek_ascii_char ();
6559	if (c != '(')
6560	return MATCH_NO;
6561
6562	tail = NULL;
6563
6564	for (;;)
6565	{
6566	eq = gfc_get_equiv ();
6567	if (tail == NULL)
6568	tail = eq;
6569
6570	eq->next = gfc_current_ns->equiv;
6571	gfc_current_ns->equiv = eq;
6572
6573	if (gfc_match_char (c: '(') != MATCH_YES)
6574	goto syntax;
6575
6576	set = eq;
6577	common_flag = false;
6578	cnt = 0;
6579
6580	for (;;)
6581	{
6582	m = gfc_match_equiv_variable (&set->expr);
6583	if (m == MATCH_ERROR)
6584	goto cleanup;
6585	if (m == MATCH_NO)
6586	goto syntax;
6587
6588	/* count the number of objects. */
6589	cnt++;
6590
6591	if (gfc_match_char (c: '%') == MATCH_YES)
6592	{
6593	gfc_error ("Derived type component %C is not a "
6594	"permitted EQUIVALENCE member");
6595	goto cleanup;
6596	}
6597
6598	for (ref = set->expr->ref; ref; ref = ref->next)
6599	if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
6600	{
6601	gfc_error ("Array reference in EQUIVALENCE at %C cannot "
6602	"be an array section");
6603	goto cleanup;
6604	}
6605
6606	sym = set->expr->symtree->n.sym;
6607
6608	if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL))
6609	goto cleanup;
6610	if (sym->ts.type == BT_CLASS
6611	&& CLASS_DATA (sym)
6612	&& !gfc_add_in_equivalence (&CLASS_DATA (sym)->attr,
6613	sym->name, NULL))
6614	goto cleanup;
6615
6616	if (sym->attr.in_common)
6617	{
6618	common_flag = true;
6619	common_head = sym->common_head;
6620	}
6621
6622	if (gfc_match_char (c: ')') == MATCH_YES)
6623	break;
6624
6625	if (gfc_match_char (c: ',') != MATCH_YES)
6626	goto syntax;
6627
6628	set->eq = gfc_get_equiv ();
6629	set = set->eq;
6630	}
6631
6632	if (cnt < 2)
6633	{
6634	gfc_error ("EQUIVALENCE at %C requires two or more objects");
6635	goto cleanup;
6636	}
6637
6638	/* If one of the members of an equivalence is in common, then
6639	mark them all as being in common. Before doing this, check
6640	that members of the equivalence group are not in different
6641	common blocks. */
6642	if (common_flag)
6643	for (set = eq; set; set = set->eq)
6644	{
6645	sym = set->expr->symtree->n.sym;
6646	if (sym->common_head && sym->common_head != common_head)
6647	{
6648	gfc_error ("Attempt to indirectly overlap COMMON "
6649	"blocks %s and %s by EQUIVALENCE at %C",
6650	sym->common_head->name, common_head->name);
6651	goto cleanup;
6652	}
6653	sym->attr.in_common = 1;
6654	sym->common_head = common_head;
6655	}
6656
6657	if (gfc_match_eos () == MATCH_YES)
6658	break;
6659	if (gfc_match_char (c: ',') != MATCH_YES)
6660	{
6661	gfc_error ("Expecting a comma in EQUIVALENCE at %C");
6662	goto cleanup;
6663	}
6664	}
6665
6666	if (!gfc_notify_std (GFC_STD_F2018_OBS, "EQUIVALENCE statement at %C"))
6667	return MATCH_ERROR;
6668
6669	return MATCH_YES;
6670
6671	syntax:
6672	gfc_syntax_error (ST_EQUIVALENCE);
6673
6674	cleanup:
6675	eq = tail->next;
6676	tail->next = NULL;
6677
6678	gfc_free_equiv (eq: gfc_current_ns->equiv);
6679	gfc_current_ns->equiv = eq;
6680
6681	return MATCH_ERROR;
6682	}
6683
6684
6685	/* Check that a statement function is not recursive. This is done by looking
6686	for the statement function symbol(sym) by looking recursively through its
6687	expression(e). If a reference to sym is found, true is returned.
6688	12.5.4 requires that any variable of function that is implicitly typed
6689	shall have that type confirmed by any subsequent type declaration. The
6690	implicit typing is conveniently done here. */
6691	static bool
6692	recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
6693
6694	static bool
6695	check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6696	{
6697
6698	if (e == NULL)
6699	return false;
6700
6701	switch (e->expr_type)
6702	{
6703	case EXPR_FUNCTION:
6704	if (e->symtree == NULL)
6705	return false;
6706
6707	/* Check the name before testing for nested recursion! */
6708	if (sym->name == e->symtree->n.sym->name)
6709	return true;
6710
6711	/* Catch recursion via other statement functions. */
6712	if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
6713	&& e->symtree->n.sym->value
6714	&& recursive_stmt_fcn (e->symtree->n.sym->value, sym))
6715	return true;
6716
6717	if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
6718	gfc_set_default_type (e->symtree->n.sym, 0, NULL);
6719
6720	break;
6721
6722	case EXPR_VARIABLE:
6723	if (e->symtree && sym->name == e->symtree->n.sym->name)
6724	return true;
6725
6726	if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
6727	gfc_set_default_type (e->symtree->n.sym, 0, NULL);
6728	break;
6729
6730	default:
6731	break;
6732	}
6733
6734	return false;
6735	}
6736
6737
6738	static bool
6739	recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
6740	{
6741	return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
6742	}
6743
6744
6745	/* Check for invalid uses of statement function dummy arguments in body. */
6746
6747	static bool
6748	chk_stmt_fcn_body (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6749	{
6750	gfc_formal_arglist *formal;
6751
6752	if (e == NULL || e->symtree == NULL || e->expr_type != EXPR_FUNCTION)
6753	return false;
6754
6755	for (formal = sym->formal; formal; formal = formal->next)
6756	{
6757	if (formal->sym == e->symtree->n.sym)
6758	{
6759	gfc_error ("Invalid use of statement function argument at %L",
6760	&e->where);
6761	return true;
6762	}
6763	}
6764
6765	return false;
6766	}
6767
6768
6769	/* Match a statement function declaration. It is so easy to match
6770	non-statement function statements with a MATCH_ERROR as opposed to
6771	MATCH_NO that we suppress error message in most cases. */
6772
6773	match
6774	gfc_match_st_function (void)
6775	{
6776	gfc_error_buffer old_error;
6777	gfc_symbol *sym;
6778	gfc_expr *expr;
6779	match m;
6780	char name[GFC_MAX_SYMBOL_LEN + 1];
6781	locus old_locus;
6782	bool fcn;
6783	gfc_formal_arglist *ptr;
6784
6785	/* Read the possible statement function name, and then check to see if
6786	a symbol is already present in the namespace. Record if it is a
6787	function and whether it has been referenced. */
6788	fcn = false;
6789	ptr = NULL;
6790	old_locus = gfc_current_locus;
6791	m = gfc_match_name (buffer: name);
6792	if (m == MATCH_YES)
6793	{
6794	gfc_find_symbol (name, NULL, 1, &sym);
6795	if (sym && sym->attr.function && !sym->attr.referenced)
6796	{
6797	fcn = true;
6798	ptr = sym->formal;
6799	}
6800	}
6801
6802	gfc_current_locus = old_locus;
6803	m = gfc_match_symbol (matched_symbol: &sym, host_assoc: 0);
6804	if (m != MATCH_YES)
6805	return m;
6806
6807	gfc_push_error (&old_error);
6808
6809	if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL))
6810	goto undo_error;
6811
6812	if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
6813	goto undo_error;
6814
6815	m = gfc_match (target: " = %e%t", &expr);
6816	if (m == MATCH_NO)
6817	goto undo_error;
6818
6819	gfc_free_error (&old_error);
6820
6821	if (m == MATCH_ERROR)
6822	return m;
6823
6824	if (recursive_stmt_fcn (e: expr, sym))
6825	{
6826	gfc_error ("Statement function at %L is recursive", &expr->where);
6827	return MATCH_ERROR;
6828	}
6829
6830	if (fcn && ptr != sym->formal)
6831	{
6832	gfc_error ("Statement function %qs at %L conflicts with function name",
6833	sym->name, &expr->where);
6834	return MATCH_ERROR;
6835	}
6836
6837	if (gfc_traverse_expr (expr, sym, chk_stmt_fcn_body, 0))
6838	return MATCH_ERROR;
6839
6840	sym->value = expr;
6841
6842	if ((gfc_current_state () == COMP_FUNCTION
6843	|| gfc_current_state () == COMP_SUBROUTINE)
6844	&& gfc_state_stack->previous->state == COMP_INTERFACE)
6845	{
6846	gfc_error ("Statement function at %L cannot appear within an INTERFACE",
6847	&expr->where);
6848	return MATCH_ERROR;
6849	}
6850
6851	if (!gfc_notify_std (GFC_STD_F95_OBS, "Statement function at %C"))
6852	return MATCH_ERROR;
6853
6854	return MATCH_YES;
6855
6856	undo_error:
6857	gfc_pop_error (&old_error);
6858	return MATCH_NO;
6859	}
6860
6861
6862	/* Match an assignment to a pointer function (F2008). This could, in
6863	general be ambiguous with a statement function. In this implementation
6864	it remains so if it is the first statement after the specification
6865	block. */
6866
6867	match
6868	gfc_match_ptr_fcn_assign (void)
6869	{
6870	gfc_error_buffer old_error;
6871	locus old_loc;
6872	gfc_symbol *sym;
6873	gfc_expr *expr;
6874	match m;
6875	char name[GFC_MAX_SYMBOL_LEN + 1];
6876
6877	old_loc = gfc_current_locus;
6878	m = gfc_match_name (buffer: name);
6879	if (m != MATCH_YES)
6880	return m;
6881
6882	gfc_find_symbol (name, NULL, 1, &sym);
6883	if (sym && sym->attr.flavor != FL_PROCEDURE)
6884	return MATCH_NO;
6885
6886	gfc_push_error (&old_error);
6887
6888	if (sym && sym->attr.function)
6889	goto match_actual_arglist;
6890
6891	gfc_current_locus = old_loc;
6892	m = gfc_match_symbol (matched_symbol: &sym, host_assoc: 0);
6893	if (m != MATCH_YES)
6894	return m;
6895
6896	if (!gfc_add_procedure (&sym->attr, PROC_UNKNOWN, sym->name, NULL))
6897	goto undo_error;
6898
6899	match_actual_arglist:
6900	gfc_current_locus = old_loc;
6901	m = gfc_match (target: " %e", &expr);
6902	if (m != MATCH_YES)
6903	goto undo_error;
6904
6905	new_st.op = EXEC_ASSIGN;
6906	new_st.expr1 = expr;
6907	expr = NULL;
6908
6909	m = gfc_match (target: " = %e%t", &expr);
6910	if (m != MATCH_YES)
6911	goto undo_error;
6912
6913	new_st.expr2 = expr;
6914	return MATCH_YES;
6915
6916	undo_error:
6917	gfc_pop_error (&old_error);
6918	return MATCH_NO;
6919	}
6920
6921
6922	/***************** SELECT CASE subroutines ******************/
6923
6924	/* Free a single case structure. */
6925
6926	static void
6927	free_case (gfc_case *p)
6928	{
6929	if (p->low == p->high)
6930	p->high = NULL;
6931	gfc_free_expr (p->low);
6932	gfc_free_expr (p->high);
6933	free (ptr: p);
6934	}
6935
6936
6937	/* Free a list of case structures. */
6938
6939	void
6940	gfc_free_case_list (gfc_case *p)
6941	{
6942	gfc_case *q;
6943
6944	for (; p; p = q)
6945	{
6946	q = p->next;
6947	free_case (p);
6948	}
6949	}
6950
6951
6952	/* Match a single case selector. Combining the requirements of F08:C830
6953	and F08:C832 (R838) means that the case-value must have either CHARACTER,
6954	INTEGER, or LOGICAL type. */
6955
6956	static match
6957	match_case_selector (gfc_case **cp)
6958	{
6959	gfc_case *c;
6960	match m;
6961
6962	c = gfc_get_case ();
6963	c->where = gfc_current_locus;
6964
6965	if (gfc_match_char (c: ':') == MATCH_YES)
6966	{
6967	m = gfc_match_init_expr (&c->high);
6968	if (m == MATCH_NO)
6969	goto need_expr;
6970	if (m == MATCH_ERROR)
6971	goto cleanup;
6972
6973	if (c->high->ts.type != BT_LOGICAL && c->high->ts.type != BT_INTEGER
6974	&& c->high->ts.type != BT_CHARACTER
6975	&& (!flag_unsigned
6976	|| (flag_unsigned && c->high->ts.type != BT_UNSIGNED)))
6977	{
6978	gfc_error ("Expression in CASE selector at %L cannot be %s",
6979	&c->high->where, gfc_typename (&c->high->ts));
6980	goto cleanup;
6981	}
6982	}
6983	else
6984	{
6985	m = gfc_match_init_expr (&c->low);
6986	if (m == MATCH_ERROR)
6987	goto cleanup;
6988	if (m == MATCH_NO)
6989	goto need_expr;
6990
6991	if (c->low->ts.type != BT_LOGICAL && c->low->ts.type != BT_INTEGER
6992	&& c->low->ts.type != BT_CHARACTER
6993	&& (!flag_unsigned
6994	|| (flag_unsigned && c->low->ts.type != BT_UNSIGNED)))
6995	{
6996	gfc_error ("Expression in CASE selector at %L cannot be %s",
6997	&c->low->where, gfc_typename (&c->low->ts));
6998	goto cleanup;
6999	}
7000
7001	/* If we're not looking at a ':' now, make a range out of a single
7002	target. Else get the upper bound for the case range. */
7003	if (gfc_match_char (c: ':') != MATCH_YES)
7004	c->high = c->low;
7005	else
7006	{
7007	m = gfc_match_init_expr (&c->high);
7008	if (m == MATCH_ERROR)
7009	goto cleanup;
7010	if (m == MATCH_YES
7011	&& c->high->ts.type != BT_LOGICAL
7012	&& c->high->ts.type != BT_INTEGER
7013	&& c->high->ts.type != BT_CHARACTER
7014	&& (!flag_unsigned
7015	|| (flag_unsigned && c->high->ts.type != BT_UNSIGNED)))
7016	{
7017	gfc_error ("Expression in CASE selector at %L cannot be %s",
7018	&c->high->where, gfc_typename (c->high));
7019	goto cleanup;
7020	}
7021	/* MATCH_NO is fine. It's OK if nothing is there! */
7022	}
7023	}
7024
7025	if (c->low && c->low->rank != 0)
7026	{
7027	gfc_error ("Expression in CASE selector at %L must be scalar",
7028	&c->low->where);
7029	goto cleanup;
7030	}
7031	if (c->high && c->high->rank != 0)
7032	{
7033	gfc_error ("Expression in CASE selector at %L must be scalar",
7034	&c->high->where);
7035	goto cleanup;
7036	}
7037
7038	*cp = c;
7039	return MATCH_YES;
7040
7041	need_expr:
7042	gfc_error ("Expected initialization expression in CASE at %C");
7043
7044	cleanup:
7045	free_case (p: c);
7046	return MATCH_ERROR;
7047	}
7048
7049
7050	/* Match the end of a case statement. */
7051
7052	static match
7053	match_case_eos (void)
7054	{
7055	char name[GFC_MAX_SYMBOL_LEN + 1];
7056	match m;
7057
7058	if (gfc_match_eos () == MATCH_YES)
7059	return MATCH_YES;
7060
7061	/* If the case construct doesn't have a case-construct-name, we
7062	should have matched the EOS. */
7063	if (!gfc_current_block ())
7064	return MATCH_NO;
7065
7066	gfc_gobble_whitespace ();
7067
7068	m = gfc_match_name (buffer: name);
7069	if (m != MATCH_YES)
7070	return m;
7071
7072	if (strcmp (s1: name, gfc_current_block ()->name) != 0)
7073	{
7074	gfc_error ("Expected block name %qs of SELECT construct at %C",
7075	gfc_current_block ()->name);
7076	return MATCH_ERROR;
7077	}
7078
7079	return gfc_match_eos ();
7080	}
7081
7082
7083	/* Match a SELECT statement. */
7084
7085	match
7086	gfc_match_select (void)
7087	{
7088	gfc_expr *expr;
7089	match m;
7090
7091	m = gfc_match_label ();
7092	if (m == MATCH_ERROR)
7093	return m;
7094
7095	m = gfc_match (target: " select case ( %e )%t", &expr);
7096	if (m != MATCH_YES)
7097	return m;
7098
7099	new_st.op = EXEC_SELECT;
7100	new_st.expr1 = expr;
7101
7102	return MATCH_YES;
7103	}
7104
7105
7106	/* Transfer the selector typespec to the associate name. */
7107
7108	static void
7109	copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector,
7110	bool select_type = false)
7111	{
7112	gfc_ref *ref;
7113	gfc_symbol *assoc_sym;
7114	int rank = 0, corank = 0;
7115
7116	assoc_sym = associate->symtree->n.sym;
7117
7118	/* At this stage the expression rank and arrayspec dimensions have
7119	not been completely sorted out. We must get the expr2->rank
7120	right here, so that the correct class container is obtained. */
7121	ref = selector->ref;
7122	while (ref && ref->next)
7123	ref = ref->next;
7124
7125	if (selector->ts.type == BT_CLASS
7126	&& CLASS_DATA (selector)
7127	&& CLASS_DATA (selector)->as
7128	&& CLASS_DATA (selector)->as->type == AS_ASSUMED_RANK)
7129	{
7130	assoc_sym->attr.dimension = 1;
7131	assoc_sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
7132	corank = assoc_sym->as->corank;
7133	goto build_class_sym;
7134	}
7135	else if (selector->ts.type == BT_CLASS
7136	&& CLASS_DATA (selector)
7137	&& CLASS_DATA (selector)->as
7138	&& ((ref && ref->type == REF_ARRAY)
7139	|| selector->expr_type == EXPR_OP))
7140	{
7141	/* Ensure that the array reference type is set. We cannot use
7142	gfc_resolve_expr at this point, so the usable parts of
7143	resolve.cc(resolve_array_ref) are employed to do it. */
7144	if (ref && ref->u.ar.type == AR_UNKNOWN)
7145	{
7146	ref->u.ar.type = AR_ELEMENT;
7147	for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
7148	if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
7149	|| ref->u.ar.dimen_type[i] == DIMEN_VECTOR
7150	|| (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
7151	&& ref->u.ar.start[i] && ref->u.ar.start[i]->rank))
7152	{
7153	ref->u.ar.type = AR_SECTION;
7154	break;
7155	}
7156	}
7157
7158	if (!ref || ref->u.ar.type == AR_FULL)
7159	{
7160	selector->rank = CLASS_DATA (selector)->as->rank;
7161	selector->corank = CLASS_DATA (selector)->as->corank;
7162	}
7163	else if (ref->u.ar.type == AR_SECTION)
7164	{
7165	selector->rank = ref->u.ar.dimen;
7166	selector->corank = ref->u.ar.codimen;
7167	}
7168	else
7169	selector->rank = 0;
7170
7171	rank = selector->rank;
7172	corank = selector->corank;
7173	}
7174
7175	if (rank)
7176	{
7177	if (ref)
7178	{
7179	for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
7180	if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT
7181	|| (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
7182	&& ref->u.ar.end[i] == NULL
7183	&& ref->u.ar.stride[i] == NULL))
7184	rank--;
7185	}
7186
7187	if (rank)
7188	{
7189	assoc_sym->attr.dimension = 1;
7190	assoc_sym->as = gfc_get_array_spec ();
7191	assoc_sym->as->rank = rank;
7192	assoc_sym->as->type = AS_DEFERRED;
7193	}
7194	}
7195
7196	if (corank != 0 && rank == 0)
7197	{
7198	if (!assoc_sym->as)
7199	assoc_sym->as = gfc_get_array_spec ();
7200	assoc_sym->as->corank = corank;
7201	assoc_sym->attr.codimension = 1;
7202	}
7203	else if (corank == 0 && rank == 0 && assoc_sym->as)
7204	{
7205	free (ptr: assoc_sym->as);
7206	assoc_sym->as = NULL;
7207	}
7208	build_class_sym:
7209	/* Deal with the very specific case of a SELECT_TYPE selector being an
7210	associate_name whose type has been identified by component references.
7211	It must be assumed that it will be identified as a CLASS expression,
7212	so convert it now. */
7213	if (select_type
7214	&& IS_INFERRED_TYPE (selector)
7215	&& selector->ts.type == BT_DERIVED)
7216	{
7217	gfc_find_derived_vtab (selector->ts.u.derived);
7218	/* The correct class container has to be available. */
7219	assoc_sym->ts.u.derived = selector->ts.u.derived;
7220	assoc_sym->ts.type = BT_CLASS;
7221	assoc_sym->attr.pointer = 1;
7222	if (!selector->ts.u.derived->attr.is_class)
7223	gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as);
7224	associate->ts = assoc_sym->ts;
7225	}
7226	else if (selector->ts.type == BT_CLASS)
7227	{
7228	/* The correct class container has to be available. */
7229	assoc_sym->ts.type = BT_CLASS;
7230	assoc_sym->ts.u.derived = CLASS_DATA (selector)
7231	? CLASS_DATA (selector)->ts.u.derived
7232	: selector->ts.u.derived;
7233	assoc_sym->attr.pointer = 1;
7234	gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as);
7235	}
7236	}
7237
7238
7239	/* Build the associate name */
7240	static int
7241	build_associate_name (const char *name, gfc_expr **e1, gfc_expr **e2)
7242	{
7243	gfc_expr *expr1 = *e1;
7244	gfc_expr *expr2 = *e2;
7245	gfc_symbol *sym;
7246
7247	/* For the case where the associate name is already an associate name. */
7248	if (!expr2)
7249	expr2 = expr1;
7250	expr1 = gfc_get_expr ();
7251	expr1->expr_type = EXPR_VARIABLE;
7252	expr1->where = expr2->where;
7253	if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
7254	return 1;
7255
7256	sym = expr1->symtree->n.sym;
7257	if (expr2->ts.type == BT_UNKNOWN)
7258	sym->attr.untyped = 1;
7259	else
7260	copy_ts_from_selector_to_associate (associate: expr1, selector: expr2, select_type: true);
7261
7262	sym->attr.flavor = FL_VARIABLE;
7263	sym->attr.referenced = 1;
7264	sym->attr.class_ok = 1;
7265
7266	*e1 = expr1;
7267	*e2 = expr2;
7268	return 0;
7269	}
7270
7271
7272	/* Push the current selector onto the SELECT TYPE stack. */
7273
7274	static void
7275	select_type_push (gfc_symbol *sel)
7276	{
7277	gfc_select_type_stack *top = gfc_get_select_type_stack ();
7278	top->selector = sel;
7279	top->tmp = NULL;
7280	top->prev = select_type_stack;
7281
7282	select_type_stack = top;
7283	}
7284
7285
7286	/* Set the temporary for the current intrinsic SELECT TYPE selector. */
7287
7288	static gfc_symtree *
7289	select_intrinsic_set_tmp (gfc_typespec *ts, const char *var_name)
7290	{
7291	/* Keep size in sync with the buffer size in resolve_select_type as it
7292	determines the final name through truncation. */
7293	char name[GFC_MAX_SYMBOL_LEN + 12 + 1];
7294	gfc_symtree *tmp;
7295	HOST_WIDE_INT charlen = 0;
7296	gfc_symbol *selector = select_type_stack->selector;
7297	gfc_symbol *sym;
7298
7299	if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
7300	return NULL;
7301
7302	if (selector->ts.type == BT_CLASS && !selector->attr.class_ok)
7303	return NULL;
7304
7305	/* Case value == NULL corresponds to SELECT TYPE cases otherwise
7306	the values correspond to SELECT rank cases. */
7307	if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
7308	&& ts->u.cl->length->expr_type == EXPR_CONSTANT)
7309	charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
7310
7311	if (ts->type != BT_CHARACTER)
7312	snprintf (s: name, maxlen: sizeof (name), format: "__tmp_%s_%d_%s",
7313	gfc_basic_typename (ts->type), ts->kind, var_name);
7314	else
7315	snprintf (s: name, maxlen: sizeof (name),
7316	format: "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d_%s",
7317	gfc_basic_typename (ts->type), charlen, ts->kind, var_name);
7318
7319	gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
7320	sym = tmp->n.sym;
7321	gfc_add_type (sym, ts, NULL);
7322
7323	/* Copy across the array spec to the selector. */
7324	if (selector->ts.type == BT_CLASS
7325	&& (CLASS_DATA (selector)->attr.dimension
7326	|| CLASS_DATA (selector)->attr.codimension))
7327	{
7328	sym->attr.pointer = 1;
7329	sym->attr.dimension = CLASS_DATA (selector)->attr.dimension;
7330	sym->attr.codimension = CLASS_DATA (selector)->attr.codimension;
7331	sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
7332	}
7333
7334	gfc_set_sym_referenced (sym);
7335	gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL);
7336	sym->attr.select_type_temporary = 1;
7337
7338	return tmp;
7339	}
7340
7341
7342	/* Set up a temporary for the current TYPE IS / CLASS IS branch . */
7343
7344	static void
7345	select_type_set_tmp (gfc_typespec *ts)
7346	{
7347	char name[GFC_MAX_SYMBOL_LEN + 12 + 1];
7348	gfc_symtree *tmp = NULL;
7349	gfc_symbol *selector = select_type_stack->selector;
7350	gfc_symbol *sym;
7351	gfc_expr *expr2;
7352
7353	if (!ts)
7354	{
7355	select_type_stack->tmp = NULL;
7356	return;
7357	}
7358
7359	gfc_expr *select_type_expr = gfc_state_stack->construct->expr1;
7360	const char *var_name = gfc_var_name_for_select_type_temp (select_type_expr);
7361	tmp = select_intrinsic_set_tmp (ts, var_name);
7362
7363	if (tmp == NULL)
7364	{
7365	if (!ts->u.derived)
7366	return;
7367
7368	if (ts->type == BT_CLASS)
7369	snprintf (s: name, maxlen: sizeof (name), format: "__tmp_class_%s_%s", ts->u.derived->name,
7370	var_name);
7371	else
7372	snprintf (s: name, maxlen: sizeof (name), format: "__tmp_type_%s_%s", ts->u.derived->name,
7373	var_name);
7374
7375	gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
7376	sym = tmp->n.sym;
7377	gfc_add_type (sym, ts, NULL);
7378
7379	/* If the SELECT TYPE selector is a function we might be able to obtain
7380	a typespec from the result. Since the function might not have been
7381	parsed yet we have to check that there is indeed a result symbol. */
7382	if (selector->ts.type == BT_UNKNOWN
7383	&& gfc_state_stack->construct
7384
7385	&& (expr2 = gfc_state_stack->construct->expr2)
7386	&& expr2->expr_type == EXPR_FUNCTION
7387	&& expr2->symtree
7388	&& expr2->symtree->n.sym && expr2->symtree->n.sym->result)
7389	selector->ts = expr2->symtree->n.sym->result->ts;
7390
7391	if (selector->ts.type == BT_CLASS
7392	&& selector->attr.class_ok
7393	&& selector->ts.u.derived && CLASS_DATA (selector))
7394	{
7395	sym->attr.pointer
7396	= CLASS_DATA (selector)->attr.class_pointer;
7397
7398	/* Copy across the array spec to the selector. */
7399	if (CLASS_DATA (selector)->attr.dimension
7400	|| CLASS_DATA (selector)->attr.codimension)
7401	{
7402	sym->attr.dimension
7403	= CLASS_DATA (selector)->attr.dimension;
7404	sym->attr.codimension
7405	= CLASS_DATA (selector)->attr.codimension;
7406	if (CLASS_DATA (selector)->as->type != AS_EXPLICIT)
7407	sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
7408	else
7409	{
7410	sym->as = gfc_get_array_spec();
7411	sym->as->rank = CLASS_DATA (selector)->as->rank;
7412	sym->as->type = AS_DEFERRED;
7413	}
7414	}
7415	}
7416
7417	gfc_set_sym_referenced (sym);
7418	gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL);
7419	sym->attr.select_type_temporary = 1;
7420
7421	if (ts->type == BT_CLASS)
7422	gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
7423	}
7424	else
7425	sym = tmp->n.sym;
7426
7427
7428	/* Add an association for it, so the rest of the parser knows it is
7429	an associate-name. The target will be set during resolution. */
7430	sym->assoc = gfc_get_association_list ();
7431	sym->assoc->dangling = 1;
7432	sym->assoc->st = tmp;
7433
7434	select_type_stack->tmp = tmp;
7435	}
7436
7437
7438	/* Match a SELECT TYPE statement. */
7439
7440	match
7441	gfc_match_select_type (void)
7442	{
7443	gfc_expr *expr1, *expr2 = NULL;
7444	match m;
7445	char name[GFC_MAX_SYMBOL_LEN + 1];
7446	bool class_array;
7447	gfc_namespace *ns = gfc_current_ns;
7448
7449	m = gfc_match_label ();
7450	if (m == MATCH_ERROR)
7451	return m;
7452
7453	m = gfc_match (target: " select type ( ");
7454	if (m != MATCH_YES)
7455	return m;
7456
7457	if (gfc_current_state() == COMP_MODULE
7458	|| gfc_current_state() == COMP_SUBMODULE)
7459	{
7460	gfc_error ("SELECT TYPE at %C cannot appear in this scope");
7461	return MATCH_ERROR;
7462	}
7463
7464	gfc_current_ns = gfc_build_block_ns (ns);
7465	m = gfc_match (target: " %n => %e", name, &expr2);
7466	if (m == MATCH_YES)
7467	{
7468	if (build_associate_name (name, e1: &expr1, e2: &expr2))
7469	{
7470	m = MATCH_ERROR;
7471	goto cleanup;
7472	}
7473	}
7474	else
7475	{
7476	m = gfc_match (target: " %e ", &expr1);
7477	if (m != MATCH_YES)
7478	{
7479	std::swap (a&: ns, b&: gfc_current_ns);
7480	gfc_free_namespace (ns);
7481	return m;
7482	}
7483	}
7484
7485	m = gfc_match (target: " )%t");
7486	if (m != MATCH_YES)
7487	{
7488	gfc_error ("parse error in SELECT TYPE statement at %C");
7489	goto cleanup;
7490	}
7491
7492	/* This ghastly expression seems to be needed to distinguish a CLASS
7493	array, which can have a reference, from other expressions that
7494	have references, such as derived type components, and are not
7495	allowed by the standard.
7496	TODO: see if it is sufficient to exclude component and substring
7497	references. */
7498	class_array = (expr1->expr_type == EXPR_VARIABLE
7499	&& expr1->ts.type == BT_CLASS
7500	&& CLASS_DATA (expr1)
7501	&& (strcmp (CLASS_DATA (expr1)->name, s2: "_data") == 0)
7502	&& (CLASS_DATA (expr1)->attr.dimension
7503	|| CLASS_DATA (expr1)->attr.codimension)
7504	&& expr1->ref
7505	&& expr1->ref->type == REF_ARRAY
7506	&& expr1->ref->u.ar.type == AR_FULL
7507	&& expr1->ref->next == NULL);
7508
7509	/* Check for F03:C811 (F08:C835). */
7510	if (!expr2 && (expr1->expr_type != EXPR_VARIABLE
7511	|| (!class_array && expr1->ref != NULL)))
7512	{
7513	gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
7514	"use associate-name=>");
7515	m = MATCH_ERROR;
7516	goto cleanup;
7517	}
7518
7519	/* Prevent an existing associate name from reuse here by pushing expr1 to
7520	expr2 and building a new associate name. */
7521	if (!expr2 && expr1->symtree->n.sym->assoc
7522	&& !expr1->symtree->n.sym->attr.select_type_temporary
7523	&& !expr1->symtree->n.sym->attr.select_rank_temporary
7524	&& build_associate_name (name: expr1->symtree->n.sym->name, e1: &expr1, e2: &expr2))
7525	{
7526	m = MATCH_ERROR;
7527	goto cleanup;
7528	}
7529
7530	/* Select type namespaces are not filled until resolution. Therefore, the
7531	namespace must be marked as having an inferred type associate name if
7532	either expr1 is an inferred type variable or expr2 is. In the latter
7533	case, as well as the symbol being marked as inferred type, it might be
7534	that it has not been detected to be so. In this case the target has
7535	unknown type. Once the namespace is marked, the fixups in resolution can
7536	be triggered. */
7537	if (!expr2
7538	&& expr1->symtree->n.sym->assoc
7539	&& expr1->symtree->n.sym->assoc->inferred_type)
7540	gfc_current_ns->assoc_name_inferred = 1;
7541	else if (expr2 && expr2->expr_type == EXPR_VARIABLE
7542	&& expr2->symtree->n.sym->assoc)
7543	{
7544	if (expr2->symtree->n.sym->assoc->inferred_type)
7545	gfc_current_ns->assoc_name_inferred = 1;
7546	else if (expr2->symtree->n.sym->assoc->target
7547	&& expr2->symtree->n.sym->assoc->target->ts.type == BT_UNKNOWN)
7548	gfc_current_ns->assoc_name_inferred = 1;
7549	}
7550
7551	new_st.op = EXEC_SELECT_TYPE;
7552	new_st.expr1 = expr1;
7553	new_st.expr2 = expr2;
7554	new_st.ext.block.ns = gfc_current_ns;
7555
7556	select_type_push (sel: expr1->symtree->n.sym);
7557	gfc_current_ns = ns;
7558
7559	return MATCH_YES;
7560
7561	cleanup:
7562	gfc_free_expr (expr1);
7563	gfc_free_expr (expr2);
7564	gfc_undo_symbols ();
7565	std::swap (a&: ns, b&: gfc_current_ns);
7566	gfc_free_namespace (ns);
7567	return m;
7568	}
7569
7570
7571	/* Set the temporary for the current intrinsic SELECT RANK selector. */
7572
7573	static void
7574	select_rank_set_tmp (gfc_typespec *ts, int *case_value)
7575	{
7576	char name[2 * GFC_MAX_SYMBOL_LEN];
7577	char tname[GFC_MAX_SYMBOL_LEN + 7];
7578	gfc_symtree *tmp;
7579	gfc_symbol *selector = select_type_stack->selector;
7580	gfc_symbol *sym;
7581	gfc_symtree *st;
7582	HOST_WIDE_INT charlen = 0;
7583
7584	if (case_value == NULL)
7585	return;
7586
7587	if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
7588	&& ts->u.cl->length->expr_type == EXPR_CONSTANT)
7589	charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
7590
7591	if (ts->type == BT_CLASS)
7592	sprintf (s: tname, format: "class_%s", ts->u.derived->name);
7593	else if (ts->type == BT_DERIVED)
7594	sprintf (s: tname, format: "type_%s", ts->u.derived->name);
7595	else if (ts->type != BT_CHARACTER)
7596	sprintf (s: tname, format: "%s_%d", gfc_basic_typename (ts->type), ts->kind);
7597	else
7598	sprintf (s: tname, format: "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
7599	gfc_basic_typename (ts->type), charlen, ts->kind);
7600
7601	/* Case value == NULL corresponds to SELECT TYPE cases otherwise
7602	the values correspond to SELECT rank cases. */
7603	if (*case_value >=0)
7604	sprintf (s: name, format: "__tmp_%s_rank_%d", tname, *case_value);
7605	else
7606	sprintf (s: name, format: "__tmp_%s_rank_m%d", tname, -*case_value);
7607
7608	gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
7609	if (st)
7610	return;
7611
7612	gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
7613	sym = tmp->n.sym;
7614	gfc_add_type (sym, ts, NULL);
7615
7616	/* Copy across the array spec to the selector. */
7617	if (selector->ts.type == BT_CLASS)
7618	{
7619	sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived;
7620	sym->attr.pointer = CLASS_DATA (selector)->attr.pointer;
7621	sym->attr.allocatable = CLASS_DATA (selector)->attr.allocatable;
7622	sym->attr.target = CLASS_DATA (selector)->attr.target;
7623	sym->attr.class_ok = 0;
7624	if (case_value && *case_value != 0)
7625	{
7626	sym->attr.dimension = 1;
7627	sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
7628	if (*case_value > 0)
7629	{
7630	sym->as->type = AS_DEFERRED;
7631	sym->as->rank = *case_value;
7632	}
7633	else if (*case_value == -1)
7634	{
7635	sym->as->type = AS_ASSUMED_SIZE;
7636	sym->as->rank = 1;
7637	}
7638	}
7639	}
7640	else
7641	{
7642	sym->attr.pointer = selector->attr.pointer;
7643	sym->attr.allocatable = selector->attr.allocatable;
7644	sym->attr.target = selector->attr.target;
7645	if (case_value && *case_value != 0)
7646	{
7647	sym->attr.dimension = 1;
7648	sym->as = gfc_copy_array_spec (selector->as);
7649	if (*case_value > 0)
7650	{
7651	sym->as->type = AS_DEFERRED;
7652	sym->as->rank = *case_value;
7653	}
7654	else if (*case_value == -1)
7655	{
7656	sym->as->type = AS_ASSUMED_SIZE;
7657	sym->as->rank = 1;
7658	}
7659	}
7660	}
7661
7662	gfc_set_sym_referenced (sym);
7663	gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL);
7664	sym->attr.select_type_temporary = 1;
7665	if (case_value)
7666	sym->attr.select_rank_temporary = 1;
7667
7668	if (ts->type == BT_CLASS)
7669	gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
7670
7671	/* Add an association for it, so the rest of the parser knows it is
7672	an associate-name. The target will be set during resolution. */
7673	sym->assoc = gfc_get_association_list ();
7674	sym->assoc->dangling = 1;
7675	sym->assoc->st = tmp;
7676
7677	select_type_stack->tmp = tmp;
7678	}
7679
7680
7681	/* Match a SELECT RANK statement. */
7682
7683	match
7684	gfc_match_select_rank (void)
7685	{
7686	gfc_expr *expr1, *expr2 = NULL;
7687	match m;
7688	char name[GFC_MAX_SYMBOL_LEN + 1];
7689	gfc_symbol *sym, *sym2;
7690	gfc_namespace *ns = gfc_current_ns;
7691	gfc_array_spec *as = NULL;
7692
7693	m = gfc_match_label ();
7694	if (m == MATCH_ERROR)
7695	return m;
7696
7697	m = gfc_match (target: " select% rank ( ");
7698	if (m != MATCH_YES)
7699	return m;
7700
7701	if (!gfc_notify_std (GFC_STD_F2018, "SELECT RANK statement at %C"))
7702	return MATCH_NO;
7703
7704	gfc_current_ns = gfc_build_block_ns (ns);
7705	m = gfc_match (target: " %n => %e", name, &expr2);
7706
7707	if (m == MATCH_YES)
7708	{
7709	/* If expr2 corresponds to an implicitly typed variable, then the
7710	actual type of the variable may not have been set. Set it here. */
7711	if (!gfc_current_ns->seen_implicit_none
7712	&& expr2->expr_type == EXPR_VARIABLE
7713	&& expr2->ts.type == BT_UNKNOWN
7714	&& expr2->symtree && expr2->symtree->n.sym)
7715	{
7716	gfc_set_default_type (expr2->symtree->n.sym, 0, gfc_current_ns);
7717	expr2->ts.type = expr2->symtree->n.sym->ts.type;
7718	}
7719
7720	expr1 = gfc_get_expr ();
7721	expr1->expr_type = EXPR_VARIABLE;
7722	expr1->where = expr2->where;
7723	expr1->ref = gfc_copy_ref (expr2->ref);
7724	if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
7725	{
7726	m = MATCH_ERROR;
7727	goto cleanup;
7728	}
7729
7730	sym = expr1->symtree->n.sym;
7731
7732	if (expr2->symtree)
7733	{
7734	sym2 = expr2->symtree->n.sym;
7735	as = (sym2->ts.type == BT_CLASS
7736	&& CLASS_DATA (sym2)) ? CLASS_DATA (sym2)->as : sym2->as;
7737	}
7738
7739	if (expr2->expr_type != EXPR_VARIABLE
7740	|| !(as && as->type == AS_ASSUMED_RANK))
7741	{
7742	gfc_error ("The SELECT RANK selector at %C must be an assumed "
7743	"rank variable");
7744	m = MATCH_ERROR;
7745	goto cleanup;
7746	}
7747
7748	if (expr2->ts.type == BT_CLASS && CLASS_DATA (sym2))
7749	{
7750	copy_ts_from_selector_to_associate (associate: expr1, selector: expr2);
7751
7752	sym->attr.flavor = FL_VARIABLE;
7753	sym->attr.referenced = 1;
7754	sym->attr.class_ok = 1;
7755	CLASS_DATA (sym)->attr.allocatable = CLASS_DATA (sym2)->attr.allocatable;
7756	CLASS_DATA (sym)->attr.pointer = CLASS_DATA (sym2)->attr.pointer;
7757	CLASS_DATA (sym)->attr.target = CLASS_DATA (sym2)->attr.target;
7758	sym->attr.pointer = 1;
7759	}
7760	else
7761	{
7762	sym->ts = sym2->ts;
7763	sym->as = gfc_copy_array_spec (sym2->as);
7764	sym->attr.dimension = 1;
7765
7766	sym->attr.flavor = FL_VARIABLE;
7767	sym->attr.referenced = 1;
7768	sym->attr.class_ok = sym2->attr.class_ok;
7769	sym->attr.allocatable = sym2->attr.allocatable;
7770	sym->attr.pointer = sym2->attr.pointer;
7771	sym->attr.target = sym2->attr.target;
7772	}
7773	}
7774	else
7775	{
7776	m = gfc_match (target: " %e ", &expr1);
7777
7778	if (m != MATCH_YES)
7779	{
7780	gfc_undo_symbols ();
7781	std::swap (a&: ns, b&: gfc_current_ns);
7782	gfc_free_namespace (ns);
7783	return m;
7784	}
7785
7786	if (expr1->symtree)
7787	{
7788	sym = expr1->symtree->n.sym;
7789	as = (sym->ts.type == BT_CLASS
7790	&& CLASS_DATA (sym)) ? CLASS_DATA (sym)->as : sym->as;
7791	}
7792
7793	if (expr1->expr_type != EXPR_VARIABLE
7794	|| !(as && as->type == AS_ASSUMED_RANK))
7795	{
7796	gfc_error("The SELECT RANK selector at %C must be an assumed "
7797	"rank variable");
7798	m = MATCH_ERROR;
7799	goto cleanup;
7800	}
7801	}
7802
7803	m = gfc_match (target: " )%t");
7804	if (m != MATCH_YES)
7805	{
7806	gfc_error ("parse error in SELECT RANK statement at %C");
7807	goto cleanup;
7808	}
7809
7810	new_st.op = EXEC_SELECT_RANK;
7811	new_st.expr1 = expr1;
7812	new_st.expr2 = expr2;
7813	new_st.ext.block.ns = gfc_current_ns;
7814
7815	select_type_push (sel: expr1->symtree->n.sym);
7816	gfc_current_ns = ns;
7817
7818	return MATCH_YES;
7819
7820	cleanup:
7821	gfc_free_expr (expr1);
7822	gfc_free_expr (expr2);
7823	gfc_undo_symbols ();
7824	std::swap (a&: ns, b&: gfc_current_ns);
7825	gfc_free_namespace (ns);
7826	return m;
7827	}
7828
7829
7830	/* Match a CASE statement. */
7831
7832	match
7833	gfc_match_case (void)
7834	{
7835	gfc_case *c, *head, *tail;
7836	match m;
7837
7838	head = tail = NULL;
7839
7840	if (gfc_current_state () != COMP_SELECT)
7841	{
7842	gfc_error ("Unexpected CASE statement at %C");
7843	return MATCH_ERROR;
7844	}
7845
7846	if (gfc_match (target: "% default") == MATCH_YES)
7847	{
7848	m = match_case_eos ();
7849	if (m == MATCH_NO)
7850	goto syntax;
7851	if (m == MATCH_ERROR)
7852	goto cleanup;
7853
7854	new_st.op = EXEC_SELECT;
7855	c = gfc_get_case ();
7856	c->where = gfc_current_locus;
7857	new_st.ext.block.case_list = c;
7858	return MATCH_YES;
7859	}
7860
7861	if (gfc_match_char (c: '(') != MATCH_YES)
7862	goto syntax;
7863
7864	for (;;)
7865	{
7866	if (match_case_selector (cp: &c) == MATCH_ERROR)
7867	goto cleanup;
7868
7869	if (head == NULL)
7870	head = c;
7871	else
7872	tail->next = c;
7873
7874	tail = c;
7875
7876	if (gfc_match_char (c: ')') == MATCH_YES)
7877	break;
7878	if (gfc_match_char (c: ',') != MATCH_YES)
7879	goto syntax;
7880	}
7881
7882	m = match_case_eos ();
7883	if (m == MATCH_NO)
7884	goto syntax;
7885	if (m == MATCH_ERROR)
7886	goto cleanup;
7887
7888	new_st.op = EXEC_SELECT;
7889	new_st.ext.block.case_list = head;
7890
7891	return MATCH_YES;
7892
7893	syntax:
7894	gfc_error ("Syntax error in CASE specification at %C");
7895
7896	cleanup:
7897	gfc_free_case_list (p: head); /* new_st is cleaned up in parse.cc. */
7898	return MATCH_ERROR;
7899	}
7900
7901
7902	/* Match a TYPE IS statement. */
7903
7904	match
7905	gfc_match_type_is (void)
7906	{
7907	gfc_case *c = NULL;
7908	match m;
7909
7910	if (gfc_current_state () != COMP_SELECT_TYPE)
7911	{
7912	gfc_error ("Unexpected TYPE IS statement at %C");
7913	return MATCH_ERROR;
7914	}
7915
7916	if (gfc_match_char (c: '(') != MATCH_YES)
7917	goto syntax;
7918
7919	c = gfc_get_case ();
7920	c->where = gfc_current_locus;
7921
7922	m = gfc_match_type_spec (ts: &c->ts);
7923	if (m == MATCH_NO)
7924	goto syntax;
7925	if (m == MATCH_ERROR)
7926	goto cleanup;
7927
7928	if (gfc_match_char (c: ')') != MATCH_YES)
7929	goto syntax;
7930
7931	m = match_case_eos ();
7932	if (m == MATCH_NO)
7933	goto syntax;
7934	if (m == MATCH_ERROR)
7935	goto cleanup;
7936
7937	new_st.op = EXEC_SELECT_TYPE;
7938	new_st.ext.block.case_list = c;
7939
7940	if (c->ts.type == BT_DERIVED && c->ts.u.derived
7941	&& (c->ts.u.derived->attr.sequence
7942	|| c->ts.u.derived->attr.is_bind_c))
7943	{
7944	gfc_error ("The type-spec shall not specify a sequence derived "
7945	"type or a type with the BIND attribute in SELECT "
7946	"TYPE at %C [F2003:C815]");
7947	return MATCH_ERROR;
7948	}
7949
7950	if (IS_PDT (c) && gfc_spec_list_type (type_param_spec_list,
7951	c->ts.u.derived) != SPEC_ASSUMED)
7952	{
7953	gfc_error ("All the LEN type parameters in the TYPE IS statement "
7954	"at %C must be ASSUMED");
7955	return MATCH_ERROR;
7956	}
7957
7958	/* Create temporary variable. */
7959	select_type_set_tmp (ts: &c->ts);
7960
7961	return MATCH_YES;
7962
7963	syntax:
7964
7965	if (!gfc_error_check ())
7966	gfc_error ("Syntax error in TYPE IS specification at %C");
7967
7968	cleanup:
7969	if (c != NULL)
7970	gfc_free_case_list (p: c); /* new_st is cleaned up in parse.cc. */
7971	return MATCH_ERROR;
7972	}
7973
7974
7975	/* Match a CLASS IS or CLASS DEFAULT statement. */
7976
7977	match
7978	gfc_match_class_is (void)
7979	{
7980	gfc_case *c = NULL;
7981	match m;
7982
7983	if (gfc_current_state () != COMP_SELECT_TYPE)
7984	return MATCH_NO;
7985
7986	if (gfc_match (target: "% default") == MATCH_YES)
7987	{
7988	m = match_case_eos ();
7989	if (m == MATCH_NO)
7990	goto syntax;
7991	if (m == MATCH_ERROR)
7992	goto cleanup;
7993
7994	new_st.op = EXEC_SELECT_TYPE;
7995	c = gfc_get_case ();
7996	c->where = gfc_current_locus;
7997	c->ts.type = BT_UNKNOWN;
7998	new_st.ext.block.case_list = c;
7999	select_type_set_tmp (NULL);
8000	return MATCH_YES;
8001	}
8002
8003	m = gfc_match (target: "% is");
8004	if (m == MATCH_NO)
8005	goto syntax;
8006	if (m == MATCH_ERROR)
8007	goto cleanup;
8008
8009	if (gfc_match_char (c: '(') != MATCH_YES)
8010	goto syntax;
8011
8012	c = gfc_get_case ();
8013	c->where = gfc_current_locus;
8014
8015	m = match_derived_type_spec (ts: &c->ts);
8016	if (m == MATCH_NO)
8017	goto syntax;
8018	if (m == MATCH_ERROR)
8019	goto cleanup;
8020
8021	if (c->ts.type == BT_DERIVED)
8022	c->ts.type = BT_CLASS;
8023
8024	if (gfc_match_char (c: ')') != MATCH_YES)
8025	goto syntax;
8026
8027	m = match_case_eos ();
8028	if (m == MATCH_NO)
8029	goto syntax;
8030	if (m == MATCH_ERROR)
8031	goto cleanup;
8032
8033	new_st.op = EXEC_SELECT_TYPE;
8034	new_st.ext.block.case_list = c;
8035
8036	/* Create temporary variable. */
8037	select_type_set_tmp (ts: &c->ts);
8038
8039	return MATCH_YES;
8040
8041	syntax:
8042	gfc_error ("Syntax error in CLASS IS specification at %C");
8043
8044	cleanup:
8045	if (c != NULL)
8046	gfc_free_case_list (p: c); /* new_st is cleaned up in parse.cc. */
8047	return MATCH_ERROR;
8048	}
8049
8050
8051	/* Match a RANK statement. */
8052
8053	match
8054	gfc_match_rank_is (void)
8055	{
8056	gfc_case *c = NULL;
8057	match m;
8058	int case_value;
8059
8060	if (gfc_current_state () != COMP_SELECT_RANK)
8061	{
8062	gfc_error ("Unexpected RANK statement at %C");
8063	return MATCH_ERROR;
8064	}
8065
8066	if (gfc_match (target: "% default") == MATCH_YES)
8067	{
8068	m = match_case_eos ();
8069	if (m == MATCH_NO)
8070	goto syntax;
8071	if (m == MATCH_ERROR)
8072	goto cleanup;
8073
8074	new_st.op = EXEC_SELECT_RANK;
8075	c = gfc_get_case ();
8076	c->ts.type = BT_UNKNOWN;
8077	c->where = gfc_current_locus;
8078	new_st.ext.block.case_list = c;
8079	select_type_stack->tmp = NULL;
8080	return MATCH_YES;
8081	}
8082
8083	if (gfc_match_char (c: '(') != MATCH_YES)
8084	goto syntax;
8085
8086	c = gfc_get_case ();
8087	c->where = gfc_current_locus;
8088	c->ts = select_type_stack->selector->ts;
8089
8090	m = gfc_match_expr (&c->low);
8091	if (m == MATCH_NO)
8092	{
8093	if (gfc_match_char (c: '*') == MATCH_YES)
8094	c->low = gfc_get_int_expr (gfc_default_integer_kind,
8095	NULL, -1);
8096	else
8097	goto syntax;
8098
8099	case_value = -1;
8100	}
8101	else if (m == MATCH_YES)
8102	{
8103	/* F2018: R1150 */
8104	if (c->low->expr_type != EXPR_CONSTANT
8105	|| c->low->ts.type != BT_INTEGER
8106	|| c->low->rank)
8107	{
8108	gfc_error ("The SELECT RANK CASE expression at %C must be a "
8109	"scalar, integer constant");
8110	goto cleanup;
8111	}
8112
8113	case_value = (int) mpz_get_si (c->low->value.integer);
8114	/* F2018: C1151 */
8115	if ((case_value < 0) || (case_value > GFC_MAX_DIMENSIONS))
8116	{
8117	gfc_error ("The value of the SELECT RANK CASE expression at "
8118	"%C must not be less than zero or greater than %d",
8119	GFC_MAX_DIMENSIONS);
8120	goto cleanup;
8121	}
8122	}
8123	else
8124	goto cleanup;
8125
8126	if (gfc_match_char (c: ')') != MATCH_YES)
8127	goto syntax;
8128
8129	m = match_case_eos ();
8130	if (m == MATCH_NO)
8131	goto syntax;
8132	if (m == MATCH_ERROR)
8133	goto cleanup;
8134
8135	new_st.op = EXEC_SELECT_RANK;
8136	new_st.ext.block.case_list = c;
8137
8138	/* Create temporary variable. Recycle the select type code. */
8139	select_rank_set_tmp (ts: &c->ts, case_value: &case_value);
8140
8141	return MATCH_YES;
8142
8143	syntax:
8144	gfc_error ("Syntax error in RANK specification at %C");
8145
8146	cleanup:
8147	if (c != NULL)
8148	gfc_free_case_list (p: c); /* new_st is cleaned up in parse.cc. */
8149	return MATCH_ERROR;
8150	}
8151
8152	/********************* WHERE subroutines ********************/
8153
8154	/* Match the rest of a simple WHERE statement that follows an IF statement.
8155	*/
8156
8157	static match
8158	match_simple_where (void)
8159	{
8160	gfc_expr *expr;
8161	gfc_code *c;
8162	match m;
8163
8164	m = gfc_match (target: " ( %e )", &expr);
8165	if (m != MATCH_YES)
8166	return m;
8167
8168	m = gfc_match_assignment ();
8169	if (m == MATCH_NO)
8170	goto syntax;
8171	if (m == MATCH_ERROR)
8172	goto cleanup;
8173
8174	if (gfc_match_eos () != MATCH_YES)
8175	goto syntax;
8176
8177	c = gfc_get_code (EXEC_WHERE);
8178	c->expr1 = expr;
8179
8180	c->next = XCNEW (gfc_code);
8181	*c->next = new_st;
8182	c->next->loc = gfc_current_locus;
8183	gfc_clear_new_st ();
8184
8185	new_st.op = EXEC_WHERE;
8186	new_st.block = c;
8187
8188	return MATCH_YES;
8189
8190	syntax:
8191	gfc_syntax_error (ST_WHERE);
8192
8193	cleanup:
8194	gfc_free_expr (expr);
8195	return MATCH_ERROR;
8196	}
8197
8198
8199	/* Match a WHERE statement. */
8200
8201	match
8202	gfc_match_where (gfc_statement *st)
8203	{
8204	gfc_expr *expr;
8205	match m0, m;
8206	gfc_code *c;
8207
8208	m0 = gfc_match_label ();
8209	if (m0 == MATCH_ERROR)
8210	return m0;
8211
8212	m = gfc_match (target: " where ( %e )", &expr);
8213	if (m != MATCH_YES)
8214	return m;
8215
8216	if (gfc_match_eos () == MATCH_YES)
8217	{
8218	*st = ST_WHERE_BLOCK;
8219	new_st.op = EXEC_WHERE;
8220	new_st.expr1 = expr;
8221	return MATCH_YES;
8222	}
8223
8224	m = gfc_match_assignment ();
8225	if (m == MATCH_NO)
8226	gfc_syntax_error (ST_WHERE);
8227
8228	if (m != MATCH_YES)
8229	{
8230	gfc_free_expr (expr);
8231	return MATCH_ERROR;
8232	}
8233
8234	/* We've got a simple WHERE statement. */
8235	*st = ST_WHERE;
8236	c = gfc_get_code (EXEC_WHERE);
8237	c->expr1 = expr;
8238
8239	/* Put in the assignment. It will not be processed by add_statement, so we
8240	need to copy the location here. */
8241
8242	c->next = XCNEW (gfc_code);
8243	*c->next = new_st;
8244	c->next->loc = gfc_current_locus;
8245	gfc_clear_new_st ();
8246
8247	new_st.op = EXEC_WHERE;
8248	new_st.block = c;
8249
8250	return MATCH_YES;
8251	}
8252
8253
8254	/* Match an ELSEWHERE statement. We leave behind a WHERE node in
8255	new_st if successful. */
8256
8257	match
8258	gfc_match_elsewhere (void)
8259	{
8260	char name[GFC_MAX_SYMBOL_LEN + 1];
8261	gfc_expr *expr;
8262	match m;
8263
8264	if (gfc_current_state () != COMP_WHERE)
8265	{
8266	gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
8267	return MATCH_ERROR;
8268	}
8269
8270	expr = NULL;
8271
8272	if (gfc_match_char (c: '(') == MATCH_YES)
8273	{
8274	m = gfc_match_expr (&expr);
8275	if (m == MATCH_NO)
8276	goto syntax;
8277	if (m == MATCH_ERROR)
8278	return MATCH_ERROR;
8279
8280	if (gfc_match_char (c: ')') != MATCH_YES)
8281	goto syntax;
8282	}
8283
8284	if (gfc_match_eos () != MATCH_YES)
8285	{
8286	/* Only makes sense if we have a where-construct-name. */
8287	if (!gfc_current_block ())
8288	{
8289	m = MATCH_ERROR;
8290	goto cleanup;
8291	}
8292	/* Better be a name at this point. */
8293	m = gfc_match_name (buffer: name);
8294	if (m == MATCH_NO)
8295	goto syntax;
8296	if (m == MATCH_ERROR)
8297	goto cleanup;
8298
8299	if (gfc_match_eos () != MATCH_YES)
8300	goto syntax;
8301
8302	if (strcmp (s1: name, gfc_current_block ()->name) != 0)
8303	{
8304	gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
8305	name, gfc_current_block ()->name);
8306	goto cleanup;
8307	}
8308	}
8309
8310	new_st.op = EXEC_WHERE;
8311	new_st.expr1 = expr;
8312	return MATCH_YES;
8313
8314	syntax:
8315	gfc_syntax_error (ST_ELSEWHERE);
8316
8317	cleanup:
8318	gfc_free_expr (expr);
8319	return MATCH_ERROR;
8320	}
8321