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