/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/match.cc

Bug Summary

File:	build/gcc/fortran/match.cc
Warning:	line 7344, column 4 Value stored to 'm' is never read

Annotated Source Code

Press '?' to see keyboard shortcuts

Show analyzer invocation

clang -cc1 -cc1 -triple x86_64-suse-linux -analyze -disable-free -clear-ast-before-backend -disable-llvm-verifier -discard-value-names -main-file-name match.cc -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=cplusplus -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -analyzer-config-compatibility-mode=true -mrelocation-model static -mframe-pointer=none -fmath-errno -ffp-contract=on -fno-rounding-math -mconstructor-aliases -funwind-tables=2 -target-cpu x86-64 -tune-cpu generic -debugger-tuning=gdb -fcoverage-compilation-dir=/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -resource-dir /usr/lib64/clang/15.0.7 -D IN_GCC_FRONTEND -D IN_GCC -D HAVE_CONFIG_H -I . -I fortran -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../include -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcpp/include -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcody -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber/bid -I ../libdecnumber -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libbacktrace -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13 -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13/x86_64-suse-linux -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13/backward -internal-isystem /usr/lib64/clang/15.0.7/include -internal-isystem /usr/local/include -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../x86_64-suse-linux/include -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -Wno-narrowing -Wwrite-strings -Wno-long-long -Wno-variadic-macros -Wno-overlength-strings -fdeprecated-macro -fdebug-compilation-dir=/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -ferror-limit 19 -fno-rtti -fgnuc-version=4.2.1 -vectorize-loops -vectorize-slp -analyzer-output=plist-html -analyzer-config silence-checkers=core.NullDereference -faddrsig -D__GCC_HAVE_DWARF2_CFI_ASM=1 -o /buildworker/marxinbox-gcc-clang-static-analyzer/objdir/clang-static-analyzer/2023-03-27-141847-20772-1/report-8p9Qv3.plist -x c++ /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/match.cc

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