1	/* Perform type resolution on the various structures.
2	Copyright (C) 2001-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 "bitmap.h"
26	#include "gfortran.h"
27	#include "arith.h" /* For gfc_compare_expr(). */
28	#include "dependency.h"
29	#include "data.h"
30	#include "target-memory.h" /* for gfc_simplify_transfer */
31	#include "constructor.h"
32
33	/* Types used in equivalence statements. */
34
35	enum seq_type
36	{
37	SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
38	};
39
40	/* Stack to keep track of the nesting of blocks as we move through the
41	code. See resolve_branch() and gfc_resolve_code(). */
42
43	typedef struct code_stack
44	{
45	struct gfc_code *head, *current;
46	struct code_stack *prev;
47
48	/* This bitmap keeps track of the targets valid for a branch from
49	inside this block except for END {IF|SELECT}s of enclosing
50	blocks. */
51	bitmap reachable_labels;
52	}
53	code_stack;
54
55	static code_stack *cs_base = NULL;
56
57
58	/* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
59
60	static int forall_flag;
61	int gfc_do_concurrent_flag;
62
63	/* True when we are resolving an expression that is an actual argument to
64	a procedure. */
65	static bool actual_arg = false;
66	/* True when we are resolving an expression that is the first actual argument
67	to a procedure. */
68	static bool first_actual_arg = false;
69
70
71	/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
72
73	static int omp_workshare_flag;
74
75	/* True if we are processing a formal arglist. The corresponding function
76	resets the flag each time that it is read. */
77	static bool formal_arg_flag = false;
78
79	/* True if we are resolving a specification expression. */
80	static bool specification_expr = false;
81
82	/* The id of the last entry seen. */
83	static int current_entry_id;
84
85	/* We use bitmaps to determine if a branch target is valid. */
86	static bitmap_obstack labels_obstack;
87
88	/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
89	static bool inquiry_argument = false;
90
91
92	bool
93	gfc_is_formal_arg (void)
94	{
95	return formal_arg_flag;
96	}
97
98	/* Is the symbol host associated? */
99	static bool
100	is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
101	{
102	for (ns = ns->parent; ns; ns = ns->parent)
103	{
104	if (sym->ns == ns)
105	return true;
106	}
107
108	return false;
109	}
110
111	/* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
112	an ABSTRACT derived-type. If where is not NULL, an error message with that
113	locus is printed, optionally using name. */
114
115	static bool
116	resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
117	{
118	if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
119	{
120	if (where)
121	{
122	if (name)
123	gfc_error ("%qs at %L is of the ABSTRACT type %qs",
124	name, where, ts->u.derived->name);
125	else
126	gfc_error ("ABSTRACT type %qs used at %L",
127	ts->u.derived->name, where);
128	}
129
130	return false;
131	}
132
133	return true;
134	}
135
136
137	static bool
138	check_proc_interface (gfc_symbol *ifc, locus *where)
139	{
140	/* Several checks for F08:C1216. */
141	if (ifc->attr.procedure)
142	{
143	gfc_error ("Interface %qs at %L is declared "
144	"in a later PROCEDURE statement", ifc->name, where);
145	return false;
146	}
147	if (ifc->generic)
148	{
149	/* For generic interfaces, check if there is
150	a specific procedure with the same name. */
151	gfc_interface *gen = ifc->generic;
152	while (gen && strcmp (s1: gen->sym->name, s2: ifc->name) != 0)
153	gen = gen->next;
154	if (!gen)
155	{
156	gfc_error ("Interface %qs at %L may not be generic",
157	ifc->name, where);
158	return false;
159	}
160	}
161	if (ifc->attr.proc == PROC_ST_FUNCTION)
162	{
163	gfc_error ("Interface %qs at %L may not be a statement function",
164	ifc->name, where);
165	return false;
166	}
167	if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
168	|| gfc_is_intrinsic (ifc, 1, ifc->declared_at))
169	ifc->attr.intrinsic = 1;
170	if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
171	{
172	gfc_error ("Intrinsic procedure %qs not allowed in "
173	"PROCEDURE statement at %L", ifc->name, where);
174	return false;
175	}
176	if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
177	{
178	gfc_error ("Interface %qs at %L must be explicit", ifc->name, where);
179	return false;
180	}
181	return true;
182	}
183
184
185	static void resolve_symbol (gfc_symbol *sym);
186
187
188	/* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
189
190	static bool
191	resolve_procedure_interface (gfc_symbol *sym)
192	{
193	gfc_symbol *ifc = sym->ts.interface;
194
195	if (!ifc)
196	return true;
197
198	if (ifc == sym)
199	{
200	gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
201	sym->name, &sym->declared_at);
202	return false;
203	}
204	if (!check_proc_interface (ifc, where: &sym->declared_at))
205	return false;
206
207	if (ifc->attr.if_source || ifc->attr.intrinsic)
208	{
209	/* Resolve interface and copy attributes. */
210	resolve_symbol (sym: ifc);
211	if (ifc->attr.intrinsic)
212	gfc_resolve_intrinsic (ifc, &ifc->declared_at);
213
214	if (ifc->result)
215	{
216	sym->ts = ifc->result->ts;
217	sym->attr.allocatable = ifc->result->attr.allocatable;
218	sym->attr.pointer = ifc->result->attr.pointer;
219	sym->attr.dimension = ifc->result->attr.dimension;
220	sym->attr.class_ok = ifc->result->attr.class_ok;
221	sym->as = gfc_copy_array_spec (ifc->result->as);
222	sym->result = sym;
223	}
224	else
225	{
226	sym->ts = ifc->ts;
227	sym->attr.allocatable = ifc->attr.allocatable;
228	sym->attr.pointer = ifc->attr.pointer;
229	sym->attr.dimension = ifc->attr.dimension;
230	sym->attr.class_ok = ifc->attr.class_ok;
231	sym->as = gfc_copy_array_spec (ifc->as);
232	}
233	sym->ts.interface = ifc;
234	sym->attr.function = ifc->attr.function;
235	sym->attr.subroutine = ifc->attr.subroutine;
236
237	sym->attr.pure = ifc->attr.pure;
238	sym->attr.elemental = ifc->attr.elemental;
239	sym->attr.contiguous = ifc->attr.contiguous;
240	sym->attr.recursive = ifc->attr.recursive;
241	sym->attr.always_explicit = ifc->attr.always_explicit;
242	sym->attr.ext_attr |= ifc->attr.ext_attr;
243	sym->attr.is_bind_c = ifc->attr.is_bind_c;
244	/* Copy char length. */
245	if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
246	{
247	sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
248	if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
249	&& !gfc_resolve_expr (sym->ts.u.cl->length))
250	return false;
251	}
252	}
253
254	return true;
255	}
256
257
258	/* Resolve types of formal argument lists. These have to be done early so that
259	the formal argument lists of module procedures can be copied to the
260	containing module before the individual procedures are resolved
261	individually. We also resolve argument lists of procedures in interface
262	blocks because they are self-contained scoping units.
263
264	Since a dummy argument cannot be a non-dummy procedure, the only
265	resort left for untyped names are the IMPLICIT types. */
266
267	void
268	gfc_resolve_formal_arglist (gfc_symbol *proc)
269	{
270	gfc_formal_arglist *f;
271	gfc_symbol *sym;
272	bool saved_specification_expr;
273	int i;
274
275	if (proc->result != NULL)
276	sym = proc->result;
277	else
278	sym = proc;
279
280	if (gfc_elemental (proc)
281	|| sym->attr.pointer || sym->attr.allocatable
282	|| (sym->as && sym->as->rank != 0))
283	{
284	proc->attr.always_explicit = 1;
285	sym->attr.always_explicit = 1;
286	}
287
288	formal_arg_flag = true;
289
290	for (f = proc->formal; f; f = f->next)
291	{
292	gfc_array_spec *as;
293
294	sym = f->sym;
295
296	if (sym == NULL)
297	{
298	/* Alternate return placeholder. */
299	if (gfc_elemental (proc))
300	gfc_error ("Alternate return specifier in elemental subroutine "
301	"%qs at %L is not allowed", proc->name,
302	&proc->declared_at);
303	if (proc->attr.function)
304	gfc_error ("Alternate return specifier in function "
305	"%qs at %L is not allowed", proc->name,
306	&proc->declared_at);
307	continue;
308	}
309	else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
310	&& !resolve_procedure_interface (sym))
311	return;
312
313	if (strcmp (s1: proc->name, s2: sym->name) == 0)
314	{
315	gfc_error ("Self-referential argument "
316	"%qs at %L is not allowed", sym->name,
317	&proc->declared_at);
318	return;
319	}
320
321	if (sym->attr.if_source != IFSRC_UNKNOWN)
322	gfc_resolve_formal_arglist (proc: sym);
323
324	if (sym->attr.subroutine || sym->attr.external)
325	{
326	if (sym->attr.flavor == FL_UNKNOWN)
327	gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
328	}
329	else
330	{
331	if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
332	&& (!sym->attr.function || sym->result == sym))
333	gfc_set_default_type (sym, 1, sym->ns);
334	}
335
336	as = sym->ts.type == BT_CLASS && sym->attr.class_ok
337	? CLASS_DATA (sym)->as : sym->as;
338
339	saved_specification_expr = specification_expr;
340	specification_expr = true;
341	gfc_resolve_array_spec (as, 0);
342	specification_expr = saved_specification_expr;
343
344	/* We can't tell if an array with dimension (:) is assumed or deferred
345	shape until we know if it has the pointer or allocatable attributes.
346	*/
347	if (as && as->rank > 0 && as->type == AS_DEFERRED
348	&& ((sym->ts.type != BT_CLASS
349	&& !(sym->attr.pointer || sym->attr.allocatable))
350	|| (sym->ts.type == BT_CLASS
351	&& !(CLASS_DATA (sym)->attr.class_pointer
352	|| CLASS_DATA (sym)->attr.allocatable)))
353	&& sym->attr.flavor != FL_PROCEDURE)
354	{
355	as->type = AS_ASSUMED_SHAPE;
356	for (i = 0; i < as->rank; i++)
357	as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
358	}
359
360	if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
361	|| (as && as->type == AS_ASSUMED_RANK)
362	|| sym->attr.pointer || sym->attr.allocatable || sym->attr.target
363	|| (sym->ts.type == BT_CLASS && sym->attr.class_ok
364	&& (CLASS_DATA (sym)->attr.class_pointer
365	|| CLASS_DATA (sym)->attr.allocatable
366	|| CLASS_DATA (sym)->attr.target))
367	|| sym->attr.optional)
368	{
369	proc->attr.always_explicit = 1;
370	if (proc->result)
371	proc->result->attr.always_explicit = 1;
372	}
373
374	/* If the flavor is unknown at this point, it has to be a variable.
375	A procedure specification would have already set the type. */
376
377	if (sym->attr.flavor == FL_UNKNOWN)
378	gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
379
380	if (gfc_pure (proc))
381	{
382	if (sym->attr.flavor == FL_PROCEDURE)
383	{
384	/* F08:C1279. */
385	if (!gfc_pure (sym))
386	{
387	gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
388	"also be PURE", sym->name, &sym->declared_at);
389	continue;
390	}
391	}
392	else if (!sym->attr.pointer)
393	{
394	if (proc->attr.function && sym->attr.intent != INTENT_IN)
395	{
396	if (sym->attr.value)
397	gfc_notify_std (GFC_STD_F2008, "Argument %qs"
398	" of pure function %qs at %L with VALUE "
399	"attribute but without INTENT(IN)",
400	sym->name, proc->name, &sym->declared_at);
401	else
402	gfc_error ("Argument %qs of pure function %qs at %L must "
403	"be INTENT(IN) or VALUE", sym->name, proc->name,
404	&sym->declared_at);
405	}
406
407	if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
408	{
409	if (sym->attr.value)
410	gfc_notify_std (GFC_STD_F2008, "Argument %qs"
411	" of pure subroutine %qs at %L with VALUE "
412	"attribute but without INTENT", sym->name,
413	proc->name, &sym->declared_at);
414	else
415	gfc_error ("Argument %qs of pure subroutine %qs at %L "
416	"must have its INTENT specified or have the "
417	"VALUE attribute", sym->name, proc->name,
418	&sym->declared_at);
419	}
420	}
421
422	/* F08:C1278a. */
423	if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT)
424	{
425	gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
426	" may not be polymorphic", sym->name, proc->name,
427	&sym->declared_at);
428	continue;
429	}
430	}
431
432	if (proc->attr.implicit_pure)
433	{
434	if (sym->attr.flavor == FL_PROCEDURE)
435	{
436	if (!gfc_pure (sym))
437	proc->attr.implicit_pure = 0;
438	}
439	else if (!sym->attr.pointer)
440	{
441	if (proc->attr.function && sym->attr.intent != INTENT_IN
442	&& !sym->value)
443	proc->attr.implicit_pure = 0;
444
445	if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
446	&& !sym->value)
447	proc->attr.implicit_pure = 0;
448	}
449	}
450
451	if (gfc_elemental (proc))
452	{
453	/* F08:C1289. */
454	if (sym->attr.codimension
455	|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
456	&& CLASS_DATA (sym)->attr.codimension))
457	{
458	gfc_error ("Coarray dummy argument %qs at %L to elemental "
459	"procedure", sym->name, &sym->declared_at);
460	continue;
461	}
462
463	if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
464	&& CLASS_DATA (sym)->as))
465	{
466	gfc_error ("Argument %qs of elemental procedure at %L must "
467	"be scalar", sym->name, &sym->declared_at);
468	continue;
469	}
470
471	if (sym->attr.allocatable
472	|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
473	&& CLASS_DATA (sym)->attr.allocatable))
474	{
475	gfc_error ("Argument %qs of elemental procedure at %L cannot "
476	"have the ALLOCATABLE attribute", sym->name,
477	&sym->declared_at);
478	continue;
479	}
480
481	if (sym->attr.pointer
482	|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
483	&& CLASS_DATA (sym)->attr.class_pointer))
484	{
485	gfc_error ("Argument %qs of elemental procedure at %L cannot "
486	"have the POINTER attribute", sym->name,
487	&sym->declared_at);
488	continue;
489	}
490
491	if (sym->attr.flavor == FL_PROCEDURE)
492	{
493	gfc_error ("Dummy procedure %qs not allowed in elemental "
494	"procedure %qs at %L", sym->name, proc->name,
495	&sym->declared_at);
496	continue;
497	}
498
499	/* Fortran 2008 Corrigendum 1, C1290a. */
500	if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
501	{
502	gfc_error ("Argument %qs of elemental procedure %qs at %L must "
503	"have its INTENT specified or have the VALUE "
504	"attribute", sym->name, proc->name,
505	&sym->declared_at);
506	continue;
507	}
508	}
509
510	/* Each dummy shall be specified to be scalar. */
511	if (proc->attr.proc == PROC_ST_FUNCTION)
512	{
513	if (sym->as != NULL)
514	{
515	/* F03:C1263 (R1238) The function-name and each dummy-arg-name
516	shall be specified, explicitly or implicitly, to be scalar. */
517	gfc_error ("Argument %qs of statement function %qs at %L "
518	"must be scalar", sym->name, proc->name,
519	&proc->declared_at);
520	continue;
521	}
522
523	if (sym->ts.type == BT_CHARACTER)
524	{
525	gfc_charlen *cl = sym->ts.u.cl;
526	if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
527	{
528	gfc_error ("Character-valued argument %qs of statement "
529	"function at %L must have constant length",
530	sym->name, &sym->declared_at);
531	continue;
532	}
533	}
534	}
535	}
536	formal_arg_flag = false;
537	}
538
539
540	/* Work function called when searching for symbols that have argument lists
541	associated with them. */
542
543	static void
544	find_arglists (gfc_symbol *sym)
545	{
546	if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
547	|| gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic)
548	return;
549
550	gfc_resolve_formal_arglist (proc: sym);
551	}
552
553
554	/* Given a namespace, resolve all formal argument lists within the namespace.
555	*/
556
557	static void
558	resolve_formal_arglists (gfc_namespace *ns)
559	{
560	if (ns == NULL)
561	return;
562
563	gfc_traverse_ns (ns, find_arglists);
564	}
565
566
567	static void
568	resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
569	{
570	bool t;
571
572	if (sym && sym->attr.flavor == FL_PROCEDURE
573	&& sym->ns->parent
574	&& sym->ns->parent->proc_name
575	&& sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE
576	&& !strcmp (s1: sym->name, s2: sym->ns->parent->proc_name->name))
577	gfc_error ("Contained procedure %qs at %L has the same name as its "
578	"encompassing procedure", sym->name, &sym->declared_at);
579
580	/* If this namespace is not a function or an entry master function,
581	ignore it. */
582	if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
583	|| sym->attr.entry_master)
584	return;
585
586	if (!sym->result)
587	return;
588
589	/* Try to find out of what the return type is. */
590	if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
591	{
592	t = gfc_set_default_type (sym->result, 0, ns);
593
594	if (!t && !sym->result->attr.untyped)
595	{
596	if (sym->result == sym)
597	gfc_error ("Contained function %qs at %L has no IMPLICIT type",
598	sym->name, &sym->declared_at);
599	else if (!sym->result->attr.proc_pointer)
600	gfc_error ("Result %qs of contained function %qs at %L has "
601	"no IMPLICIT type", sym->result->name, sym->name,
602	&sym->result->declared_at);
603	sym->result->attr.untyped = 1;
604	}
605	}
606
607	/* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
608	type, lists the only ways a character length value of * can be used:
609	dummy arguments of procedures, named constants, function results and
610	in allocate statements if the allocate_object is an assumed length dummy
611	in external functions. Internal function results and results of module
612	procedures are not on this list, ergo, not permitted. */
613
614	if (sym->result->ts.type == BT_CHARACTER)
615	{
616	gfc_charlen *cl = sym->result->ts.u.cl;
617	if ((!cl || !cl->length) && !sym->result->ts.deferred)
618	{
619	/* See if this is a module-procedure and adapt error message
620	accordingly. */
621	bool module_proc;
622	gcc_assert (ns->parent && ns->parent->proc_name);
623	module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
624
625	gfc_error (module_proc
626	? G_("Character-valued module procedure %qs at %L"
627	" must not be assumed length")
628	: G_("Character-valued internal function %qs at %L"
629	" must not be assumed length"),
630	sym->name, &sym->declared_at);
631	}
632	}
633	}
634
635
636	/* Add NEW_ARGS to the formal argument list of PROC, taking care not to
637	introduce duplicates. */
638
639	static void
640	merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
641	{
642	gfc_formal_arglist *f, *new_arglist;
643	gfc_symbol *new_sym;
644
645	for (; new_args != NULL; new_args = new_args->next)
646	{
647	new_sym = new_args->sym;
648	/* See if this arg is already in the formal argument list. */
649	for (f = proc->formal; f; f = f->next)
650	{
651	if (new_sym == f->sym)
652	break;
653	}
654
655	if (f)
656	continue;
657
658	/* Add a new argument. Argument order is not important. */
659	new_arglist = gfc_get_formal_arglist ();
660	new_arglist->sym = new_sym;
661	new_arglist->next = proc->formal;
662	proc->formal = new_arglist;
663	}
664	}
665
666
667	/* Flag the arguments that are not present in all entries. */
668
669	static void
670	check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
671	{
672	gfc_formal_arglist *f, *head;
673	head = new_args;
674
675	for (f = proc->formal; f; f = f->next)
676	{
677	if (f->sym == NULL)
678	continue;
679
680	for (new_args = head; new_args; new_args = new_args->next)
681	{
682	if (new_args->sym == f->sym)
683	break;
684	}
685
686	if (new_args)
687	continue;
688
689	f->sym->attr.not_always_present = 1;
690	}
691	}
692
693
694	/* Resolve alternate entry points. If a symbol has multiple entry points we
695	create a new master symbol for the main routine, and turn the existing
696	symbol into an entry point. */
697
698	static void
699	resolve_entries (gfc_namespace *ns)
700	{
701	gfc_namespace *old_ns;
702	gfc_code *c;
703	gfc_symbol *proc;
704	gfc_entry_list *el;
705	/* Provide sufficient space to hold "master.%d.%s". */
706	char name[GFC_MAX_SYMBOL_LEN + 1 + 18];
707	static int master_count = 0;
708
709	if (ns->proc_name == NULL)
710	return;
711
712	/* No need to do anything if this procedure doesn't have alternate entry
713	points. */
714	if (!ns->entries)
715	return;
716
717	/* We may already have resolved alternate entry points. */
718	if (ns->proc_name->attr.entry_master)
719	return;
720
721	/* If this isn't a procedure something has gone horribly wrong. */
722	gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
723
724	/* Remember the current namespace. */
725	old_ns = gfc_current_ns;
726
727	gfc_current_ns = ns;
728
729	/* Add the main entry point to the list of entry points. */
730	el = gfc_get_entry_list ();
731	el->sym = ns->proc_name;
732	el->id = 0;
733	el->next = ns->entries;
734	ns->entries = el;
735	ns->proc_name->attr.entry = 1;
736
737	/* If it is a module function, it needs to be in the right namespace
738	so that gfc_get_fake_result_decl can gather up the results. The
739	need for this arose in get_proc_name, where these beasts were
740	left in their own namespace, to keep prior references linked to
741	the entry declaration.*/
742	if (ns->proc_name->attr.function
743	&& ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
744	el->sym->ns = ns;
745
746	/* Do the same for entries where the master is not a module
747	procedure. These are retained in the module namespace because
748	of the module procedure declaration. */
749	for (el = el->next; el; el = el->next)
750	if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
751	&& el->sym->attr.mod_proc)
752	el->sym->ns = ns;
753	el = ns->entries;
754
755	/* Add an entry statement for it. */
756	c = gfc_get_code (EXEC_ENTRY);
757	c->ext.entry = el;
758	c->next = ns->code;
759	ns->code = c;
760
761	/* Create a new symbol for the master function. */
762	/* Give the internal function a unique name (within this file).
763	Also include the function name so the user has some hope of figuring
764	out what is going on. */
765	snprintf (s: name, GFC_MAX_SYMBOL_LEN, format: "master.%d.%s",
766	master_count++, ns->proc_name->name);
767	gfc_get_ha_symbol (name, &proc);
768	gcc_assert (proc != NULL);
769
770	gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
771	if (ns->proc_name->attr.subroutine)
772	gfc_add_subroutine (&proc->attr, proc->name, NULL);
773	else
774	{
775	gfc_symbol *sym;
776	gfc_typespec *ts, *fts;
777	gfc_array_spec *as, *fas;
778	gfc_add_function (&proc->attr, proc->name, NULL);
779	proc->result = proc;
780	fas = ns->entries->sym->as;
781	fas = fas ? fas : ns->entries->sym->result->as;
782	fts = &ns->entries->sym->result->ts;
783	if (fts->type == BT_UNKNOWN)
784	fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
785	for (el = ns->entries->next; el; el = el->next)
786	{
787	ts = &el->sym->result->ts;
788	as = el->sym->as;
789	as = as ? as : el->sym->result->as;
790	if (ts->type == BT_UNKNOWN)
791	ts = gfc_get_default_type (el->sym->result->name, NULL);
792
793	if (! gfc_compare_types (ts, fts)
794	|| (el->sym->result->attr.dimension
795	!= ns->entries->sym->result->attr.dimension)
796	|| (el->sym->result->attr.pointer
797	!= ns->entries->sym->result->attr.pointer))
798	break;
799	else if (as && fas && ns->entries->sym->result != el->sym->result
800	&& gfc_compare_array_spec (as, fas) == 0)
801	gfc_error ("Function %s at %L has entries with mismatched "
802	"array specifications", ns->entries->sym->name,
803	&ns->entries->sym->declared_at);
804	/* The characteristics need to match and thus both need to have
805	the same string length, i.e. both len=*, or both len=4.
806	Having both len=<variable> is also possible, but difficult to
807	check at compile time. */
808	else if (ts->type == BT_CHARACTER
809	&& (el->sym->result->attr.allocatable
810	!= ns->entries->sym->result->attr.allocatable))
811	{
812	gfc_error ("Function %s at %L has entry %s with mismatched "
813	"characteristics", ns->entries->sym->name,
814	&ns->entries->sym->declared_at, el->sym->name);
815	goto cleanup;
816	}
817	else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
818	&& (((ts->u.cl->length && !fts->u.cl->length)
819	||(!ts->u.cl->length && fts->u.cl->length))
820	|| (ts->u.cl->length
821	&& ts->u.cl->length->expr_type
822	!= fts->u.cl->length->expr_type)
823	|| (ts->u.cl->length
824	&& ts->u.cl->length->expr_type == EXPR_CONSTANT
825	&& mpz_cmp (ts->u.cl->length->value.integer,
826	fts->u.cl->length->value.integer) != 0)))
827	gfc_notify_std (GFC_STD_GNU, "Function %s at %L with "
828	"entries returning variables of different "
829	"string lengths", ns->entries->sym->name,
830	&ns->entries->sym->declared_at);
831	else if (el->sym->result->attr.allocatable
832	!= ns->entries->sym->result->attr.allocatable)
833	break;
834	}
835
836	if (el == NULL)
837	{
838	sym = ns->entries->sym->result;
839	/* All result types the same. */
840	proc->ts = *fts;
841	if (sym->attr.dimension)
842	gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
843	if (sym->attr.pointer)
844	gfc_add_pointer (&proc->attr, NULL);
845	if (sym->attr.allocatable)
846	gfc_add_allocatable (&proc->attr, NULL);
847	}
848	else
849	{
850	/* Otherwise the result will be passed through a union by
851	reference. */
852	proc->attr.mixed_entry_master = 1;
853	for (el = ns->entries; el; el = el->next)
854	{
855	sym = el->sym->result;
856	if (sym->attr.dimension)
857	{
858	if (el == ns->entries)
859	gfc_error ("FUNCTION result %s cannot be an array in "
860	"FUNCTION %s at %L", sym->name,
861	ns->entries->sym->name, &sym->declared_at);
862	else
863	gfc_error ("ENTRY result %s cannot be an array in "
864	"FUNCTION %s at %L", sym->name,
865	ns->entries->sym->name, &sym->declared_at);
866	}
867	else if (sym->attr.pointer)
868	{
869	if (el == ns->entries)
870	gfc_error ("FUNCTION result %s cannot be a POINTER in "
871	"FUNCTION %s at %L", sym->name,
872	ns->entries->sym->name, &sym->declared_at);
873	else
874	gfc_error ("ENTRY result %s cannot be a POINTER in "
875	"FUNCTION %s at %L", sym->name,
876	ns->entries->sym->name, &sym->declared_at);
877	}
878	else if (sym->attr.allocatable)
879	{
880	if (el == ns->entries)
881	gfc_error ("FUNCTION result %s cannot be ALLOCATABLE in "
882	"FUNCTION %s at %L", sym->name,
883	ns->entries->sym->name, &sym->declared_at);
884	else
885	gfc_error ("ENTRY result %s cannot be ALLOCATABLE in "
886	"FUNCTION %s at %L", sym->name,
887	ns->entries->sym->name, &sym->declared_at);
888	}
889	else
890	{
891	ts = &sym->ts;
892	if (ts->type == BT_UNKNOWN)
893	ts = gfc_get_default_type (sym->name, NULL);
894	switch (ts->type)
895	{
896	case BT_INTEGER:
897	if (ts->kind == gfc_default_integer_kind)
898	sym = NULL;
899	break;
900	case BT_REAL:
901	if (ts->kind == gfc_default_real_kind
902	|| ts->kind == gfc_default_double_kind)
903	sym = NULL;
904	break;
905	case BT_COMPLEX:
906	if (ts->kind == gfc_default_complex_kind)
907	sym = NULL;
908	break;
909	case BT_LOGICAL:
910	if (ts->kind == gfc_default_logical_kind)
911	sym = NULL;
912	break;
913	case BT_UNKNOWN:
914	/* We will issue error elsewhere. */
915	sym = NULL;
916	break;
917	default:
918	break;
919	}
920	if (sym)
921	{
922	if (el == ns->entries)
923	gfc_error ("FUNCTION result %s cannot be of type %s "
924	"in FUNCTION %s at %L", sym->name,
925	gfc_typename (ts), ns->entries->sym->name,
926	&sym->declared_at);
927	else
928	gfc_error ("ENTRY result %s cannot be of type %s "
929	"in FUNCTION %s at %L", sym->name,
930	gfc_typename (ts), ns->entries->sym->name,
931	&sym->declared_at);
932	}
933	}
934	}
935	}
936	}
937
938	cleanup:
939	proc->attr.access = ACCESS_PRIVATE;
940	proc->attr.entry_master = 1;
941
942	/* Merge all the entry point arguments. */
943	for (el = ns->entries; el; el = el->next)
944	merge_argument_lists (proc, new_args: el->sym->formal);
945
946	/* Check the master formal arguments for any that are not
947	present in all entry points. */
948	for (el = ns->entries; el; el = el->next)
949	check_argument_lists (proc, new_args: el->sym->formal);
950
951	/* Use the master function for the function body. */
952	ns->proc_name = proc;
953
954	/* Finalize the new symbols. */
955	gfc_commit_symbols ();
956
957	/* Restore the original namespace. */
958	gfc_current_ns = old_ns;
959	}
960
961
962	/* Forward declaration. */
963	static bool is_non_constant_shape_array (gfc_symbol *sym);
964
965
966	/* Resolve common variables. */
967	static void
968	resolve_common_vars (gfc_common_head *common_block, bool named_common)
969	{
970	gfc_symbol *csym = common_block->head;
971	gfc_gsymbol *gsym;
972
973	for (; csym; csym = csym->common_next)
974	{
975	gsym = gfc_find_gsymbol (gfc_gsym_root, csym->name);
976	if (gsym && (gsym->type == GSYM_MODULE || gsym->type == GSYM_PROGRAM))
977	{
978	if (csym->common_block)
979	gfc_error_now ("Global entity %qs at %L cannot appear in a "
980	"COMMON block at %L", gsym->name,
981	&gsym->where, &csym->common_block->where);
982	else
983	gfc_error_now ("Global entity %qs at %L cannot appear in a "
984	"COMMON block", gsym->name, &gsym->where);
985	}
986
987	/* gfc_add_in_common may have been called before, but the reported errors
988	have been ignored to continue parsing.
989	We do the checks again here. */
990	if (!csym->attr.use_assoc)
991	{
992	gfc_add_in_common (&csym->attr, csym->name, &common_block->where);
993	gfc_notify_std (GFC_STD_F2018_OBS, "COMMON block at %L",
994	&common_block->where);
995	}
996
997	if (csym->value || csym->attr.data)
998	{
999	if (!csym->ns->is_block_data)
1000	gfc_notify_std (GFC_STD_GNU, "Variable %qs at %L is in COMMON "
1001	"but only in BLOCK DATA initialization is "
1002	"allowed", csym->name, &csym->declared_at);
1003	else if (!named_common)
1004	gfc_notify_std (GFC_STD_GNU, "Initialized variable %qs at %L is "
1005	"in a blank COMMON but initialization is only "
1006	"allowed in named common blocks", csym->name,
1007	&csym->declared_at);
1008	}
1009
1010	if (UNLIMITED_POLY (csym))
1011	gfc_error_now ("%qs at %L cannot appear in COMMON "
1012	"[F2008:C5100]", csym->name, &csym->declared_at);
1013
1014	if (csym->attr.dimension && is_non_constant_shape_array (sym: csym))
1015	{
1016	gfc_error_now ("Automatic object %qs at %L cannot appear in "
1017	"COMMON at %L", csym->name, &csym->declared_at,
1018	&common_block->where);
1019	/* Avoid confusing follow-on error. */
1020	csym->error = 1;
1021	}
1022
1023	if (csym->ts.type != BT_DERIVED)
1024	continue;
1025
1026	if (!(csym->ts.u.derived->attr.sequence
1027	|| csym->ts.u.derived->attr.is_bind_c))
1028	gfc_error_now ("Derived type variable %qs in COMMON at %L "
1029	"has neither the SEQUENCE nor the BIND(C) "
1030	"attribute", csym->name, &csym->declared_at);
1031	if (csym->ts.u.derived->attr.alloc_comp)
1032	gfc_error_now ("Derived type variable %qs in COMMON at %L "
1033	"has an ultimate component that is "
1034	"allocatable", csym->name, &csym->declared_at);
1035	if (gfc_has_default_initializer (csym->ts.u.derived))
1036	gfc_error_now ("Derived type variable %qs in COMMON at %L "
1037	"may not have default initializer", csym->name,
1038	&csym->declared_at);
1039
1040	if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
1041	gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
1042	}
1043	}
1044
1045	/* Resolve common blocks. */
1046	static void
1047	resolve_common_blocks (gfc_symtree *common_root)
1048	{
1049	gfc_symbol *sym;
1050	gfc_gsymbol * gsym;
1051
1052	if (common_root == NULL)
1053	return;
1054
1055	if (common_root->left)
1056	resolve_common_blocks (common_root: common_root->left);
1057	if (common_root->right)
1058	resolve_common_blocks (common_root: common_root->right);
1059
1060	resolve_common_vars (common_block: common_root->n.common, named_common: true);
1061
1062	/* The common name is a global name - in Fortran 2003 also if it has a
1063	C binding name, since Fortran 2008 only the C binding name is a global
1064	identifier. */
1065	if (!common_root->n.common->binding_label
1066	|| gfc_notification_std (GFC_STD_F2008))
1067	{
1068	gsym = gfc_find_gsymbol (gfc_gsym_root,
1069	common_root->n.common->name);
1070
1071	if (gsym && gfc_notification_std (GFC_STD_F2008)
1072	&& gsym->type == GSYM_COMMON
1073	&& ((common_root->n.common->binding_label
1074	&& (!gsym->binding_label
1075	|| strcmp (s1: common_root->n.common->binding_label,
1076	s2: gsym->binding_label) != 0))
1077	|| (!common_root->n.common->binding_label
1078	&& gsym->binding_label)))
1079	{
1080	gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1081	"identifier and must thus have the same binding name "
1082	"as the same-named COMMON block at %L: %s vs %s",
1083	common_root->n.common->name, &common_root->n.common->where,
1084	&gsym->where,
1085	common_root->n.common->binding_label
1086	? common_root->n.common->binding_label : "(blank)",
1087	gsym->binding_label ? gsym->binding_label : "(blank)");
1088	return;
1089	}
1090
1091	if (gsym && gsym->type != GSYM_COMMON
1092	&& !common_root->n.common->binding_label)
1093	{
1094	gfc_error ("COMMON block %qs at %L uses the same global identifier "
1095	"as entity at %L",
1096	common_root->n.common->name, &common_root->n.common->where,
1097	&gsym->where);
1098	return;
1099	}
1100	if (gsym && gsym->type != GSYM_COMMON)
1101	{
1102	gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1103	"%L sharing the identifier with global non-COMMON-block "
1104	"entity at %L", common_root->n.common->name,
1105	&common_root->n.common->where, &gsym->where);
1106	return;
1107	}
1108	if (!gsym)
1109	{
1110	gsym = gfc_get_gsymbol (common_root->n.common->name, bind_c: false);
1111	gsym->type = GSYM_COMMON;
1112	gsym->where = common_root->n.common->where;
1113	gsym->defined = 1;
1114	}
1115	gsym->used = 1;
1116	}
1117
1118	if (common_root->n.common->binding_label)
1119	{
1120	gsym = gfc_find_gsymbol (gfc_gsym_root,
1121	common_root->n.common->binding_label);
1122	if (gsym && gsym->type != GSYM_COMMON)
1123	{
1124	gfc_error ("COMMON block at %L with binding label %qs uses the same "
1125	"global identifier as entity at %L",
1126	&common_root->n.common->where,
1127	common_root->n.common->binding_label, &gsym->where);
1128	return;
1129	}
1130	if (!gsym)
1131	{
1132	gsym = gfc_get_gsymbol (common_root->n.common->binding_label, bind_c: true);
1133	gsym->type = GSYM_COMMON;
1134	gsym->where = common_root->n.common->where;
1135	gsym->defined = 1;
1136	}
1137	gsym->used = 1;
1138	}
1139
1140	gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
1141	if (sym == NULL)
1142	return;
1143
1144	if (sym->attr.flavor == FL_PARAMETER)
1145	gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1146	sym->name, &common_root->n.common->where, &sym->declared_at);
1147
1148	if (sym->attr.external)
1149	gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
1150	sym->name, &common_root->n.common->where);
1151
1152	if (sym->attr.intrinsic)
1153	gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1154	sym->name, &common_root->n.common->where);
1155	else if (sym->attr.result
1156	|| gfc_is_function_return_value (sym, gfc_current_ns))
1157	gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1158	"that is also a function result", sym->name,
1159	&common_root->n.common->where);
1160	else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
1161	&& sym->attr.proc != PROC_ST_FUNCTION)
1162	gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1163	"that is also a global procedure", sym->name,
1164	&common_root->n.common->where);
1165	}
1166
1167
1168	/* Resolve contained function types. Because contained functions can call one
1169	another, they have to be worked out before any of the contained procedures
1170	can be resolved.
1171
1172	The good news is that if a function doesn't already have a type, the only
1173	way it can get one is through an IMPLICIT type or a RESULT variable, because
1174	by definition contained functions are contained namespace they're contained
1175	in, not in a sibling or parent namespace. */
1176
1177	static void
1178	resolve_contained_functions (gfc_namespace *ns)
1179	{
1180	gfc_namespace *child;
1181	gfc_entry_list *el;
1182
1183	resolve_formal_arglists (ns);
1184
1185	for (child = ns->contained; child; child = child->sibling)
1186	{
1187	/* Resolve alternate entry points first. */
1188	resolve_entries (ns: child);
1189
1190	/* Then check function return types. */
1191	resolve_contained_fntype (sym: child->proc_name, ns: child);
1192	for (el = child->entries; el; el = el->next)
1193	resolve_contained_fntype (sym: el->sym, ns: child);
1194	}
1195	}
1196
1197
1198
1199	/* A Parameterized Derived Type constructor must contain values for
1200	the PDT KIND parameters or they must have a default initializer.
1201	Go through the constructor picking out the KIND expressions,
1202	storing them in 'param_list' and then call gfc_get_pdt_instance
1203	to obtain the PDT instance. */
1204
1205	static gfc_actual_arglist *param_list, *param_tail, *param;
1206
1207	static bool
1208	get_pdt_spec_expr (gfc_component *c, gfc_expr *expr)
1209	{
1210	param = gfc_get_actual_arglist ();
1211	if (!param_list)
1212	param_list = param_tail = param;
1213	else
1214	{
1215	param_tail->next = param;
1216	param_tail = param_tail->next;
1217	}
1218
1219	param_tail->name = c->name;
1220	if (expr)
1221	param_tail->expr = gfc_copy_expr (expr);
1222	else if (c->initializer)
1223	param_tail->expr = gfc_copy_expr (c->initializer);
1224	else
1225	{
1226	param_tail->spec_type = SPEC_ASSUMED;
1227	if (c->attr.pdt_kind)
1228	{
1229	gfc_error ("The KIND parameter %qs in the PDT constructor "
1230	"at %C has no value", param->name);
1231	return false;
1232	}
1233	}
1234
1235	return true;
1236	}
1237
1238	static bool
1239	get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
1240	gfc_symbol *derived)
1241	{
1242	gfc_constructor *cons = NULL;
1243	gfc_component *comp;
1244	bool t = true;
1245
1246	if (expr && expr->expr_type == EXPR_STRUCTURE)
1247	cons = gfc_constructor_first (base: expr->value.constructor);
1248	else if (constr)
1249	cons = *constr;
1250	gcc_assert (cons);
1251
1252	comp = derived->components;
1253
1254	for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (ctor: cons))
1255	{
1256	if (cons->expr
1257	&& cons->expr->expr_type == EXPR_STRUCTURE
1258	&& comp->ts.type == BT_DERIVED)
1259	{
1260	t = get_pdt_constructor (expr: cons->expr, NULL, derived: comp->ts.u.derived);
1261	if (!t)
1262	return t;
1263	}
1264	else if (comp->ts.type == BT_DERIVED)
1265	{
1266	t = get_pdt_constructor (NULL, constr: &cons, derived: comp->ts.u.derived);
1267	if (!t)
1268	return t;
1269	}
1270	else if ((comp->attr.pdt_kind || comp->attr.pdt_len)
1271	&& derived->attr.pdt_template)
1272	{
1273	t = get_pdt_spec_expr (c: comp, expr: cons->expr);
1274	if (!t)
1275	return t;
1276	}
1277	}
1278	return t;
1279	}
1280
1281
1282	static bool resolve_fl_derived0 (gfc_symbol *sym);
1283	static bool resolve_fl_struct (gfc_symbol *sym);
1284
1285
1286	/* Resolve all of the elements of a structure constructor and make sure that
1287	the types are correct. The 'init' flag indicates that the given
1288	constructor is an initializer. */
1289
1290	static bool
1291	resolve_structure_cons (gfc_expr *expr, int init)
1292	{
1293	gfc_constructor *cons;
1294	gfc_component *comp;
1295	bool t;
1296	symbol_attribute a;
1297
1298	t = true;
1299
1300	if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION)
1301	{
1302	if (expr->ts.u.derived->attr.flavor == FL_DERIVED)
1303	resolve_fl_derived0 (sym: expr->ts.u.derived);
1304	else
1305	resolve_fl_struct (sym: expr->ts.u.derived);
1306
1307	/* If this is a Parameterized Derived Type template, find the
1308	instance corresponding to the PDT kind parameters. */
1309	if (expr->ts.u.derived->attr.pdt_template)
1310	{
1311	param_list = NULL;
1312	t = get_pdt_constructor (expr, NULL, derived: expr->ts.u.derived);
1313	if (!t)
1314	return t;
1315	gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL);
1316
1317	expr->param_list = gfc_copy_actual_arglist (param_list);
1318
1319	if (param_list)
1320	gfc_free_actual_arglist (param_list);
1321
1322	if (!expr->ts.u.derived->attr.pdt_type)
1323	return false;
1324	}
1325	}
1326
1327	/* A constructor may have references if it is the result of substituting a
1328	parameter variable. In this case we just pull out the component we
1329	want. */
1330	if (expr->ref)
1331	comp = expr->ref->u.c.sym->components;
1332	else if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS
1333	|| expr->ts.type == BT_UNION)
1334	&& expr->ts.u.derived)
1335	comp = expr->ts.u.derived->components;
1336	else
1337	return false;
1338
1339	cons = gfc_constructor_first (base: expr->value.constructor);
1340
1341	for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (ctor: cons))
1342	{
1343	int rank;
1344
1345	if (!cons->expr)
1346	continue;
1347
1348	/* Unions use an EXPR_NULL contrived expression to tell the translation
1349	phase to generate an initializer of the appropriate length.
1350	Ignore it here. */
1351	if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL)
1352	continue;
1353
1354	if (!gfc_resolve_expr (cons->expr))
1355	{
1356	t = false;
1357	continue;
1358	}
1359
1360	rank = comp->as ? comp->as->rank : 0;
1361	if (comp->ts.type == BT_CLASS
1362	&& !comp->ts.u.derived->attr.unlimited_polymorphic
1363	&& CLASS_DATA (comp)->as)
1364	rank = CLASS_DATA (comp)->as->rank;
1365
1366	if (comp->ts.type == BT_CLASS && cons->expr->ts.type != BT_CLASS)
1367	gfc_find_vtab (&cons->expr->ts);
1368
1369	if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1370	&& (comp->attr.allocatable || cons->expr->rank))
1371	{
1372	gfc_error ("The rank of the element in the structure "
1373	"constructor at %L does not match that of the "
1374	"component (%d/%d)", &cons->expr->where,
1375	cons->expr->rank, rank);
1376	t = false;
1377	}
1378
1379	/* If we don't have the right type, try to convert it. */
1380
1381	if (!comp->attr.proc_pointer &&
1382	!gfc_compare_types (&cons->expr->ts, &comp->ts))
1383	{
1384	if (strcmp (s1: comp->name, s2: "_extends") == 0)
1385	{
1386	/* Can afford to be brutal with the _extends initializer.
1387	The derived type can get lost because it is PRIVATE
1388	but it is not usage constrained by the standard. */
1389	cons->expr->ts = comp->ts;
1390	}
1391	else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1392	{
1393	gfc_error ("The element in the structure constructor at %L, "
1394	"for pointer component %qs, is %s but should be %s",
1395	&cons->expr->where, comp->name,
1396	gfc_basic_typename (cons->expr->ts.type),
1397	gfc_basic_typename (comp->ts.type));
1398	t = false;
1399	}
1400	else if (!UNLIMITED_POLY (comp))
1401	{
1402	bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
1403	if (t)
1404	t = t2;
1405	}
1406	}
1407
1408	/* For strings, the length of the constructor should be the same as
1409	the one of the structure, ensure this if the lengths are known at
1410	compile time and when we are dealing with PARAMETER or structure
1411	constructors. */
1412	if (cons->expr->ts.type == BT_CHARACTER
1413	&& comp->ts.type == BT_CHARACTER
1414	&& comp->ts.u.cl && comp->ts.u.cl->length
1415	&& comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1416	&& cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1417	&& cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1418	&& cons->expr->ts.u.cl->length->ts.type == BT_INTEGER
1419	&& comp->ts.u.cl->length->ts.type == BT_INTEGER
1420	&& mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1421	comp->ts.u.cl->length->value.integer) != 0)
1422	{
1423	if (comp->attr.pointer)
1424	{
1425	HOST_WIDE_INT la, lb;
1426	la = gfc_mpz_get_hwi (comp->ts.u.cl->length->value.integer);
1427	lb = gfc_mpz_get_hwi (cons->expr->ts.u.cl->length->value.integer);
1428	gfc_error ("Unequal character lengths (%wd/%wd) for pointer "
1429	"component %qs in constructor at %L",
1430	la, lb, comp->name, &cons->expr->where);
1431	t = false;
1432	}
1433
1434	if (cons->expr->expr_type == EXPR_VARIABLE
1435	&& cons->expr->rank != 0
1436	&& cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1437	{
1438	/* Wrap the parameter in an array constructor (EXPR_ARRAY)
1439	to make use of the gfc_resolve_character_array_constructor
1440	machinery. The expression is later simplified away to
1441	an array of string literals. */
1442	gfc_expr *para = cons->expr;
1443	cons->expr = gfc_get_expr ();
1444	cons->expr->ts = para->ts;
1445	cons->expr->where = para->where;
1446	cons->expr->expr_type = EXPR_ARRAY;
1447	cons->expr->rank = para->rank;
1448	cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1449	gfc_constructor_append_expr (base: &cons->expr->value.constructor,
1450	e: para, where: &cons->expr->where);
1451	}
1452
1453	if (cons->expr->expr_type == EXPR_ARRAY)
1454	{
1455	/* Rely on the cleanup of the namespace to deal correctly with
1456	the old charlen. (There was a block here that attempted to
1457	remove the charlen but broke the chain in so doing.) */
1458	cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1459	cons->expr->ts.u.cl->length_from_typespec = true;
1460	cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1461	gfc_resolve_character_array_constructor (cons->expr);
1462	}
1463	}
1464
1465	if (cons->expr->expr_type == EXPR_NULL
1466	&& !(comp->attr.pointer || comp->attr.allocatable
1467	|| comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID
1468	|| (comp->ts.type == BT_CLASS
1469	&& (CLASS_DATA (comp)->attr.class_pointer
1470	|| CLASS_DATA (comp)->attr.allocatable))))
1471	{
1472	t = false;
1473	gfc_error ("The NULL in the structure constructor at %L is "
1474	"being applied to component %qs, which is neither "
1475	"a POINTER nor ALLOCATABLE", &cons->expr->where,
1476	comp->name);
1477	}
1478
1479	if (comp->attr.proc_pointer && comp->ts.interface)
1480	{
1481	/* Check procedure pointer interface. */
1482	gfc_symbol *s2 = NULL;
1483	gfc_component *c2;
1484	const char *name;
1485	char err[200];
1486
1487	c2 = gfc_get_proc_ptr_comp (cons->expr);
1488	if (c2)
1489	{
1490	s2 = c2->ts.interface;
1491	name = c2->name;
1492	}
1493	else if (cons->expr->expr_type == EXPR_FUNCTION)
1494	{
1495	s2 = cons->expr->symtree->n.sym->result;
1496	name = cons->expr->symtree->n.sym->result->name;
1497	}
1498	else if (cons->expr->expr_type != EXPR_NULL)
1499	{
1500	s2 = cons->expr->symtree->n.sym;
1501	name = cons->expr->symtree->n.sym->name;
1502	}
1503
1504	if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1505	err, sizeof (err), NULL, NULL))
1506	{
1507	gfc_error_opt (opt: 0, "Interface mismatch for procedure-pointer "
1508	"component %qs in structure constructor at %L:"
1509	" %s", comp->name, &cons->expr->where, err);
1510	return false;
1511	}
1512	}
1513
1514	/* Validate shape, except for dynamic or PDT arrays. */
1515	if (cons->expr->expr_type == EXPR_ARRAY && rank == cons->expr->rank
1516	&& comp->as && !comp->attr.allocatable && !comp->attr.pointer
1517	&& !comp->attr.pdt_array)
1518	{
1519	mpz_t len;
1520	mpz_init (len);
1521	for (int n = 0; n < rank; n++)
1522	{
1523	if (comp->as->upper[n]->expr_type != EXPR_CONSTANT
1524	|| comp->as->lower[n]->expr_type != EXPR_CONSTANT)
1525	{
1526	gfc_error ("Bad array spec of component %qs referenced in "
1527	"structure constructor at %L",
1528	comp->name, &cons->expr->where);
1529	t = false;
1530	break;
1531	};
1532	if (cons->expr->shape == NULL)
1533	continue;
1534	mpz_set_ui (len, 1);
1535	mpz_add (len, len, comp->as->upper[n]->value.integer);
1536	mpz_sub (len, len, comp->as->lower[n]->value.integer);
1537	if (mpz_cmp (cons->expr->shape[n], len) != 0)
1538	{
1539	gfc_error ("The shape of component %qs in the structure "
1540	"constructor at %L differs from the shape of the "
1541	"declared component for dimension %d (%ld/%ld)",
1542	comp->name, &cons->expr->where, n+1,
1543	mpz_get_si (cons->expr->shape[n]),
1544	mpz_get_si (len));
1545	t = false;
1546	}
1547	}
1548	mpz_clear (len);
1549	}
1550
1551	if (!comp->attr.pointer || comp->attr.proc_pointer
1552	|| cons->expr->expr_type == EXPR_NULL)
1553	continue;
1554
1555	a = gfc_expr_attr (cons->expr);
1556
1557	if (!a.pointer && !a.target)
1558	{
1559	t = false;
1560	gfc_error ("The element in the structure constructor at %L, "
1561	"for pointer component %qs should be a POINTER or "
1562	"a TARGET", &cons->expr->where, comp->name);
1563	}
1564
1565	if (init)
1566	{
1567	/* F08:C461. Additional checks for pointer initialization. */
1568	if (a.allocatable)
1569	{
1570	t = false;
1571	gfc_error ("Pointer initialization target at %L "
1572	"must not be ALLOCATABLE", &cons->expr->where);
1573	}
1574	if (!a.save)
1575	{
1576	t = false;
1577	gfc_error ("Pointer initialization target at %L "
1578	"must have the SAVE attribute", &cons->expr->where);
1579	}
1580	}
1581
1582	/* F2003, C1272 (3). */
1583	bool impure = cons->expr->expr_type == EXPR_VARIABLE
1584	&& (gfc_impure_variable (cons->expr->symtree->n.sym)
1585	|| gfc_is_coindexed (cons->expr));
1586	if (impure && gfc_pure (NULL))
1587	{
1588	t = false;
1589	gfc_error ("Invalid expression in the structure constructor for "
1590	"pointer component %qs at %L in PURE procedure",
1591	comp->name, &cons->expr->where);
1592	}
1593
1594	if (impure)
1595	gfc_unset_implicit_pure (NULL);
1596	}
1597
1598	return t;
1599	}
1600
1601
1602	/****************** Expression name resolution ******************/
1603
1604	/* Returns 0 if a symbol was not declared with a type or
1605	attribute declaration statement, nonzero otherwise. */
1606
1607	static bool
1608	was_declared (gfc_symbol *sym)
1609	{
1610	symbol_attribute a;
1611
1612	a = sym->attr;
1613
1614	if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1615	return 1;
1616
1617	if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1618	|| a.optional || a.pointer || a.save || a.target || a.volatile_
1619	|| a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1620	|| a.asynchronous || a.codimension)
1621	return 1;
1622
1623	return 0;
1624	}
1625
1626
1627	/* Determine if a symbol is generic or not. */
1628
1629	static int
1630	generic_sym (gfc_symbol *sym)
1631	{
1632	gfc_symbol *s;
1633
1634	if (sym->attr.generic ||
1635	(sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1636	return 1;
1637
1638	if (was_declared (sym) || sym->ns->parent == NULL)
1639	return 0;
1640
1641	gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1642
1643	if (s != NULL)
1644	{
1645	if (s == sym)
1646	return 0;
1647	else
1648	return generic_sym (sym: s);
1649	}
1650
1651	return 0;
1652	}
1653
1654
1655	/* Determine if a symbol is specific or not. */
1656
1657	static int
1658	specific_sym (gfc_symbol *sym)
1659	{
1660	gfc_symbol *s;
1661
1662	if (sym->attr.if_source == IFSRC_IFBODY
1663	|| sym->attr.proc == PROC_MODULE
1664	|| sym->attr.proc == PROC_INTERNAL
1665	|| sym->attr.proc == PROC_ST_FUNCTION
1666	|| (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1667	|| sym->attr.external)
1668	return 1;
1669
1670	if (was_declared (sym) || sym->ns->parent == NULL)
1671	return 0;
1672
1673	gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1674
1675	return (s == NULL) ? 0 : specific_sym (sym: s);
1676	}
1677
1678
1679	/* Figure out if the procedure is specific, generic or unknown. */
1680
1681	enum proc_type
1682	{ PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN };
1683
1684	static proc_type
1685	procedure_kind (gfc_symbol *sym)
1686	{
1687	if (generic_sym (sym))
1688	return PTYPE_GENERIC;
1689
1690	if (specific_sym (sym))
1691	return PTYPE_SPECIFIC;
1692
1693	return PTYPE_UNKNOWN;
1694	}
1695
1696	/* Check references to assumed size arrays. The flag need_full_assumed_size
1697	is nonzero when matching actual arguments. */
1698
1699	static int need_full_assumed_size = 0;
1700
1701	static bool
1702	check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1703	{
1704	if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1705	return false;
1706
1707	/* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1708	What should it be? */
1709	if (e->ref
1710	&& e->ref->u.ar.as
1711	&& (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1712	&& (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1713	&& (e->ref->u.ar.type == AR_FULL))
1714	{
1715	gfc_error ("The upper bound in the last dimension must "
1716	"appear in the reference to the assumed size "
1717	"array %qs at %L", sym->name, &e->where);
1718	return true;
1719	}
1720	return false;
1721	}
1722
1723
1724	/* Look for bad assumed size array references in argument expressions
1725	of elemental and array valued intrinsic procedures. Since this is
1726	called from procedure resolution functions, it only recurses at
1727	operators. */
1728
1729	static bool
1730	resolve_assumed_size_actual (gfc_expr *e)
1731	{
1732	if (e == NULL)
1733	return false;
1734
1735	switch (e->expr_type)
1736	{
1737	case EXPR_VARIABLE:
1738	if (e->symtree && check_assumed_size_reference (sym: e->symtree->n.sym, e))
1739	return true;
1740	break;
1741
1742	case EXPR_OP:
1743	if (resolve_assumed_size_actual (e: e->value.op.op1)
1744	|| resolve_assumed_size_actual (e: e->value.op.op2))
1745	return true;
1746	break;
1747
1748	default:
1749	break;
1750	}
1751	return false;
1752	}
1753
1754
1755	/* Check a generic procedure, passed as an actual argument, to see if
1756	there is a matching specific name. If none, it is an error, and if
1757	more than one, the reference is ambiguous. */
1758	static int
1759	count_specific_procs (gfc_expr *e)
1760	{
1761	int n;
1762	gfc_interface *p;
1763	gfc_symbol *sym;
1764
1765	n = 0;
1766	sym = e->symtree->n.sym;
1767
1768	for (p = sym->generic; p; p = p->next)
1769	if (strcmp (s1: sym->name, s2: p->sym->name) == 0)
1770	{
1771	e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1772	sym->name);
1773	n++;
1774	}
1775
1776	if (n > 1)
1777	gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name,
1778	&e->where);
1779
1780	if (n == 0)
1781	gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1782	"argument at %L", sym->name, &e->where);
1783
1784	return n;
1785	}
1786
1787
1788	/* See if a call to sym could possibly be a not allowed RECURSION because of
1789	a missing RECURSIVE declaration. This means that either sym is the current
1790	context itself, or sym is the parent of a contained procedure calling its
1791	non-RECURSIVE containing procedure.
1792	This also works if sym is an ENTRY. */
1793
1794	static bool
1795	is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1796	{
1797	gfc_symbol* proc_sym;
1798	gfc_symbol* context_proc;
1799	gfc_namespace* real_context;
1800
1801	if (sym->attr.flavor == FL_PROGRAM
1802	|| gfc_fl_struct (sym->attr.flavor))
1803	return false;
1804
1805	/* If we've got an ENTRY, find real procedure. */
1806	if (sym->attr.entry && sym->ns->entries)
1807	proc_sym = sym->ns->entries->sym;
1808	else
1809	proc_sym = sym;
1810
1811	/* If sym is RECURSIVE, all is well of course. */
1812	if (proc_sym->attr.recursive || flag_recursive)
1813	return false;
1814
1815	/* Find the context procedure's "real" symbol if it has entries.
1816	We look for a procedure symbol, so recurse on the parents if we don't
1817	find one (like in case of a BLOCK construct). */
1818	for (real_context = context; ; real_context = real_context->parent)
1819	{
1820	/* We should find something, eventually! */
1821	gcc_assert (real_context);
1822
1823	context_proc = (real_context->entries ? real_context->entries->sym
1824	: real_context->proc_name);
1825
1826	/* In some special cases, there may not be a proc_name, like for this
1827	invalid code:
1828	real(bad_kind()) function foo () ...
1829	when checking the call to bad_kind ().
1830	In these cases, we simply return here and assume that the
1831	call is ok. */
1832	if (!context_proc)
1833	return false;
1834
1835	if (context_proc->attr.flavor != FL_LABEL)
1836	break;
1837	}
1838
1839	/* A call from sym's body to itself is recursion, of course. */
1840	if (context_proc == proc_sym)
1841	return true;
1842
1843	/* The same is true if context is a contained procedure and sym the
1844	containing one. */
1845	if (context_proc->attr.contained)
1846	{
1847	gfc_symbol* parent_proc;
1848
1849	gcc_assert (context->parent);
1850	parent_proc = (context->parent->entries ? context->parent->entries->sym
1851	: context->parent->proc_name);
1852
1853	if (parent_proc == proc_sym)
1854	return true;
1855	}
1856
1857	return false;
1858	}
1859
1860
1861	/* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1862	its typespec and formal argument list. */
1863
1864	bool
1865	gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
1866	{
1867	gfc_intrinsic_sym* isym = NULL;
1868	const char* symstd;
1869
1870	if (sym->resolve_symbol_called >= 2)
1871	return true;
1872
1873	sym->resolve_symbol_called = 2;
1874
1875	/* Already resolved. */
1876	if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1877	return true;
1878
1879	/* We already know this one is an intrinsic, so we don't call
1880	gfc_is_intrinsic for full checking but rather use gfc_find_function and
1881	gfc_find_subroutine directly to check whether it is a function or
1882	subroutine. */
1883
1884	if (sym->intmod_sym_id && sym->attr.subroutine)
1885	{
1886	gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1887	isym = gfc_intrinsic_subroutine_by_id (id);
1888	}
1889	else if (sym->intmod_sym_id)
1890	{
1891	gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1892	isym = gfc_intrinsic_function_by_id (id);
1893	}
1894	else if (!sym->attr.subroutine)
1895	isym = gfc_find_function (sym->name);
1896
1897	if (isym && !sym->attr.subroutine)
1898	{
1899	if (sym->ts.type != BT_UNKNOWN && warn_surprising
1900	&& !sym->attr.implicit_type)
1901	gfc_warning (opt: OPT_Wsurprising,
1902	"Type specified for intrinsic function %qs at %L is"
1903	" ignored", sym->name, &sym->declared_at);
1904
1905	if (!sym->attr.function &&
1906	!gfc_add_function(&sym->attr, sym->name, loc))
1907	return false;
1908
1909	sym->ts = isym->ts;
1910	}
1911	else if (isym || (isym = gfc_find_subroutine (sym->name)))
1912	{
1913	if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1914	{
1915	gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1916	" specifier", sym->name, &sym->declared_at);
1917	return false;
1918	}
1919
1920	if (!sym->attr.subroutine &&
1921	!gfc_add_subroutine(&sym->attr, sym->name, loc))
1922	return false;
1923	}
1924	else
1925	{
1926	gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name,
1927	&sym->declared_at);
1928	return false;
1929	}
1930
1931	gfc_copy_formal_args_intr (sym, isym, NULL);
1932
1933	sym->attr.pure = isym->pure;
1934	sym->attr.elemental = isym->elemental;
1935
1936	/* Check it is actually available in the standard settings. */
1937	if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
1938	{
1939	gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1940	"available in the current standard settings but %s. Use "
1941	"an appropriate %<-std=*%> option or enable "
1942	"%<-fall-intrinsics%> in order to use it.",
1943	sym->name, &sym->declared_at, symstd);
1944	return false;
1945	}
1946
1947	return true;
1948	}
1949
1950
1951	/* Resolve a procedure expression, like passing it to a called procedure or as
1952	RHS for a procedure pointer assignment. */
1953
1954	static bool
1955	resolve_procedure_expression (gfc_expr* expr)
1956	{
1957	gfc_symbol* sym;
1958
1959	if (expr->expr_type != EXPR_VARIABLE)
1960	return true;
1961	gcc_assert (expr->symtree);
1962
1963	sym = expr->symtree->n.sym;
1964
1965	if (sym->attr.intrinsic)
1966	gfc_resolve_intrinsic (sym, loc: &expr->where);
1967
1968	if (sym->attr.flavor != FL_PROCEDURE
1969	|| (sym->attr.function && sym->result == sym))
1970	return true;
1971
1972	/* A non-RECURSIVE procedure that is used as procedure expression within its
1973	own body is in danger of being called recursively. */
1974	if (is_illegal_recursion (sym, context: gfc_current_ns))
1975	gfc_warning (opt: 0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1976	" itself recursively. Declare it RECURSIVE or use"
1977	" %<-frecursive%>", sym->name, &expr->where);
1978
1979	return true;
1980	}
1981
1982
1983	/* Check that name is not a derived type. */
1984
1985	static bool
1986	is_dt_name (const char *name)
1987	{
1988	gfc_symbol *dt_list, *dt_first;
1989
1990	dt_list = dt_first = gfc_derived_types;
1991	for (; dt_list; dt_list = dt_list->dt_next)
1992	{
1993	if (strcmp(s1: dt_list->name, s2: name) == 0)
1994	return true;
1995	if (dt_first == dt_list->dt_next)
1996	break;
1997	}
1998	return false;
1999	}
2000
2001
2002	/* Resolve an actual argument list. Most of the time, this is just
2003	resolving the expressions in the list.
2004	The exception is that we sometimes have to decide whether arguments
2005	that look like procedure arguments are really simple variable
2006	references. */
2007
2008	static bool
2009	resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
2010	bool no_formal_args)
2011	{
2012	gfc_symbol *sym;
2013	gfc_symtree *parent_st;
2014	gfc_expr *e;
2015	gfc_component *comp;
2016	int save_need_full_assumed_size;
2017	bool return_value = false;
2018	bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
2019
2020	actual_arg = true;
2021	first_actual_arg = true;
2022
2023	for (; arg; arg = arg->next)
2024	{
2025	e = arg->expr;
2026	if (e == NULL)
2027	{
2028	/* Check the label is a valid branching target. */
2029	if (arg->label)
2030	{
2031	if (arg->label->defined == ST_LABEL_UNKNOWN)
2032	{
2033	gfc_error ("Label %d referenced at %L is never defined",
2034	arg->label->value, &arg->label->where);
2035	goto cleanup;
2036	}
2037	}
2038	first_actual_arg = false;
2039	continue;
2040	}
2041
2042	if (e->expr_type == EXPR_VARIABLE
2043	&& e->symtree->n.sym->attr.generic
2044	&& no_formal_args
2045	&& count_specific_procs (e) != 1)
2046	goto cleanup;
2047
2048	if (e->ts.type != BT_PROCEDURE)
2049	{
2050	save_need_full_assumed_size = need_full_assumed_size;
2051	if (e->expr_type != EXPR_VARIABLE)
2052	need_full_assumed_size = 0;
2053	if (!gfc_resolve_expr (e))
2054	goto cleanup;
2055	need_full_assumed_size = save_need_full_assumed_size;
2056	goto argument_list;
2057	}
2058
2059	/* See if the expression node should really be a variable reference. */
2060
2061	sym = e->symtree->n.sym;
2062
2063	if (sym->attr.flavor == FL_PROCEDURE && is_dt_name (name: sym->name))
2064	{
2065	gfc_error ("Derived type %qs is used as an actual "
2066	"argument at %L", sym->name, &e->where);
2067	goto cleanup;
2068	}
2069
2070	if (sym->attr.flavor == FL_PROCEDURE
2071	|| sym->attr.intrinsic
2072	|| sym->attr.external)
2073	{
2074	int actual_ok;
2075
2076	/* If a procedure is not already determined to be something else
2077	check if it is intrinsic. */
2078	if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
2079	sym->attr.intrinsic = 1;
2080
2081	if (sym->attr.proc == PROC_ST_FUNCTION)
2082	{
2083	gfc_error ("Statement function %qs at %L is not allowed as an "
2084	"actual argument", sym->name, &e->where);
2085	}
2086
2087	actual_ok = gfc_intrinsic_actual_ok (sym->name,
2088	sym->attr.subroutine);
2089	if (sym->attr.intrinsic && actual_ok == 0)
2090	{
2091	gfc_error ("Intrinsic %qs at %L is not allowed as an "
2092	"actual argument", sym->name, &e->where);
2093	}
2094
2095	if (sym->attr.contained && !sym->attr.use_assoc
2096	&& sym->ns->proc_name->attr.flavor != FL_MODULE)
2097	{
2098	if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure %qs is"
2099	" used as actual argument at %L",
2100	sym->name, &e->where))
2101	goto cleanup;
2102	}
2103
2104	if (sym->attr.elemental && !sym->attr.intrinsic)
2105	{
2106	gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
2107	"allowed as an actual argument at %L", sym->name,
2108	&e->where);
2109	}
2110
2111	/* Check if a generic interface has a specific procedure
2112	with the same name before emitting an error. */
2113	if (sym->attr.generic && count_specific_procs (e) != 1)
2114	goto cleanup;
2115
2116	/* Just in case a specific was found for the expression. */
2117	sym = e->symtree->n.sym;
2118
2119	/* If the symbol is the function that names the current (or
2120	parent) scope, then we really have a variable reference. */
2121
2122	if (gfc_is_function_return_value (sym, sym->ns))
2123	goto got_variable;
2124
2125	/* If all else fails, see if we have a specific intrinsic. */
2126	if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
2127	{
2128	gfc_intrinsic_sym *isym;
2129
2130	isym = gfc_find_function (sym->name);
2131	if (isym == NULL || !isym->specific)
2132	{
2133	gfc_error ("Unable to find a specific INTRINSIC procedure "
2134	"for the reference %qs at %L", sym->name,
2135	&e->where);
2136	goto cleanup;
2137	}
2138	sym->ts = isym->ts;
2139	sym->attr.intrinsic = 1;
2140	sym->attr.function = 1;
2141	}
2142
2143	if (!gfc_resolve_expr (e))
2144	goto cleanup;
2145	goto argument_list;
2146	}
2147
2148	/* See if the name is a module procedure in a parent unit. */
2149
2150	if (was_declared (sym) || sym->ns->parent == NULL)
2151	goto got_variable;
2152
2153	if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
2154	{
2155	gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where);
2156	goto cleanup;
2157	}
2158
2159	if (parent_st == NULL)
2160	goto got_variable;
2161
2162	sym = parent_st->n.sym;
2163	e->symtree = parent_st; /* Point to the right thing. */
2164
2165	if (sym->attr.flavor == FL_PROCEDURE
2166	|| sym->attr.intrinsic
2167	|| sym->attr.external)
2168	{
2169	if (!gfc_resolve_expr (e))
2170	goto cleanup;
2171	goto argument_list;
2172	}
2173
2174	got_variable:
2175	e->expr_type = EXPR_VARIABLE;
2176	e->ts = sym->ts;
2177	if ((sym->as != NULL && sym->ts.type != BT_CLASS)
2178	|| (sym->ts.type == BT_CLASS && sym->attr.class_ok
2179	&& CLASS_DATA (sym)->as))
2180	{
2181	e->rank = sym->ts.type == BT_CLASS
2182	? CLASS_DATA (sym)->as->rank : sym->as->rank;
2183	e->ref = gfc_get_ref ();
2184	e->ref->type = REF_ARRAY;
2185	e->ref->u.ar.type = AR_FULL;
2186	e->ref->u.ar.as = sym->ts.type == BT_CLASS
2187	? CLASS_DATA (sym)->as : sym->as;
2188	}
2189
2190	/* Expressions are assigned a default ts.type of BT_PROCEDURE in
2191	primary.cc (match_actual_arg). If above code determines that it
2192	is a variable instead, it needs to be resolved as it was not
2193	done at the beginning of this function. */
2194	save_need_full_assumed_size = need_full_assumed_size;
2195	if (e->expr_type != EXPR_VARIABLE)
2196	need_full_assumed_size = 0;
2197	if (!gfc_resolve_expr (e))
2198	goto cleanup;
2199	need_full_assumed_size = save_need_full_assumed_size;
2200
2201	argument_list:
2202	/* Check argument list functions %VAL, %LOC and %REF. There is
2203	nothing to do for %REF. */
2204	if (arg->name && arg->name[0] == '%')
2205	{
2206	if (strcmp (s1: "%VAL", s2: arg->name) == 0)
2207	{
2208	if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
2209	{
2210	gfc_error ("By-value argument at %L is not of numeric "
2211	"type", &e->where);
2212	goto cleanup;
2213	}
2214
2215	if (e->rank)
2216	{
2217	gfc_error ("By-value argument at %L cannot be an array or "
2218	"an array section", &e->where);
2219	goto cleanup;
2220	}
2221
2222	/* Intrinsics are still PROC_UNKNOWN here. However,
2223	since same file external procedures are not resolvable
2224	in gfortran, it is a good deal easier to leave them to
2225	intrinsic.cc. */
2226	if (ptype != PROC_UNKNOWN
2227	&& ptype != PROC_DUMMY
2228	&& ptype != PROC_EXTERNAL
2229	&& ptype != PROC_MODULE)
2230	{
2231	gfc_error ("By-value argument at %L is not allowed "
2232	"in this context", &e->where);
2233	goto cleanup;
2234	}
2235	}
2236
2237	/* Statement functions have already been excluded above. */
2238	else if (strcmp (s1: "%LOC", s2: arg->name) == 0
2239	&& e->ts.type == BT_PROCEDURE)
2240	{
2241	if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
2242	{
2243	gfc_error ("Passing internal procedure at %L by location "
2244	"not allowed", &e->where);
2245	goto cleanup;
2246	}
2247	}
2248	}
2249
2250	comp = gfc_get_proc_ptr_comp(e);
2251	if (e->expr_type == EXPR_VARIABLE
2252	&& comp && comp->attr.elemental)
2253	{
2254	gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2255	"allowed as an actual argument at %L", comp->name,
2256	&e->where);
2257	}
2258
2259	/* Fortran 2008, C1237. */
2260	if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
2261	&& gfc_has_ultimate_pointer (e))
2262	{
2263	gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2264	"component", &e->where);
2265	goto cleanup;
2266	}
2267
2268	first_actual_arg = false;
2269	}
2270
2271	return_value = true;
2272
2273	cleanup:
2274	actual_arg = actual_arg_sav;
2275	first_actual_arg = first_actual_arg_sav;
2276
2277	return return_value;
2278	}
2279
2280
2281	/* Do the checks of the actual argument list that are specific to elemental
2282	procedures. If called with c == NULL, we have a function, otherwise if
2283	expr == NULL, we have a subroutine. */
2284
2285	static bool
2286	resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
2287	{
2288	gfc_actual_arglist *arg0;
2289	gfc_actual_arglist *arg;
2290	gfc_symbol *esym = NULL;
2291	gfc_intrinsic_sym *isym = NULL;
2292	gfc_expr *e = NULL;
2293	gfc_intrinsic_arg *iformal = NULL;
2294	gfc_formal_arglist *eformal = NULL;
2295	bool formal_optional = false;
2296	bool set_by_optional = false;
2297	int i;
2298	int rank = 0;
2299
2300	/* Is this an elemental procedure? */
2301	if (expr && expr->value.function.actual != NULL)
2302	{
2303	if (expr->value.function.esym != NULL
2304	&& expr->value.function.esym->attr.elemental)
2305	{
2306	arg0 = expr->value.function.actual;
2307	esym = expr->value.function.esym;
2308	}
2309	else if (expr->value.function.isym != NULL
2310	&& expr->value.function.isym->elemental)
2311	{
2312	arg0 = expr->value.function.actual;
2313	isym = expr->value.function.isym;
2314	}
2315	else
2316	return true;
2317	}
2318	else if (c && c->ext.actual != NULL)
2319	{
2320	arg0 = c->ext.actual;
2321
2322	if (c->resolved_sym)
2323	esym = c->resolved_sym;
2324	else
2325	esym = c->symtree->n.sym;
2326	gcc_assert (esym);
2327
2328	if (!esym->attr.elemental)
2329	return true;
2330	}
2331	else
2332	return true;
2333
2334	/* The rank of an elemental is the rank of its array argument(s). */
2335	for (arg = arg0; arg; arg = arg->next)
2336	{
2337	if (arg->expr != NULL && arg->expr->rank != 0)
2338	{
2339	rank = arg->expr->rank;
2340	if (arg->expr->expr_type == EXPR_VARIABLE
2341	&& arg->expr->symtree->n.sym->attr.optional)
2342	set_by_optional = true;
2343
2344	/* Function specific; set the result rank and shape. */
2345	if (expr)
2346	{
2347	expr->rank = rank;
2348	if (!expr->shape && arg->expr->shape)
2349	{
2350	expr->shape = gfc_get_shape (rank);
2351	for (i = 0; i < rank; i++)
2352	mpz_init_set (expr->shape[i], arg->expr->shape[i]);
2353	}
2354	}
2355	break;
2356	}
2357	}
2358
2359	/* If it is an array, it shall not be supplied as an actual argument
2360	to an elemental procedure unless an array of the same rank is supplied
2361	as an actual argument corresponding to a nonoptional dummy argument of
2362	that elemental procedure(12.4.1.5). */
2363	formal_optional = false;
2364	if (isym)
2365	iformal = isym->formal;
2366	else
2367	eformal = esym->formal;
2368
2369	for (arg = arg0; arg; arg = arg->next)
2370	{
2371	if (eformal)
2372	{
2373	if (eformal->sym && eformal->sym->attr.optional)
2374	formal_optional = true;
2375	eformal = eformal->next;
2376	}
2377	else if (isym && iformal)
2378	{
2379	if (iformal->optional)
2380	formal_optional = true;
2381	iformal = iformal->next;
2382	}
2383	else if (isym)
2384	formal_optional = true;
2385
2386	if (pedantic && arg->expr != NULL
2387	&& arg->expr->expr_type == EXPR_VARIABLE
2388	&& arg->expr->symtree->n.sym->attr.optional
2389	&& formal_optional
2390	&& arg->expr->rank
2391	&& (set_by_optional || arg->expr->rank != rank)
2392	&& !(isym && isym->id == GFC_ISYM_CONVERSION))
2393	{
2394	bool t = false;
2395	gfc_actual_arglist *a;
2396
2397	/* Scan the argument list for a non-optional argument with the
2398	same rank as arg. */
2399	for (a = arg0; a; a = a->next)
2400	if (a != arg
2401	&& a->expr->rank == arg->expr->rank
2402	&& !a->expr->symtree->n.sym->attr.optional)
2403	{
2404	t = true;
2405	break;
2406	}
2407
2408	if (!t)
2409	gfc_warning (opt: OPT_Wpedantic,
2410	"%qs at %L is an array and OPTIONAL; If it is not "
2411	"present, then it cannot be the actual argument of "
2412	"an ELEMENTAL procedure unless there is a non-optional"
2413	" argument with the same rank "
2414	"(Fortran 2018, 15.5.2.12)",
2415	arg->expr->symtree->n.sym->name, &arg->expr->where);
2416	}
2417	}
2418
2419	for (arg = arg0; arg; arg = arg->next)
2420	{
2421	if (arg->expr == NULL || arg->expr->rank == 0)
2422	continue;
2423
2424	/* Being elemental, the last upper bound of an assumed size array
2425	argument must be present. */
2426	if (resolve_assumed_size_actual (e: arg->expr))
2427	return false;
2428
2429	/* Elemental procedure's array actual arguments must conform. */
2430	if (e != NULL)
2431	{
2432	if (!gfc_check_conformance (arg->expr, e, _("elemental procedure")))
2433	return false;
2434	}
2435	else
2436	e = arg->expr;
2437	}
2438
2439	/* INTENT(OUT) is only allowed for subroutines; if any actual argument
2440	is an array, the intent inout/out variable needs to be also an array. */
2441	if (rank > 0 && esym && expr == NULL)
2442	for (eformal = esym->formal, arg = arg0; arg && eformal;
2443	arg = arg->next, eformal = eformal->next)
2444	if (eformal->sym
2445	&& (eformal->sym->attr.intent == INTENT_OUT
2446	|| eformal->sym->attr.intent == INTENT_INOUT)
2447	&& arg->expr && arg->expr->rank == 0)
2448	{
2449	gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2450	"ELEMENTAL subroutine %qs is a scalar, but another "
2451	"actual argument is an array", &arg->expr->where,
2452	(eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
2453	: "INOUT", eformal->sym->name, esym->name);
2454	return false;
2455	}
2456	return true;
2457	}
2458
2459
2460	/* This function does the checking of references to global procedures
2461	as defined in sections 18.1 and 14.1, respectively, of the Fortran
2462	77 and 95 standards. It checks for a gsymbol for the name, making
2463	one if it does not already exist. If it already exists, then the
2464	reference being resolved must correspond to the type of gsymbol.
2465	Otherwise, the new symbol is equipped with the attributes of the
2466	reference. The corresponding code that is called in creating
2467	global entities is parse.cc.
2468
2469	In addition, for all but -std=legacy, the gsymbols are used to
2470	check the interfaces of external procedures from the same file.
2471	The namespace of the gsymbol is resolved and then, once this is
2472	done the interface is checked. */
2473
2474
2475	static bool
2476	not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2477	{
2478	if (!gsym_ns->proc_name->attr.recursive)
2479	return true;
2480
2481	if (sym->ns == gsym_ns)
2482	return false;
2483
2484	if (sym->ns->parent && sym->ns->parent == gsym_ns)
2485	return false;
2486
2487	return true;
2488	}
2489
2490	static bool
2491	not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2492	{
2493	if (gsym_ns->entries)
2494	{
2495	gfc_entry_list *entry = gsym_ns->entries;
2496
2497	for (; entry; entry = entry->next)
2498	{
2499	if (strcmp (s1: sym->name, s2: entry->sym->name) == 0)
2500	{
2501	if (strcmp (s1: gsym_ns->proc_name->name,
2502	s2: sym->ns->proc_name->name) == 0)
2503	return false;
2504
2505	if (sym->ns->parent
2506	&& strcmp (s1: gsym_ns->proc_name->name,
2507	s2: sym->ns->parent->proc_name->name) == 0)
2508	return false;
2509	}
2510	}
2511	}
2512	return true;
2513	}
2514
2515
2516	/* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2517
2518	bool
2519	gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len)
2520	{
2521	gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym);
2522
2523	for ( ; arg; arg = arg->next)
2524	{
2525	if (!arg->sym)
2526	continue;
2527
2528	if (arg->sym->attr.allocatable) /* (2a) */
2529	{
2530	strncpy (dest: errmsg, _("allocatable argument"), n: err_len);
2531	return true;
2532	}
2533	else if (arg->sym->attr.asynchronous)
2534	{
2535	strncpy (dest: errmsg, _("asynchronous argument"), n: err_len);
2536	return true;
2537	}
2538	else if (arg->sym->attr.optional)
2539	{
2540	strncpy (dest: errmsg, _("optional argument"), n: err_len);
2541	return true;
2542	}
2543	else if (arg->sym->attr.pointer)
2544	{
2545	strncpy (dest: errmsg, _("pointer argument"), n: err_len);
2546	return true;
2547	}
2548	else if (arg->sym->attr.target)
2549	{
2550	strncpy (dest: errmsg, _("target argument"), n: err_len);
2551	return true;
2552	}
2553	else if (arg->sym->attr.value)
2554	{
2555	strncpy (dest: errmsg, _("value argument"), n: err_len);
2556	return true;
2557	}
2558	else if (arg->sym->attr.volatile_)
2559	{
2560	strncpy (dest: errmsg, _("volatile argument"), n: err_len);
2561	return true;
2562	}
2563	else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */
2564	{
2565	strncpy (dest: errmsg, _("assumed-shape argument"), n: err_len);
2566	return true;
2567	}
2568	else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */
2569	{
2570	strncpy (dest: errmsg, _("assumed-rank argument"), n: err_len);
2571	return true;
2572	}
2573	else if (arg->sym->attr.codimension) /* (2c) */
2574	{
2575	strncpy (dest: errmsg, _("coarray argument"), n: err_len);
2576	return true;
2577	}
2578	else if (false) /* (2d) TODO: parametrized derived type */
2579	{
2580	strncpy (dest: errmsg, _("parametrized derived type argument"), n: err_len);
2581	return true;
2582	}
2583	else if (arg->sym->ts.type == BT_CLASS) /* (2e) */
2584	{
2585	strncpy (dest: errmsg, _("polymorphic argument"), n: err_len);
2586	return true;
2587	}
2588	else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2589	{
2590	strncpy (dest: errmsg, _("NO_ARG_CHECK attribute"), n: err_len);
2591	return true;
2592	}
2593	else if (arg->sym->ts.type == BT_ASSUMED)
2594	{
2595	/* As assumed-type is unlimited polymorphic (cf. above).
2596	See also TS 29113, Note 6.1. */
2597	strncpy (dest: errmsg, _("assumed-type argument"), n: err_len);
2598	return true;
2599	}
2600	}
2601
2602	if (sym->attr.function)
2603	{
2604	gfc_symbol *res = sym->result ? sym->result : sym;
2605
2606	if (res->attr.dimension) /* (3a) */
2607	{
2608	strncpy (dest: errmsg, _("array result"), n: err_len);
2609	return true;
2610	}
2611	else if (res->attr.pointer || res->attr.allocatable) /* (3b) */
2612	{
2613	strncpy (dest: errmsg, _("pointer or allocatable result"), n: err_len);
2614	return true;
2615	}
2616	else if (res->ts.type == BT_CHARACTER && res->ts.u.cl
2617	&& res->ts.u.cl->length
2618	&& res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */
2619	{
2620	strncpy (dest: errmsg, _("result with non-constant character length"), n: err_len);
2621	return true;
2622	}
2623	}
2624
2625	if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */
2626	{
2627	strncpy (dest: errmsg, _("elemental procedure"), n: err_len);
2628	return true;
2629	}
2630	else if (sym->attr.is_bind_c) /* (5) */
2631	{
2632	strncpy (dest: errmsg, _("bind(c) procedure"), n: err_len);
2633	return true;
2634	}
2635
2636	return false;
2637	}
2638
2639
2640	static void
2641	resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
2642	{
2643	gfc_gsymbol * gsym;
2644	gfc_namespace *ns;
2645	enum gfc_symbol_type type;
2646	char reason[200];
2647
2648	type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2649
2650	gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
2651	bind_c: sym->binding_label != NULL);
2652
2653	if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2654	gfc_global_used (gsym, where);
2655
2656	if ((sym->attr.if_source == IFSRC_UNKNOWN
2657	|| sym->attr.if_source == IFSRC_IFBODY)
2658	&& gsym->type != GSYM_UNKNOWN
2659	&& !gsym->binding_label
2660	&& gsym->ns
2661	&& gsym->ns->proc_name
2662	&& not_in_recursive (sym, gsym_ns: gsym->ns)
2663	&& not_entry_self_reference (sym, gsym_ns: gsym->ns))
2664	{
2665	gfc_symbol *def_sym;
2666	def_sym = gsym->ns->proc_name;
2667
2668	if (gsym->ns->resolved != -1)
2669	{
2670
2671	/* Resolve the gsymbol namespace if needed. */
2672	if (!gsym->ns->resolved)
2673	{
2674	gfc_symbol *old_dt_list;
2675
2676	/* Stash away derived types so that the backend_decls
2677	do not get mixed up. */
2678	old_dt_list = gfc_derived_types;
2679	gfc_derived_types = NULL;
2680
2681	gfc_resolve (gsym->ns);
2682
2683	/* Store the new derived types with the global namespace. */
2684	if (gfc_derived_types)
2685	gsym->ns->derived_types = gfc_derived_types;
2686
2687	/* Restore the derived types of this namespace. */
2688	gfc_derived_types = old_dt_list;
2689	}
2690
2691	/* Make sure that translation for the gsymbol occurs before
2692	the procedure currently being resolved. */
2693	ns = gfc_global_ns_list;
2694	for (; ns && ns != gsym->ns; ns = ns->sibling)
2695	{
2696	if (ns->sibling == gsym->ns)
2697	{
2698	ns->sibling = gsym->ns->sibling;
2699	gsym->ns->sibling = gfc_global_ns_list;
2700	gfc_global_ns_list = gsym->ns;
2701	break;
2702	}
2703	}
2704
2705	/* This can happen if a binding name has been specified. */
2706	if (gsym->binding_label && gsym->sym_name != def_sym->name)
2707	gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
2708
2709	if (def_sym->attr.entry_master || def_sym->attr.entry)
2710	{
2711	gfc_entry_list *entry;
2712	for (entry = gsym->ns->entries; entry; entry = entry->next)
2713	if (strcmp (s1: entry->sym->name, s2: sym->name) == 0)
2714	{
2715	def_sym = entry->sym;
2716	break;
2717	}
2718	}
2719	}
2720
2721	if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
2722	{
2723	gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2724	sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2725	gfc_typename (&def_sym->ts));
2726	goto done;
2727	}
2728
2729	if (sym->attr.if_source == IFSRC_UNKNOWN
2730	&& gfc_explicit_interface_required (sym: def_sym, errmsg: reason, err_len: sizeof(reason)))
2731	{
2732	gfc_error ("Explicit interface required for %qs at %L: %s",
2733	sym->name, &sym->declared_at, reason);
2734	goto done;
2735	}
2736
2737	bool bad_result_characteristics;
2738	if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
2739	reason, sizeof(reason), NULL, NULL,
2740	bad_result_characteristics: &bad_result_characteristics))
2741	{
2742	/* Turn erros into warnings with -std=gnu and -std=legacy,
2743	unless a function returns a wrong type, which can lead
2744	to all kinds of ICEs and wrong code. */
2745
2746	if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU)
2747	&& !bad_result_characteristics)
2748	gfc_errors_to_warnings (true);
2749
2750	gfc_error ("Interface mismatch in global procedure %qs at %L: %s",
2751	sym->name, &sym->declared_at, reason);
2752	sym->error = 1;
2753	gfc_errors_to_warnings (false);
2754	goto done;
2755	}
2756	}
2757
2758	done:
2759
2760	if (gsym->type == GSYM_UNKNOWN)
2761	{
2762	gsym->type = type;
2763	gsym->where = *where;
2764	}
2765
2766	gsym->used = 1;
2767	}
2768
2769
2770	/************* Function resolution *************/
2771
2772	/* Resolve a function call known to be generic.
2773	Section 14.1.2.4.1. */
2774
2775	static match
2776	resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2777	{
2778	gfc_symbol *s;
2779
2780	if (sym->attr.generic)
2781	{
2782	s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2783	if (s != NULL)
2784	{
2785	expr->value.function.name = s->name;
2786	expr->value.function.esym = s;
2787
2788	if (s->ts.type != BT_UNKNOWN)
2789	expr->ts = s->ts;
2790	else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2791	expr->ts = s->result->ts;
2792
2793	if (s->as != NULL)
2794	expr->rank = s->as->rank;
2795	else if (s->result != NULL && s->result->as != NULL)
2796	expr->rank = s->result->as->rank;
2797
2798	gfc_set_sym_referenced (expr->value.function.esym);
2799
2800	return MATCH_YES;
2801	}
2802
2803	/* TODO: Need to search for elemental references in generic
2804	interface. */
2805	}
2806
2807	if (sym->attr.intrinsic)
2808	return gfc_intrinsic_func_interface (expr, 0);
2809
2810	return MATCH_NO;
2811	}
2812
2813
2814	static bool
2815	resolve_generic_f (gfc_expr *expr)
2816	{
2817	gfc_symbol *sym;
2818	match m;
2819	gfc_interface *intr = NULL;
2820
2821	sym = expr->symtree->n.sym;
2822
2823	for (;;)
2824	{
2825	m = resolve_generic_f0 (expr, sym);
2826	if (m == MATCH_YES)
2827	return true;
2828	else if (m == MATCH_ERROR)
2829	return false;
2830
2831	generic:
2832	if (!intr)
2833	for (intr = sym->generic; intr; intr = intr->next)
2834	if (gfc_fl_struct (intr->sym->attr.flavor))
2835	break;
2836
2837	if (sym->ns->parent == NULL)
2838	break;
2839	gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2840
2841	if (sym == NULL)
2842	break;
2843	if (!generic_sym (sym))
2844	goto generic;
2845	}
2846
2847	/* Last ditch attempt. See if the reference is to an intrinsic
2848	that possesses a matching interface. 14.1.2.4 */
2849	if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2850	{
2851	if (gfc_init_expr_flag)
2852	gfc_error ("Function %qs in initialization expression at %L "
2853	"must be an intrinsic function",
2854	expr->symtree->n.sym->name, &expr->where);
2855	else
2856	gfc_error ("There is no specific function for the generic %qs "
2857	"at %L", expr->symtree->n.sym->name, &expr->where);
2858	return false;
2859	}
2860
2861	if (intr)
2862	{
2863	if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL,
2864	NULL, false))
2865	return false;
2866	if (!gfc_use_derived (expr->ts.u.derived))
2867	return false;
2868	return resolve_structure_cons (expr, init: 0);
2869	}
2870
2871	m = gfc_intrinsic_func_interface (expr, 0);
2872	if (m == MATCH_YES)
2873	return true;
2874
2875	if (m == MATCH_NO)
2876	gfc_error ("Generic function %qs at %L is not consistent with a "
2877	"specific intrinsic interface", expr->symtree->n.sym->name,
2878	&expr->where);
2879
2880	return false;
2881	}
2882
2883
2884	/* Resolve a function call known to be specific. */
2885
2886	static match
2887	resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2888	{
2889	match m;
2890
2891	if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2892	{
2893	if (sym->attr.dummy)
2894	{
2895	sym->attr.proc = PROC_DUMMY;
2896	goto found;
2897	}
2898
2899	sym->attr.proc = PROC_EXTERNAL;
2900	goto found;
2901	}
2902
2903	if (sym->attr.proc == PROC_MODULE
2904	|| sym->attr.proc == PROC_ST_FUNCTION
2905	|| sym->attr.proc == PROC_INTERNAL)
2906	goto found;
2907
2908	if (sym->attr.intrinsic)
2909	{
2910	m = gfc_intrinsic_func_interface (expr, 1);
2911	if (m == MATCH_YES)
2912	return MATCH_YES;
2913	if (m == MATCH_NO)
2914	gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2915	"with an intrinsic", sym->name, &expr->where);
2916
2917	return MATCH_ERROR;
2918	}
2919
2920	return MATCH_NO;
2921
2922	found:
2923	gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2924
2925	if (sym->result)
2926	expr->ts = sym->result->ts;
2927	else
2928	expr->ts = sym->ts;
2929	expr->value.function.name = sym->name;
2930	expr->value.function.esym = sym;
2931	/* Prevent crash when sym->ts.u.derived->components is not set due to previous
2932	error(s). */
2933	if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym))
2934	return MATCH_ERROR;
2935	if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
2936	expr->rank = CLASS_DATA (sym)->as->rank;
2937	else if (sym->as != NULL)
2938	expr->rank = sym->as->rank;
2939
2940	return MATCH_YES;
2941	}
2942
2943
2944	static bool
2945	resolve_specific_f (gfc_expr *expr)
2946	{
2947	gfc_symbol *sym;
2948	match m;
2949
2950	sym = expr->symtree->n.sym;
2951
2952	for (;;)
2953	{
2954	m = resolve_specific_f0 (sym, expr);
2955	if (m == MATCH_YES)
2956	return true;
2957	if (m == MATCH_ERROR)
2958	return false;
2959
2960	if (sym->ns->parent == NULL)
2961	break;
2962
2963	gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2964
2965	if (sym == NULL)
2966	break;
2967	}
2968
2969	gfc_error ("Unable to resolve the specific function %qs at %L",
2970	expr->symtree->n.sym->name, &expr->where);
2971
2972	return true;
2973	}
2974
2975	/* Recursively append candidate SYM to CANDIDATES. Store the number of
2976	candidates in CANDIDATES_LEN. */
2977
2978	static void
2979	lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
2980	char **&candidates,
2981	size_t &candidates_len)
2982	{
2983	gfc_symtree *p;
2984
2985	if (sym == NULL)
2986	return;
2987	if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
2988	&& sym->n.sym->attr.flavor == FL_PROCEDURE)
2989	vec_push (optr&: candidates, osz&: candidates_len, elt: sym->name);
2990
2991	p = sym->left;
2992	if (p)
2993	lookup_function_fuzzy_find_candidates (sym: p, candidates, candidates_len);
2994
2995	p = sym->right;
2996	if (p)
2997	lookup_function_fuzzy_find_candidates (sym: p, candidates, candidates_len);
2998	}
2999
3000
3001	/* Lookup function FN fuzzily, taking names in SYMROOT into account. */
3002
3003	const char*
3004	gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
3005	{
3006	char **candidates = NULL;
3007	size_t candidates_len = 0;
3008	lookup_function_fuzzy_find_candidates (sym: symroot, candidates, candidates_len);
3009	return gfc_closest_fuzzy_match (fn, candidates);
3010	}
3011
3012
3013	/* Resolve a procedure call not known to be generic nor specific. */
3014
3015	static bool
3016	resolve_unknown_f (gfc_expr *expr)
3017	{
3018	gfc_symbol *sym;
3019	gfc_typespec *ts;
3020
3021	sym = expr->symtree->n.sym;
3022
3023	if (sym->attr.dummy)
3024	{
3025	sym->attr.proc = PROC_DUMMY;
3026	expr->value.function.name = sym->name;
3027	goto set_type;
3028	}
3029
3030	/* See if we have an intrinsic function reference. */
3031
3032	if (gfc_is_intrinsic (sym, 0, expr->where))
3033	{
3034	if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
3035	return true;
3036	return false;
3037	}
3038
3039	/* IMPLICIT NONE (external) procedures require an explicit EXTERNAL attr. */
3040	/* Intrinsics were handled above, only non-intrinsics left here. */
3041	if (sym->attr.flavor == FL_PROCEDURE
3042	&& sym->attr.implicit_type
3043	&& sym->ns
3044	&& sym->ns->has_implicit_none_export)
3045	{
3046	gfc_error ("Missing explicit declaration with EXTERNAL attribute "
3047	"for symbol %qs at %L", sym->name, &sym->declared_at);
3048	sym->error = 1;
3049	return false;
3050	}
3051
3052	/* The reference is to an external name. */
3053
3054	sym->attr.proc = PROC_EXTERNAL;
3055	expr->value.function.name = sym->name;
3056	expr->value.function.esym = expr->symtree->n.sym;
3057
3058	if (sym->as != NULL)
3059	expr->rank = sym->as->rank;
3060
3061	/* Type of the expression is either the type of the symbol or the
3062	default type of the symbol. */
3063
3064	set_type:
3065	gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
3066
3067	if (sym->ts.type != BT_UNKNOWN)
3068	expr->ts = sym->ts;
3069	else
3070	{
3071	ts = gfc_get_default_type (sym->name, sym->ns);
3072
3073	if (ts->type == BT_UNKNOWN)
3074	{
3075	const char *guessed
3076	= gfc_lookup_function_fuzzy (fn: sym->name, symroot: sym->ns->sym_root);
3077	if (guessed)
3078	gfc_error ("Function %qs at %L has no IMPLICIT type"
3079	"; did you mean %qs?",
3080	sym->name, &expr->where, guessed);
3081	else
3082	gfc_error ("Function %qs at %L has no IMPLICIT type",
3083	sym->name, &expr->where);
3084	return false;
3085	}
3086	else
3087	expr->ts = *ts;
3088	}
3089
3090	return true;
3091	}
3092
3093
3094	/* Return true, if the symbol is an external procedure. */
3095	static bool
3096	is_external_proc (gfc_symbol *sym)
3097	{
3098	if (!sym->attr.dummy && !sym->attr.contained
3099	&& !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
3100	&& sym->attr.proc != PROC_ST_FUNCTION
3101	&& !sym->attr.proc_pointer
3102	&& !sym->attr.use_assoc
3103	&& sym->name)
3104	return true;
3105
3106	return false;
3107	}
3108
3109
3110	/* Figure out if a function reference is pure or not. Also set the name
3111	of the function for a potential error message. Return nonzero if the
3112	function is PURE, zero if not. */
3113	static bool
3114	pure_stmt_function (gfc_expr *, gfc_symbol *);
3115
3116	bool
3117	gfc_pure_function (gfc_expr *e, const char **name)
3118	{
3119	bool pure;
3120	gfc_component *comp;
3121
3122	*name = NULL;
3123
3124	if (e->symtree != NULL
3125	&& e->symtree->n.sym != NULL
3126	&& e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3127	return pure_stmt_function (e, e->symtree->n.sym);
3128
3129	comp = gfc_get_proc_ptr_comp (e);
3130	if (comp)
3131	{
3132	pure = gfc_pure (comp->ts.interface);
3133	*name = comp->name;
3134	}
3135	else if (e->value.function.esym)
3136	{
3137	pure = gfc_pure (e->value.function.esym);
3138	*name = e->value.function.esym->name;
3139	}
3140	else if (e->value.function.isym)
3141	{
3142	pure = e->value.function.isym->pure
3143	|| e->value.function.isym->elemental;
3144	*name = e->value.function.isym->name;
3145	}
3146	else
3147	{
3148	/* Implicit functions are not pure. */
3149	pure = 0;
3150	*name = e->value.function.name;
3151	}
3152
3153	return pure;
3154	}
3155
3156
3157	/* Check if the expression is a reference to an implicitly pure function. */
3158
3159	bool
3160	gfc_implicit_pure_function (gfc_expr *e)
3161	{
3162	gfc_component *comp = gfc_get_proc_ptr_comp (e);
3163	if (comp)
3164	return gfc_implicit_pure (comp->ts.interface);
3165	else if (e->value.function.esym)
3166	return gfc_implicit_pure (e->value.function.esym);
3167	else
3168	return 0;
3169	}
3170
3171
3172	static bool
3173	impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
3174	int *f ATTRIBUTE_UNUSED)
3175	{
3176	const char *name;
3177
3178	/* Don't bother recursing into other statement functions
3179	since they will be checked individually for purity. */
3180	if (e->expr_type != EXPR_FUNCTION
3181	|| !e->symtree
3182	|| e->symtree->n.sym == sym
3183	|| e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3184	return false;
3185
3186	return gfc_pure_function (e, name: &name) ? false : true;
3187	}
3188
3189
3190	static bool
3191	pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
3192	{
3193	return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
3194	}
3195
3196
3197	/* Check if an impure function is allowed in the current context. */
3198
3199	static bool check_pure_function (gfc_expr *e)
3200	{
3201	const char *name = NULL;
3202	if (!gfc_pure_function (e, name: &name) && name)
3203	{
3204	if (forall_flag)
3205	{
3206	gfc_error ("Reference to impure function %qs at %L inside a "
3207	"FORALL %s", name, &e->where,
3208	forall_flag == 2 ? "mask" : "block");
3209	return false;
3210	}
3211	else if (gfc_do_concurrent_flag)
3212	{
3213	gfc_error ("Reference to impure function %qs at %L inside a "
3214	"DO CONCURRENT %s", name, &e->where,
3215	gfc_do_concurrent_flag == 2 ? "mask" : "block");
3216	return false;
3217	}
3218	else if (gfc_pure (NULL))
3219	{
3220	gfc_error ("Reference to impure function %qs at %L "
3221	"within a PURE procedure", name, &e->where);
3222	return false;
3223	}
3224	if (!gfc_implicit_pure_function (e))
3225	gfc_unset_implicit_pure (NULL);
3226	}
3227	return true;
3228	}
3229
3230
3231	/* Update current procedure's array_outer_dependency flag, considering
3232	a call to procedure SYM. */
3233
3234	static void
3235	update_current_proc_array_outer_dependency (gfc_symbol *sym)
3236	{
3237	/* Check to see if this is a sibling function that has not yet
3238	been resolved. */
3239	gfc_namespace *sibling = gfc_current_ns->sibling;
3240	for (; sibling; sibling = sibling->sibling)
3241	{
3242	if (sibling->proc_name == sym)
3243	{
3244	gfc_resolve (sibling);
3245	break;
3246	}
3247	}
3248
3249	/* If SYM has references to outer arrays, so has the procedure calling
3250	SYM. If SYM is a procedure pointer, we can assume the worst. */
3251	if ((sym->attr.array_outer_dependency || sym->attr.proc_pointer)
3252	&& gfc_current_ns->proc_name)
3253	gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3254	}
3255
3256
3257	/* Resolve a function call, which means resolving the arguments, then figuring
3258	out which entity the name refers to. */
3259
3260	static bool
3261	resolve_function (gfc_expr *expr)
3262	{
3263	gfc_actual_arglist *arg;
3264	gfc_symbol *sym;
3265	bool t;
3266	int temp;
3267	procedure_type p = PROC_INTRINSIC;
3268	bool no_formal_args;
3269
3270	sym = NULL;
3271	if (expr->symtree)
3272	sym = expr->symtree->n.sym;
3273
3274	/* If this is a procedure pointer component, it has already been resolved. */
3275	if (gfc_is_proc_ptr_comp (expr))
3276	return true;
3277
3278	/* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3279	another caf_get. */
3280	if (sym && sym->attr.intrinsic
3281	&& (sym->intmod_sym_id == GFC_ISYM_CAF_GET
3282	|| sym->intmod_sym_id == GFC_ISYM_CAF_SEND))
3283	return true;
3284
3285	if (expr->ref)
3286	{
3287	gfc_error ("Unexpected junk after %qs at %L", expr->symtree->n.sym->name,
3288	&expr->where);
3289	return false;
3290	}
3291
3292	if (sym && sym->attr.intrinsic
3293	&& !gfc_resolve_intrinsic (sym, loc: &expr->where))
3294	return false;
3295
3296	if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
3297	{
3298	gfc_error ("%qs at %L is not a function", sym->name, &expr->where);
3299	return false;
3300	}
3301
3302	/* If this is a deferred TBP with an abstract interface (which may
3303	of course be referenced), expr->value.function.esym will be set. */
3304	if (sym && sym->attr.abstract && !expr->value.function.esym)
3305	{
3306	gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3307	sym->name, &expr->where);
3308	return false;
3309	}
3310
3311	/* If this is a deferred TBP with an abstract interface, its result
3312	cannot be an assumed length character (F2003: C418). */
3313	if (sym && sym->attr.abstract && sym->attr.function
3314	&& sym->result->ts.u.cl
3315	&& sym->result->ts.u.cl->length == NULL
3316	&& !sym->result->ts.deferred)
3317	{
3318	gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3319	"character length result (F2008: C418)", sym->name,
3320	&sym->declared_at);
3321	return false;
3322	}
3323
3324	/* Switch off assumed size checking and do this again for certain kinds
3325	of procedure, once the procedure itself is resolved. */
3326	need_full_assumed_size++;
3327
3328	if (expr->symtree && expr->symtree->n.sym)
3329	p = expr->symtree->n.sym->attr.proc;
3330
3331	if (expr->value.function.isym && expr->value.function.isym->inquiry)
3332	inquiry_argument = true;
3333	no_formal_args = sym && is_external_proc (sym)
3334	&& gfc_sym_get_dummy_args (sym) == NULL;
3335
3336	if (!resolve_actual_arglist (arg: expr->value.function.actual,
3337	ptype: p, no_formal_args))
3338	{
3339	inquiry_argument = false;
3340	return false;
3341	}
3342
3343	inquiry_argument = false;
3344
3345	/* Resume assumed_size checking. */
3346	need_full_assumed_size--;
3347
3348	/* If the procedure is external, check for usage. */
3349	if (sym && is_external_proc (sym))
3350	resolve_global_procedure (sym, where: &expr->where, sub: 0);
3351
3352	if (sym && sym->ts.type == BT_CHARACTER
3353	&& sym->ts.u.cl
3354	&& sym->ts.u.cl->length == NULL
3355	&& !sym->attr.dummy
3356	&& !sym->ts.deferred
3357	&& expr->value.function.esym == NULL
3358	&& !sym->attr.contained)
3359	{
3360	/* Internal procedures are taken care of in resolve_contained_fntype. */
3361	gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3362	"be used at %L since it is not a dummy argument",
3363	sym->name, &expr->where);
3364	return false;
3365	}
3366
3367	/* See if function is already resolved. */
3368
3369	if (expr->value.function.name != NULL
3370	|| expr->value.function.isym != NULL)
3371	{
3372	if (expr->ts.type == BT_UNKNOWN)
3373	expr->ts = sym->ts;
3374	t = true;
3375	}
3376	else
3377	{
3378	/* Apply the rules of section 14.1.2. */
3379
3380	switch (procedure_kind (sym))
3381	{
3382	case PTYPE_GENERIC:
3383	t = resolve_generic_f (expr);
3384	break;
3385
3386	case PTYPE_SPECIFIC:
3387	t = resolve_specific_f (expr);
3388	break;
3389
3390	case PTYPE_UNKNOWN:
3391	t = resolve_unknown_f (expr);
3392	break;
3393
3394	default:
3395	gfc_internal_error ("resolve_function(): bad function type");
3396	}
3397	}
3398
3399	/* If the expression is still a function (it might have simplified),
3400	then we check to see if we are calling an elemental function. */
3401
3402	if (expr->expr_type != EXPR_FUNCTION)
3403	return t;
3404
3405	/* Walk the argument list looking for invalid BOZ. */
3406	for (arg = expr->value.function.actual; arg; arg = arg->next)
3407	if (arg->expr && arg->expr->ts.type == BT_BOZ)
3408	{
3409	gfc_error ("A BOZ literal constant at %L cannot appear as an "
3410	"actual argument in a function reference",
3411	&arg->expr->where);
3412	return false;
3413	}
3414
3415	temp = need_full_assumed_size;
3416	need_full_assumed_size = 0;
3417
3418	if (!resolve_elemental_actual (expr, NULL))
3419	return false;
3420
3421	if (omp_workshare_flag
3422	&& expr->value.function.esym
3423	&& ! gfc_elemental (expr->value.function.esym))
3424	{
3425	gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3426	"in WORKSHARE construct", expr->value.function.esym->name,
3427	&expr->where);
3428	t = false;
3429	}
3430
3431	#define GENERIC_ID expr->value.function.isym->id
3432	else if (expr->value.function.actual != NULL
3433	&& expr->value.function.isym != NULL
3434	&& GENERIC_ID != GFC_ISYM_LBOUND
3435	&& GENERIC_ID != GFC_ISYM_LCOBOUND
3436	&& GENERIC_ID != GFC_ISYM_UCOBOUND
3437	&& GENERIC_ID != GFC_ISYM_LEN
3438	&& GENERIC_ID != GFC_ISYM_LOC
3439	&& GENERIC_ID != GFC_ISYM_C_LOC
3440	&& GENERIC_ID != GFC_ISYM_PRESENT)
3441	{
3442	/* Array intrinsics must also have the last upper bound of an
3443	assumed size array argument. UBOUND and SIZE have to be
3444	excluded from the check if the second argument is anything
3445	than a constant. */
3446
3447	for (arg = expr->value.function.actual; arg; arg = arg->next)
3448	{
3449	if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3450	&& arg == expr->value.function.actual
3451	&& arg->next != NULL && arg->next->expr)
3452	{
3453	if (arg->next->expr->expr_type != EXPR_CONSTANT)
3454	break;
3455
3456	if (arg->next->name && strcmp (s1: arg->next->name, s2: "kind") == 0)
3457	break;
3458
3459	if ((int)mpz_get_si (arg->next->expr->value.integer)
3460	< arg->expr->rank)
3461	break;
3462	}
3463
3464	if (arg->expr != NULL
3465	&& arg->expr->rank > 0
3466	&& resolve_assumed_size_actual (e: arg->expr))
3467	return false;
3468	}
3469	}
3470	#undef GENERIC_ID
3471
3472	need_full_assumed_size = temp;
3473
3474	if (!check_pure_function(e: expr))
3475	t = false;
3476
3477	/* Functions without the RECURSIVE attribution are not allowed to
3478	* call themselves. */
3479	if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3480	{
3481	gfc_symbol *esym;
3482	esym = expr->value.function.esym;
3483
3484	if (is_illegal_recursion (sym: esym, context: gfc_current_ns))
3485	{
3486	if (esym->attr.entry && esym->ns->entries)
3487	gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3488	" function %qs is not RECURSIVE",
3489	esym->name, &expr->where, esym->ns->entries->sym->name);
3490	else
3491	gfc_error ("Function %qs at %L cannot be called recursively, as it"
3492	" is not RECURSIVE", esym->name, &expr->where);
3493
3494	t = false;
3495	}
3496	}
3497
3498	/* Character lengths of use associated functions may contains references to
3499	symbols not referenced from the current program unit otherwise. Make sure
3500	those symbols are marked as referenced. */
3501
3502	if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3503	&& expr->value.function.esym->attr.use_assoc)
3504	{
3505	gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3506	}
3507
3508	/* Make sure that the expression has a typespec that works. */
3509	if (expr->ts.type == BT_UNKNOWN)
3510	{
3511	if (expr->symtree->n.sym->result
3512	&& expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3513	&& !expr->symtree->n.sym->result->attr.proc_pointer)
3514	expr->ts = expr->symtree->n.sym->result->ts;
3515	}
3516
3517	/* These derived types with an incomplete namespace, arising from use
3518	association, cause gfc_get_derived_vtab to segfault. If the function
3519	namespace does not suffice, something is badly wrong. */
3520	if (expr->ts.type == BT_DERIVED
3521	&& !expr->ts.u.derived->ns->proc_name)
3522	{
3523	gfc_symbol *der;
3524	gfc_find_symbol (expr->ts.u.derived->name, expr->symtree->n.sym->ns, 1, &der);
3525	if (der)
3526	{
3527	expr->ts.u.derived->refs--;
3528	expr->ts.u.derived = der;
3529	der->refs++;
3530	}
3531	else
3532	expr->ts.u.derived->ns = expr->symtree->n.sym->ns;
3533	}
3534
3535	if (!expr->ref && !expr->value.function.isym)
3536	{
3537	if (expr->value.function.esym)
3538	update_current_proc_array_outer_dependency (sym: expr->value.function.esym);
3539	else
3540	update_current_proc_array_outer_dependency (sym);
3541	}
3542	else if (expr->ref)
3543	/* typebound procedure: Assume the worst. */
3544	gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3545
3546	if (expr->value.function.esym
3547	&& expr->value.function.esym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
3548	gfc_warning (opt: OPT_Wdeprecated_declarations,
3549	"Using function %qs at %L is deprecated",
3550	sym->name, &expr->where);
3551	return t;
3552	}
3553
3554
3555	/************* Subroutine resolution *************/
3556
3557	static bool
3558	pure_subroutine (gfc_symbol *sym, const char *name, locus *loc)
3559	{
3560	if (gfc_pure (sym))
3561	return true;
3562
3563	if (forall_flag)
3564	{
3565	gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3566	name, loc);
3567	return false;
3568	}
3569	else if (gfc_do_concurrent_flag)
3570	{
3571	gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3572	"PURE", name, loc);
3573	return false;
3574	}
3575	else if (gfc_pure (NULL))
3576	{
3577	gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc);
3578	return false;
3579	}
3580
3581	gfc_unset_implicit_pure (NULL);
3582	return true;
3583	}
3584
3585
3586	static match
3587	resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3588	{
3589	gfc_symbol *s;
3590
3591	if (sym->attr.generic)
3592	{
3593	s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3594	if (s != NULL)
3595	{
3596	c->resolved_sym = s;
3597	if (!pure_subroutine (sym: s, name: s->name, loc: &c->loc))
3598	return MATCH_ERROR;
3599	return MATCH_YES;
3600	}
3601
3602	/* TODO: Need to search for elemental references in generic interface. */
3603	}
3604
3605	if (sym->attr.intrinsic)
3606	return gfc_intrinsic_sub_interface (c, 0);
3607
3608	return MATCH_NO;
3609	}
3610
3611
3612	static bool
3613	resolve_generic_s (gfc_code *c)
3614	{
3615	gfc_symbol *sym;
3616	match m;
3617
3618	sym = c->symtree->n.sym;
3619
3620	for (;;)
3621	{
3622	m = resolve_generic_s0 (c, sym);
3623	if (m == MATCH_YES)
3624	return true;
3625	else if (m == MATCH_ERROR)
3626	return false;
3627
3628	generic:
3629	if (sym->ns->parent == NULL)
3630	break;
3631	gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3632
3633	if (sym == NULL)
3634	break;
3635	if (!generic_sym (sym))
3636	goto generic;
3637	}
3638
3639	/* Last ditch attempt. See if the reference is to an intrinsic
3640	that possesses a matching interface. 14.1.2.4 */
3641	sym = c->symtree->n.sym;
3642
3643	if (!gfc_is_intrinsic (sym, 1, c->loc))
3644	{
3645	gfc_error ("There is no specific subroutine for the generic %qs at %L",
3646	sym->name, &c->loc);
3647	return false;
3648	}
3649
3650	m = gfc_intrinsic_sub_interface (c, 0);
3651	if (m == MATCH_YES)
3652	return true;
3653	if (m == MATCH_NO)
3654	gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3655	"intrinsic subroutine interface", sym->name, &c->loc);
3656
3657	return false;
3658	}
3659
3660
3661	/* Resolve a subroutine call known to be specific. */
3662
3663	static match
3664	resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3665	{
3666	match m;
3667
3668	if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3669	{
3670	if (sym->attr.dummy)
3671	{
3672	sym->attr.proc = PROC_DUMMY;
3673	goto found;
3674	}
3675
3676	sym->attr.proc = PROC_EXTERNAL;
3677	goto found;
3678	}
3679
3680	if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3681	goto found;
3682
3683	if (sym->attr.intrinsic)
3684	{
3685	m = gfc_intrinsic_sub_interface (c, 1);
3686	if (m == MATCH_YES)
3687	return MATCH_YES;
3688	if (m == MATCH_NO)
3689	gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3690	"with an intrinsic", sym->name, &c->loc);
3691
3692	return MATCH_ERROR;
3693	}
3694
3695	return MATCH_NO;
3696
3697	found:
3698	gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3699
3700	c->resolved_sym = sym;
3701	if (!pure_subroutine (sym, name: sym->name, loc: &c->loc))
3702	return MATCH_ERROR;
3703
3704	return MATCH_YES;
3705	}
3706
3707
3708	static bool
3709	resolve_specific_s (gfc_code *c)
3710	{
3711	gfc_symbol *sym;
3712	match m;
3713
3714	sym = c->symtree->n.sym;
3715
3716	for (;;)
3717	{
3718	m = resolve_specific_s0 (c, sym);
3719	if (m == MATCH_YES)
3720	return true;
3721	if (m == MATCH_ERROR)
3722	return false;
3723
3724	if (sym->ns->parent == NULL)
3725	break;
3726
3727	gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3728
3729	if (sym == NULL)
3730	break;
3731	}
3732
3733	sym = c->symtree->n.sym;
3734	gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3735	sym->name, &c->loc);
3736
3737	return false;
3738	}
3739
3740
3741	/* Resolve a subroutine call not known to be generic nor specific. */
3742
3743	static bool
3744	resolve_unknown_s (gfc_code *c)
3745	{
3746	gfc_symbol *sym;
3747
3748	sym = c->symtree->n.sym;
3749
3750	if (sym->attr.dummy)
3751	{
3752	sym->attr.proc = PROC_DUMMY;
3753	goto found;
3754	}
3755
3756	/* See if we have an intrinsic function reference. */
3757
3758	if (gfc_is_intrinsic (sym, 1, c->loc))
3759	{
3760	if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3761	return true;
3762	return false;
3763	}
3764
3765	/* The reference is to an external name. */
3766
3767	found:
3768	gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3769
3770	c->resolved_sym = sym;
3771
3772	return pure_subroutine (sym, name: sym->name, loc: &c->loc);
3773	}
3774
3775
3776	/* Resolve a subroutine call. Although it was tempting to use the same code
3777	for functions, subroutines and functions are stored differently and this
3778	makes things awkward. */
3779
3780	static bool
3781	resolve_call (gfc_code *c)
3782	{
3783	bool t;
3784	procedure_type ptype = PROC_INTRINSIC;
3785	gfc_symbol *csym, *sym;
3786	bool no_formal_args;
3787
3788	csym = c->symtree ? c->symtree->n.sym : NULL;
3789
3790	if (csym && csym->ts.type != BT_UNKNOWN)
3791	{
3792	gfc_error ("%qs at %L has a type, which is not consistent with "
3793	"the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3794	return false;
3795	}
3796
3797	if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3798	{
3799	gfc_symtree *st;
3800	gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
3801	sym = st ? st->n.sym : NULL;
3802	if (sym && csym != sym
3803	&& sym->ns == gfc_current_ns
3804	&& sym->attr.flavor == FL_PROCEDURE
3805	&& sym->attr.contained)
3806	{
3807	sym->refs++;
3808	if (csym->attr.generic)
3809	c->symtree->n.sym = sym;
3810	else
3811	c->symtree = st;
3812	csym = c->symtree->n.sym;
3813	}
3814	}
3815
3816	/* If this ia a deferred TBP, c->expr1 will be set. */
3817	if (!c->expr1 && csym)
3818	{
3819	if (csym->attr.abstract)
3820	{
3821	gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3822	csym->name, &c->loc);
3823	return false;
3824	}
3825
3826	/* Subroutines without the RECURSIVE attribution are not allowed to
3827	call themselves. */
3828	if (is_illegal_recursion (sym: csym, context: gfc_current_ns))
3829	{
3830	if (csym->attr.entry && csym->ns->entries)
3831	gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3832	"as subroutine %qs is not RECURSIVE",
3833	csym->name, &c->loc, csym->ns->entries->sym->name);
3834	else
3835	gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3836	"as it is not RECURSIVE", csym->name, &c->loc);
3837
3838	t = false;
3839	}
3840	}
3841
3842	/* Switch off assumed size checking and do this again for certain kinds
3843	of procedure, once the procedure itself is resolved. */
3844	need_full_assumed_size++;
3845
3846	if (csym)
3847	ptype = csym->attr.proc;
3848
3849	no_formal_args = csym && is_external_proc (sym: csym)
3850	&& gfc_sym_get_dummy_args (csym) == NULL;
3851	if (!resolve_actual_arglist (arg: c->ext.actual, ptype, no_formal_args))
3852	return false;
3853
3854	/* Resume assumed_size checking. */
3855	need_full_assumed_size--;
3856
3857	/* If external, check for usage. */
3858	if (csym && is_external_proc (sym: csym))
3859	resolve_global_procedure (sym: csym, where: &c->loc, sub: 1);
3860
3861	t = true;
3862	if (c->resolved_sym == NULL)
3863	{
3864	c->resolved_isym = NULL;
3865	switch (procedure_kind (sym: csym))
3866	{
3867	case PTYPE_GENERIC:
3868	t = resolve_generic_s (c);
3869	break;
3870
3871	case PTYPE_SPECIFIC:
3872	t = resolve_specific_s (c);
3873	break;
3874
3875	case PTYPE_UNKNOWN:
3876	t = resolve_unknown_s (c);
3877	break;
3878
3879	default:
3880	gfc_internal_error ("resolve_subroutine(): bad function type");
3881	}
3882	}
3883
3884	/* Some checks of elemental subroutine actual arguments. */
3885	if (!resolve_elemental_actual (NULL, c))
3886	return false;
3887
3888	if (!c->expr1)
3889	update_current_proc_array_outer_dependency (sym: csym);
3890	else
3891	/* Typebound procedure: Assume the worst. */
3892	gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3893
3894	if (c->resolved_sym
3895	&& c->resolved_sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
3896	gfc_warning (opt: OPT_Wdeprecated_declarations,
3897	"Using subroutine %qs at %L is deprecated",
3898	c->resolved_sym->name, &c->loc);
3899
3900	return t;
3901	}
3902
3903
3904	/* Compare the shapes of two arrays that have non-NULL shapes. If both
3905	op1->shape and op2->shape are non-NULL return true if their shapes
3906	match. If both op1->shape and op2->shape are non-NULL return false
3907	if their shapes do not match. If either op1->shape or op2->shape is
3908	NULL, return true. */
3909
3910	static bool
3911	compare_shapes (gfc_expr *op1, gfc_expr *op2)
3912	{
3913	bool t;
3914	int i;
3915
3916	t = true;
3917
3918	if (op1->shape != NULL && op2->shape != NULL)
3919	{
3920	for (i = 0; i < op1->rank; i++)
3921	{
3922	if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3923	{
3924	gfc_error ("Shapes for operands at %L and %L are not conformable",
3925	&op1->where, &op2->where);
3926	t = false;
3927	break;
3928	}
3929	}
3930	}
3931
3932	return t;
3933	}
3934
3935	/* Convert a logical operator to the corresponding bitwise intrinsic call.
3936	For example A .AND. B becomes IAND(A, B). */
3937	static gfc_expr *
3938	logical_to_bitwise (gfc_expr *e)
3939	{
3940	gfc_expr *tmp, *op1, *op2;
3941	gfc_isym_id isym;
3942	gfc_actual_arglist *args = NULL;
3943
3944	gcc_assert (e->expr_type == EXPR_OP);
3945
3946	isym = GFC_ISYM_NONE;
3947	op1 = e->value.op.op1;
3948	op2 = e->value.op.op2;
3949
3950	switch (e->value.op.op)
3951	{
3952	case INTRINSIC_NOT:
3953	isym = GFC_ISYM_NOT;
3954	break;
3955	case INTRINSIC_AND:
3956	isym = GFC_ISYM_IAND;
3957	break;
3958	case INTRINSIC_OR:
3959	isym = GFC_ISYM_IOR;
3960	break;
3961	case INTRINSIC_NEQV:
3962	isym = GFC_ISYM_IEOR;
3963	break;
3964	case INTRINSIC_EQV:
3965	/* "Bitwise eqv" is just the complement of NEQV === IEOR.
3966	Change the old expression to NEQV, which will get replaced by IEOR,
3967	and wrap it in NOT. */
3968	tmp = gfc_copy_expr (e);
3969	tmp->value.op.op = INTRINSIC_NEQV;
3970	tmp = logical_to_bitwise (e: tmp);
3971	isym = GFC_ISYM_NOT;
3972	op1 = tmp;
3973	op2 = NULL;
3974	break;
3975	default:
3976	gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3977	}
3978
3979	/* Inherit the original operation's operands as arguments. */
3980	args = gfc_get_actual_arglist ();
3981	args->expr = op1;
3982	if (op2)
3983	{
3984	args->next = gfc_get_actual_arglist ();
3985	args->next->expr = op2;
3986	}
3987
3988	/* Convert the expression to a function call. */
3989	e->expr_type = EXPR_FUNCTION;
3990	e->value.function.actual = args;
3991	e->value.function.isym = gfc_intrinsic_function_by_id (isym);
3992	e->value.function.name = e->value.function.isym->name;
3993	e->value.function.esym = NULL;
3994
3995	/* Make up a pre-resolved function call symtree if we need to. */
3996	if (!e->symtree || !e->symtree->n.sym)
3997	{
3998	gfc_symbol *sym;
3999	gfc_get_ha_sym_tree (e->value.function.isym->name, &e->symtree);
4000	sym = e->symtree->n.sym;
4001	sym->result = sym;
4002	sym->attr.flavor = FL_PROCEDURE;
4003	sym->attr.function = 1;
4004	sym->attr.elemental = 1;
4005	sym->attr.pure = 1;
4006	sym->attr.referenced = 1;
4007	gfc_intrinsic_symbol (sym);
4008	gfc_commit_symbol (sym);
4009	}
4010
4011	args->name = e->value.function.isym->formal->name;
4012	if (e->value.function.isym->formal->next)
4013	args->next->name = e->value.function.isym->formal->next->name;
4014
4015	return e;
4016	}
4017
4018	/* Recursively append candidate UOP to CANDIDATES. Store the number of
4019	candidates in CANDIDATES_LEN. */
4020	static void
4021	lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
4022	char **&candidates,
4023	size_t &candidates_len)
4024	{
4025	gfc_symtree *p;
4026
4027	if (uop == NULL)
4028	return;
4029
4030	/* Not sure how to properly filter here. Use all for a start.
4031	n.uop.op is NULL for empty interface operators (is that legal?) disregard
4032	these as i suppose they don't make terribly sense. */
4033
4034	if (uop->n.uop->op != NULL)
4035	vec_push (optr&: candidates, osz&: candidates_len, elt: uop->name);
4036
4037	p = uop->left;
4038	if (p)
4039	lookup_uop_fuzzy_find_candidates (uop: p, candidates, candidates_len);
4040
4041	p = uop->right;
4042	if (p)
4043	lookup_uop_fuzzy_find_candidates (uop: p, candidates, candidates_len);
4044	}
4045
4046	/* Lookup user-operator OP fuzzily, taking names in UOP into account. */
4047
4048	static const char*
4049	lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
4050	{
4051	char **candidates = NULL;
4052	size_t candidates_len = 0;
4053	lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
4054	return gfc_closest_fuzzy_match (op, candidates);
4055	}
4056
4057
4058	/* Callback finding an impure function as an operand to an .and. or
4059	.or. expression. Remember the last function warned about to
4060	avoid double warnings when recursing. */
4061
4062	static int
4063	impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
4064	void *data)
4065	{
4066	gfc_expr *f = *e;
4067	const char *name;
4068	static gfc_expr *last = NULL;
4069	bool *found = (bool *) data;
4070
4071	if (f->expr_type == EXPR_FUNCTION)
4072	{
4073	*found = 1;
4074	if (f != last && !gfc_pure_function (e: f, name: &name)
4075	&& !gfc_implicit_pure_function (e: f))
4076	{
4077	if (name)
4078	gfc_warning (opt: OPT_Wfunction_elimination,
4079	"Impure function %qs at %L might not be evaluated",
4080	name, &f->where);
4081	else
4082	gfc_warning (opt: OPT_Wfunction_elimination,
4083	"Impure function at %L might not be evaluated",
4084	&f->where);
4085	}
4086	last = f;
4087	}
4088
4089	return 0;
4090	}
4091
4092	/* Return true if TYPE is character based, false otherwise. */
4093
4094	static int
4095	is_character_based (bt type)
4096	{
4097	return type == BT_CHARACTER || type == BT_HOLLERITH;
4098	}
4099
4100
4101	/* If expression is a hollerith, convert it to character and issue a warning
4102	for the conversion. */
4103
4104	static void
4105	convert_hollerith_to_character (gfc_expr *e)
4106	{
4107	if (e->ts.type == BT_HOLLERITH)
4108	{
4109	gfc_typespec t;
4110	gfc_clear_ts (&t);
4111	t.type = BT_CHARACTER;
4112	t.kind = e->ts.kind;
4113	gfc_convert_type_warn (e, &t, 2, 1);
4114	}
4115	}
4116
4117	/* Convert to numeric and issue a warning for the conversion. */
4118
4119	static void
4120	convert_to_numeric (gfc_expr *a, gfc_expr *b)
4121	{
4122	gfc_typespec t;
4123	gfc_clear_ts (&t);
4124	t.type = b->ts.type;
4125	t.kind = b->ts.kind;
4126	gfc_convert_type_warn (a, &t, 2, 1);
4127	}
4128
4129	/* Resolve an operator expression node. This can involve replacing the
4130	operation with a user defined function call. */
4131
4132	static bool
4133	resolve_operator (gfc_expr *e)
4134	{
4135	gfc_expr *op1, *op2;
4136	/* One error uses 3 names; additional space for wording (also via gettext). */
4137	char msg[3*GFC_MAX_SYMBOL_LEN + 1 + 50];
4138	bool dual_locus_error;
4139	bool t = true;
4140
4141	/* Reduce stacked parentheses to single pair */
4142	while (e->expr_type == EXPR_OP
4143	&& e->value.op.op == INTRINSIC_PARENTHESES
4144	&& e->value.op.op1->expr_type == EXPR_OP
4145	&& e->value.op.op1->value.op.op == INTRINSIC_PARENTHESES)
4146	{
4147	gfc_expr *tmp = gfc_copy_expr (e->value.op.op1);
4148	gfc_replace_expr (e, tmp);
4149	}
4150
4151	/* Resolve all subnodes-- give them types. */
4152
4153	switch (e->value.op.op)
4154	{
4155	default:
4156	if (!gfc_resolve_expr (e->value.op.op2))
4157	t = false;
4158
4159	/* Fall through. */
4160
4161	case INTRINSIC_NOT:
4162	case INTRINSIC_UPLUS:
4163	case INTRINSIC_UMINUS:
4164	case INTRINSIC_PARENTHESES:
4165	if (!gfc_resolve_expr (e->value.op.op1))
4166	return false;
4167	if (e->value.op.op1
4168	&& e->value.op.op1->ts.type == BT_BOZ && !e->value.op.op2)
4169	{
4170	gfc_error ("BOZ literal constant at %L cannot be an operand of "
4171	"unary operator %qs", &e->value.op.op1->where,
4172	gfc_op2string (e->value.op.op));
4173	return false;
4174	}
4175	break;
4176	}
4177
4178	/* Typecheck the new node. */
4179
4180	op1 = e->value.op.op1;
4181	op2 = e->value.op.op2;
4182	if (op1 == NULL && op2 == NULL)
4183	return false;
4184	/* Error out if op2 did not resolve. We already diagnosed op1. */
4185	if (t == false)
4186	return false;
4187
4188	dual_locus_error = false;
4189
4190	/* op1 and op2 cannot both be BOZ. */
4191	if (op1 && op1->ts.type == BT_BOZ
4192	&& op2 && op2->ts.type == BT_BOZ)
4193	{
4194	gfc_error ("Operands at %L and %L cannot appear as operands of "
4195	"binary operator %qs", &op1->where, &op2->where,
4196	gfc_op2string (e->value.op.op));
4197	return false;
4198	}
4199
4200	if ((op1 && op1->expr_type == EXPR_NULL)
4201	|| (op2 && op2->expr_type == EXPR_NULL))
4202	{
4203	snprintf (s: msg, maxlen: sizeof (msg),
4204	_("Invalid context for NULL() pointer at %%L"));
4205	goto bad_op;
4206	}
4207
4208	switch (e->value.op.op)
4209	{
4210	case INTRINSIC_UPLUS:
4211	case INTRINSIC_UMINUS:
4212	if (op1->ts.type == BT_INTEGER
4213	|| op1->ts.type == BT_REAL
4214	|| op1->ts.type == BT_COMPLEX)
4215	{
4216	e->ts = op1->ts;
4217	break;
4218	}
4219
4220	snprintf (s: msg, maxlen: sizeof (msg),
4221	_("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
4222	gfc_op2string (e->value.op.op), gfc_typename (e));
4223	goto bad_op;
4224
4225	case INTRINSIC_PLUS:
4226	case INTRINSIC_MINUS:
4227	case INTRINSIC_TIMES:
4228	case INTRINSIC_DIVIDE:
4229	case INTRINSIC_POWER:
4230	if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4231	{
4232	/* Do not perform conversions if operands are not conformable as
4233	required for the binary intrinsic operators (F2018:10.1.5).
4234	Defer to a possibly overloading user-defined operator. */
4235	if (!gfc_op_rank_conformable (op1, op2))
4236	{
4237	dual_locus_error = true;
4238	snprintf (s: msg, maxlen: sizeof (msg),
4239	_("Inconsistent ranks for operator at %%L and %%L"));
4240	goto bad_op;
4241	}
4242
4243	gfc_type_convert_binary (e, 1);
4244	break;
4245	}
4246
4247	if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED)
4248	snprintf (s: msg, maxlen: sizeof (msg),
4249	_("Unexpected derived-type entities in binary intrinsic "
4250	"numeric operator %%<%s%%> at %%L"),
4251	gfc_op2string (e->value.op.op));
4252	else
4253	snprintf (s: msg, maxlen: sizeof(msg),
4254	_("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
4255	gfc_op2string (e->value.op.op), gfc_typename (op1),
4256	gfc_typename (op2));
4257	goto bad_op;
4258
4259	case INTRINSIC_CONCAT:
4260	if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4261	&& op1->ts.kind == op2->ts.kind)
4262	{
4263	e->ts.type = BT_CHARACTER;
4264	e->ts.kind = op1->ts.kind;
4265	break;
4266	}
4267
4268	snprintf (s: msg, maxlen: sizeof (msg),
4269	_("Operands of string concatenation operator at %%L are %s/%s"),
4270	gfc_typename (op1), gfc_typename (op2));
4271	goto bad_op;
4272
4273	case INTRINSIC_AND:
4274	case INTRINSIC_OR:
4275	case INTRINSIC_EQV:
4276	case INTRINSIC_NEQV:
4277	if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4278	{
4279	e->ts.type = BT_LOGICAL;
4280	e->ts.kind = gfc_kind_max (op1, op2);
4281	if (op1->ts.kind < e->ts.kind)
4282	gfc_convert_type (op1, &e->ts, 2);
4283	else if (op2->ts.kind < e->ts.kind)
4284	gfc_convert_type (op2, &e->ts, 2);
4285
4286	if (flag_frontend_optimize &&
4287	(e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR))
4288	{
4289	/* Warn about short-circuiting
4290	with impure function as second operand. */
4291	bool op2_f = false;
4292	gfc_expr_walker (&op2, impure_function_callback, &op2_f);
4293	}
4294	break;
4295	}
4296
4297	/* Logical ops on integers become bitwise ops with -fdec. */
4298	else if (flag_dec
4299	&& (op1->ts.type == BT_INTEGER || op2->ts.type == BT_INTEGER))
4300	{
4301	e->ts.type = BT_INTEGER;
4302	e->ts.kind = gfc_kind_max (op1, op2);
4303	if (op1->ts.type != e->ts.type || op1->ts.kind != e->ts.kind)
4304	gfc_convert_type (op1, &e->ts, 1);
4305	if (op2->ts.type != e->ts.type || op2->ts.kind != e->ts.kind)
4306	gfc_convert_type (op2, &e->ts, 1);
4307	e = logical_to_bitwise (e);
4308	goto simplify_op;
4309	}
4310
4311	snprintf (s: msg, maxlen: sizeof (msg),
4312	_("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
4313	gfc_op2string (e->value.op.op), gfc_typename (op1),
4314	gfc_typename (op2));
4315
4316	goto bad_op;
4317
4318	case INTRINSIC_NOT:
4319	/* Logical ops on integers become bitwise ops with -fdec. */
4320	if (flag_dec && op1->ts.type == BT_INTEGER)
4321	{
4322	e->ts.type = BT_INTEGER;
4323	e->ts.kind = op1->ts.kind;
4324	e = logical_to_bitwise (e);
4325	goto simplify_op;
4326	}
4327
4328	if (op1->ts.type == BT_LOGICAL)
4329	{
4330	e->ts.type = BT_LOGICAL;
4331	e->ts.kind = op1->ts.kind;
4332	break;
4333	}
4334
4335	snprintf (s: msg, maxlen: sizeof (msg), _("Operand of .not. operator at %%L is %s"),
4336	gfc_typename (op1));
4337	goto bad_op;
4338
4339	case INTRINSIC_GT:
4340	case INTRINSIC_GT_OS:
4341	case INTRINSIC_GE:
4342	case INTRINSIC_GE_OS:
4343	case INTRINSIC_LT:
4344	case INTRINSIC_LT_OS:
4345	case INTRINSIC_LE:
4346	case INTRINSIC_LE_OS:
4347	if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
4348	{
4349	strcpy (dest: msg, _("COMPLEX quantities cannot be compared at %L"));
4350	goto bad_op;
4351	}
4352
4353	/* Fall through. */
4354
4355	case INTRINSIC_EQ:
4356	case INTRINSIC_EQ_OS:
4357	case INTRINSIC_NE:
4358	case INTRINSIC_NE_OS:
4359
4360	if (flag_dec
4361	&& is_character_based (type: op1->ts.type)
4362	&& is_character_based (type: op2->ts.type))
4363	{
4364	convert_hollerith_to_character (e: op1);
4365	convert_hollerith_to_character (e: op2);
4366	}
4367
4368	if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4369	&& op1->ts.kind == op2->ts.kind)
4370	{
4371	e->ts.type = BT_LOGICAL;
4372	e->ts.kind = gfc_default_logical_kind;
4373	break;
4374	}
4375
4376	/* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
4377	if (op1->ts.type == BT_BOZ)
4378	{
4379	if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear "
4380	"as an operand of a relational operator"),
4381	&op1->where))
4382	return false;
4383
4384	if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind))
4385	return false;
4386
4387	if (op2->ts.type == BT_REAL && !gfc_boz2real (op1, op2->ts.kind))
4388	return false;
4389	}
4390
4391	/* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
4392	if (op2->ts.type == BT_BOZ)
4393	{
4394	if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear"
4395	" as an operand of a relational operator"),
4396	&op2->where))
4397	return false;
4398
4399	if (op1->ts.type == BT_INTEGER && !gfc_boz2int (op2, op1->ts.kind))
4400	return false;
4401
4402	if (op1->ts.type == BT_REAL && !gfc_boz2real (op2, op1->ts.kind))
4403	return false;
4404	}
4405	if (flag_dec
4406	&& op1->ts.type == BT_HOLLERITH && gfc_numeric_ts (&op2->ts))
4407	convert_to_numeric (a: op1, b: op2);
4408
4409	if (flag_dec
4410	&& gfc_numeric_ts (&op1->ts) && op2->ts.type == BT_HOLLERITH)
4411	convert_to_numeric (a: op2, b: op1);
4412
4413	if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4414	{
4415	/* Do not perform conversions if operands are not conformable as
4416	required for the binary intrinsic operators (F2018:10.1.5).
4417	Defer to a possibly overloading user-defined operator. */
4418	if (!gfc_op_rank_conformable (op1, op2))
4419	{
4420	dual_locus_error = true;
4421	snprintf (s: msg, maxlen: sizeof (msg),
4422	_("Inconsistent ranks for operator at %%L and %%L"));
4423	goto bad_op;
4424	}
4425
4426	gfc_type_convert_binary (e, 1);
4427
4428	e->ts.type = BT_LOGICAL;
4429	e->ts.kind = gfc_default_logical_kind;
4430
4431	if (warn_compare_reals)
4432	{
4433	gfc_intrinsic_op op = e->value.op.op;
4434
4435	/* Type conversion has made sure that the types of op1 and op2
4436	agree, so it is only necessary to check the first one. */
4437	if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX)
4438	&& (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS
4439	|| op == INTRINSIC_NE || op == INTRINSIC_NE_OS))
4440	{
4441	const char *msg;
4442
4443	if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
4444	msg = G_("Equality comparison for %s at %L");
4445	else
4446	msg = G_("Inequality comparison for %s at %L");
4447
4448	gfc_warning (opt: OPT_Wcompare_reals, msg,
4449	gfc_typename (op1), &op1->where);
4450	}
4451	}
4452
4453	break;
4454	}
4455
4456	if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4457	snprintf (s: msg, maxlen: sizeof (msg),
4458	_("Logicals at %%L must be compared with %s instead of %s"),
4459	(e->value.op.op == INTRINSIC_EQ
4460	|| e->value.op.op == INTRINSIC_EQ_OS)
4461	? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
4462	else
4463	snprintf (s: msg, maxlen: sizeof (msg),
4464	_("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
4465	gfc_op2string (e->value.op.op), gfc_typename (op1),
4466	gfc_typename (op2));
4467
4468	goto bad_op;
4469
4470	case INTRINSIC_USER:
4471	if (e->value.op.uop->op == NULL)
4472	{
4473	const char *name = e->value.op.uop->name;
4474	const char *guessed;
4475	guessed = lookup_uop_fuzzy (op: name, uop: e->value.op.uop->ns->uop_root);
4476	if (guessed)
4477	snprintf (s: msg, maxlen: sizeof (msg),
4478	_("Unknown operator %%<%s%%> at %%L; did you mean "
4479	"%%<%s%%>?"), name, guessed);
4480	else
4481	snprintf (s: msg, maxlen: sizeof (msg), _("Unknown operator %%<%s%%> at %%L"),
4482	name);
4483	}
4484	else if (op2 == NULL)
4485	snprintf (s: msg, maxlen: sizeof (msg),
4486	_("Operand of user operator %%<%s%%> at %%L is %s"),
4487	e->value.op.uop->name, gfc_typename (op1));
4488	else
4489	{
4490	snprintf (s: msg, maxlen: sizeof (msg),
4491	_("Operands of user operator %%<%s%%> at %%L are %s/%s"),
4492	e->value.op.uop->name, gfc_typename (op1),
4493	gfc_typename (op2));
4494	e->value.op.uop->op->sym->attr.referenced = 1;
4495	}
4496
4497	goto bad_op;
4498
4499	case INTRINSIC_PARENTHESES:
4500	e->ts = op1->ts;
4501	if (e->ts.type == BT_CHARACTER)
4502	e->ts.u.cl = op1->ts.u.cl;
4503	break;
4504
4505	default:
4506	gfc_internal_error ("resolve_operator(): Bad intrinsic");
4507	}
4508
4509	/* Deal with arrayness of an operand through an operator. */
4510
4511	switch (e->value.op.op)
4512	{
4513	case INTRINSIC_PLUS:
4514	case INTRINSIC_MINUS:
4515	case INTRINSIC_TIMES:
4516	case INTRINSIC_DIVIDE:
4517	case INTRINSIC_POWER:
4518	case INTRINSIC_CONCAT:
4519	case INTRINSIC_AND:
4520	case INTRINSIC_OR:
4521	case INTRINSIC_EQV:
4522	case INTRINSIC_NEQV:
4523	case INTRINSIC_EQ:
4524	case INTRINSIC_EQ_OS:
4525	case INTRINSIC_NE:
4526	case INTRINSIC_NE_OS:
4527	case INTRINSIC_GT:
4528	case INTRINSIC_GT_OS:
4529	case INTRINSIC_GE:
4530	case INTRINSIC_GE_OS:
4531	case INTRINSIC_LT:
4532	case INTRINSIC_LT_OS:
4533	case INTRINSIC_LE:
4534	case INTRINSIC_LE_OS:
4535
4536	if (op1->rank == 0 && op2->rank == 0)
4537	e->rank = 0;
4538
4539	if (op1->rank == 0 && op2->rank != 0)
4540	{
4541	e->rank = op2->rank;
4542
4543	if (e->shape == NULL)
4544	e->shape = gfc_copy_shape (op2->shape, op2->rank);
4545	}
4546
4547	if (op1->rank != 0 && op2->rank == 0)
4548	{
4549	e->rank = op1->rank;
4550
4551	if (e->shape == NULL)
4552	e->shape = gfc_copy_shape (op1->shape, op1->rank);
4553	}
4554
4555	if (op1->rank != 0 && op2->rank != 0)
4556	{
4557	if (op1->rank == op2->rank)
4558	{
4559	e->rank = op1->rank;
4560	if (e->shape == NULL)
4561	{
4562	t = compare_shapes (op1, op2);
4563	if (!t)
4564	e->shape = NULL;
4565	else
4566	e->shape = gfc_copy_shape (op1->shape, op1->rank);
4567	}
4568	}
4569	else
4570	{
4571	/* Allow higher level expressions to work. */
4572	e->rank = 0;
4573
4574	/* Try user-defined operators, and otherwise throw an error. */
4575	dual_locus_error = true;
4576	snprintf (s: msg, maxlen: sizeof (msg),
4577	_("Inconsistent ranks for operator at %%L and %%L"));
4578	goto bad_op;
4579	}
4580	}
4581
4582	break;
4583
4584	case INTRINSIC_PARENTHESES:
4585	case INTRINSIC_NOT:
4586	case INTRINSIC_UPLUS:
4587	case INTRINSIC_UMINUS:
4588	/* Simply copy arrayness attribute */
4589	e->rank = op1->rank;
4590
4591	if (e->shape == NULL)
4592	e->shape = gfc_copy_shape (op1->shape, op1->rank);
4593
4594	break;
4595
4596	default:
4597	break;
4598	}
4599
4600	simplify_op:
4601
4602	/* Attempt to simplify the expression. */
4603	if (t)
4604	{
4605	t = gfc_simplify_expr (e, 0);
4606	/* Some calls do not succeed in simplification and return false
4607	even though there is no error; e.g. variable references to
4608	PARAMETER arrays. */
4609	if (!gfc_is_constant_expr (e))
4610	t = true;
4611	}
4612	return t;
4613
4614	bad_op:
4615
4616	{
4617	match m = gfc_extend_expr (e);
4618	if (m == MATCH_YES)
4619	return true;
4620	if (m == MATCH_ERROR)
4621	return false;
4622	}
4623
4624	if (dual_locus_error)
4625	gfc_error (msg, &op1->where, &op2->where);
4626	else
4627	gfc_error (msg, &e->where);
4628
4629	return false;
4630	}
4631
4632
4633	/************** Array resolution subroutines **************/
4634
4635	enum compare_result
4636	{ CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN };
4637
4638	/* Compare two integer expressions. */
4639
4640	static compare_result
4641	compare_bound (gfc_expr *a, gfc_expr *b)
4642	{
4643	int i;
4644
4645	if (a == NULL || a->expr_type != EXPR_CONSTANT
4646	|| b == NULL || b->expr_type != EXPR_CONSTANT)
4647	return CMP_UNKNOWN;
4648
4649	/* If either of the types isn't INTEGER, we must have
4650	raised an error earlier. */
4651
4652	if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
4653	return CMP_UNKNOWN;
4654
4655	i = mpz_cmp (a->value.integer, b->value.integer);
4656
4657	if (i < 0)
4658	return CMP_LT;
4659	if (i > 0)
4660	return CMP_GT;
4661	return CMP_EQ;
4662	}
4663
4664
4665	/* Compare an integer expression with an integer. */
4666
4667	static compare_result
4668	compare_bound_int (gfc_expr *a, int b)
4669	{
4670	int i;
4671
4672	if (a == NULL
4673	|| a->expr_type != EXPR_CONSTANT
4674	|| a->ts.type != BT_INTEGER)
4675	return CMP_UNKNOWN;
4676
4677	i = mpz_cmp_si (a->value.integer, b);
4678
4679	if (i < 0)
4680	return CMP_LT;
4681	if (i > 0)
4682	return CMP_GT;
4683	return CMP_EQ;
4684	}
4685
4686
4687	/* Compare an integer expression with a mpz_t. */
4688
4689	static compare_result
4690	compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4691	{
4692	int i;
4693
4694	if (a == NULL
4695	|| a->expr_type != EXPR_CONSTANT
4696	|| a->ts.type != BT_INTEGER)
4697	return CMP_UNKNOWN;
4698
4699	i = mpz_cmp (a->value.integer, b);
4700
4701	if (i < 0)
4702	return CMP_LT;
4703	if (i > 0)
4704	return CMP_GT;
4705	return CMP_EQ;
4706	}
4707
4708
4709	/* Compute the last value of a sequence given by a triplet.
4710	Return 0 if it wasn't able to compute the last value, or if the
4711	sequence if empty, and 1 otherwise. */
4712
4713	static int
4714	compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4715	gfc_expr *stride, mpz_t last)
4716	{
4717	mpz_t rem;
4718
4719	if (start == NULL || start->expr_type != EXPR_CONSTANT
4720	|| end == NULL || end->expr_type != EXPR_CONSTANT
4721	|| (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4722	return 0;
4723
4724	if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4725	|| (stride != NULL && stride->ts.type != BT_INTEGER))
4726	return 0;
4727
4728	if (stride == NULL || compare_bound_int (a: stride, b: 1) == CMP_EQ)
4729	{
4730	if (compare_bound (a: start, b: end) == CMP_GT)
4731	return 0;
4732	mpz_set (last, end->value.integer);
4733	return 1;
4734	}
4735
4736	if (compare_bound_int (a: stride, b: 0) == CMP_GT)
4737	{
4738	/* Stride is positive */
4739	if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4740	return 0;
4741	}
4742	else
4743	{
4744	/* Stride is negative */
4745	if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4746	return 0;
4747	}
4748
4749	mpz_init (rem);
4750	mpz_sub (rem, end->value.integer, start->value.integer);
4751	mpz_tdiv_r (rem, rem, stride->value.integer);
4752	mpz_sub (last, end->value.integer, rem);
4753	mpz_clear (rem);
4754
4755	return 1;
4756	}
4757
4758
4759	/* Compare a single dimension of an array reference to the array
4760	specification. */
4761
4762	static bool
4763	check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4764	{
4765	mpz_t last_value;
4766
4767	if (ar->dimen_type[i] == DIMEN_STAR)
4768	{
4769	gcc_assert (ar->stride[i] == NULL);
4770	/* This implies [*] as [*:] and [*:3] are not possible. */
4771	if (ar->start[i] == NULL)
4772	{
4773	gcc_assert (ar->end[i] == NULL);
4774	return true;
4775	}
4776	}
4777
4778	/* Given start, end and stride values, calculate the minimum and
4779	maximum referenced indexes. */
4780
4781	switch (ar->dimen_type[i])
4782	{
4783	case DIMEN_VECTOR:
4784	case DIMEN_THIS_IMAGE:
4785	break;
4786
4787	case DIMEN_STAR:
4788	case DIMEN_ELEMENT:
4789	if (compare_bound (a: ar->start[i], b: as->lower[i]) == CMP_LT)
4790	{
4791	if (i < as->rank)
4792	gfc_warning (opt: 0, "Array reference at %L is out of bounds "
4793	"(%ld < %ld) in dimension %d", &ar->c_where[i],
4794	mpz_get_si (ar->start[i]->value.integer),
4795	mpz_get_si (as->lower[i]->value.integer), i+1);
4796	else
4797	gfc_warning (opt: 0, "Array reference at %L is out of bounds "
4798	"(%ld < %ld) in codimension %d", &ar->c_where[i],
4799	mpz_get_si (ar->start[i]->value.integer),
4800	mpz_get_si (as->lower[i]->value.integer),
4801	i + 1 - as->rank);
4802	return true;
4803	}
4804	if (compare_bound (a: ar->start[i], b: as->upper[i]) == CMP_GT)
4805	{
4806	if (i < as->rank)
4807	gfc_warning (opt: 0, "Array reference at %L is out of bounds "
4808	"(%ld > %ld) in dimension %d", &ar->c_where[i],
4809	mpz_get_si (ar->start[i]->value.integer),
4810	mpz_get_si (as->upper[i]->value.integer), i+1);
4811	else
4812	gfc_warning (opt: 0, "Array reference at %L is out of bounds "
4813	"(%ld > %ld) in codimension %d", &ar->c_where[i],
4814	mpz_get_si (ar->start[i]->value.integer),
4815	mpz_get_si (as->upper[i]->value.integer),
4816	i + 1 - as->rank);
4817	return true;
4818	}
4819
4820	break;
4821
4822	case DIMEN_RANGE:
4823	{
4824	#define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4825	#define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4826
4827	compare_result comp_start_end = compare_bound (AR_START, AR_END);
4828	compare_result comp_stride_zero = compare_bound_int (a: ar->stride[i], b: 0);
4829
4830	/* Check for zero stride, which is not allowed. */
4831	if (comp_stride_zero == CMP_EQ)
4832	{
4833	gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4834	return false;
4835	}
4836
4837	/* if start == end || (stride > 0 && start < end)
4838	|| (stride < 0 && start > end),
4839	then the array section contains at least one element. In this
4840	case, there is an out-of-bounds access if
4841	(start < lower || start > upper). */
4842	if (comp_start_end == CMP_EQ
4843	|| ((comp_stride_zero == CMP_GT || ar->stride[i] == NULL)
4844	&& comp_start_end == CMP_LT)
4845	|| (comp_stride_zero == CMP_LT
4846	&& comp_start_end == CMP_GT))
4847	{
4848	if (compare_bound (AR_START, b: as->lower[i]) == CMP_LT)
4849	{
4850	gfc_warning (opt: 0, "Lower array reference at %L is out of bounds "
4851	"(%ld < %ld) in dimension %d", &ar->c_where[i],
4852	mpz_get_si (AR_START->value.integer),
4853	mpz_get_si (as->lower[i]->value.integer), i+1);
4854	return true;
4855	}
4856	if (compare_bound (AR_START, b: as->upper[i]) == CMP_GT)
4857	{
4858	gfc_warning (opt: 0, "Lower array reference at %L is out of bounds "
4859	"(%ld > %ld) in dimension %d", &ar->c_where[i],
4860	mpz_get_si (AR_START->value.integer),
4861	mpz_get_si (as->upper[i]->value.integer), i+1);
4862	return true;
4863	}
4864	}
4865
4866	/* If we can compute the highest index of the array section,
4867	then it also has to be between lower and upper. */
4868	mpz_init (last_value);
4869	if (compute_last_value_for_triplet (AR_START, AR_END, stride: ar->stride[i],
4870	last: last_value))
4871	{
4872	if (compare_bound_mpz_t (a: as->lower[i], b: last_value) == CMP_GT)
4873	{
4874	gfc_warning (opt: 0, "Upper array reference at %L is out of bounds "
4875	"(%ld < %ld) in dimension %d", &ar->c_where[i],
4876	mpz_get_si (last_value),
4877	mpz_get_si (as->lower[i]->value.integer), i+1);
4878	mpz_clear (last_value);
4879	return true;
4880	}
4881	if (compare_bound_mpz_t (a: as->upper[i], b: last_value) == CMP_LT)
4882	{
4883	gfc_warning (opt: 0, "Upper array reference at %L is out of bounds "
4884	"(%ld > %ld) in dimension %d", &ar->c_where[i],
4885	mpz_get_si (last_value),
4886	mpz_get_si (as->upper[i]->value.integer), i+1);
4887	mpz_clear (last_value);
4888	return true;
4889	}
4890	}
4891	mpz_clear (last_value);
4892
4893	#undef AR_START
4894	#undef AR_END
4895	}
4896	break;
4897
4898	default:
4899	gfc_internal_error ("check_dimension(): Bad array reference");
4900	}
4901
4902	return true;
4903	}
4904
4905
4906	/* Compare an array reference with an array specification. */
4907
4908	static bool
4909	compare_spec_to_ref (gfc_array_ref *ar)
4910	{
4911	gfc_array_spec *as;
4912	int i;
4913
4914	as = ar->as;
4915	i = as->rank - 1;
4916	/* TODO: Full array sections are only allowed as actual parameters. */
4917	if (as->type == AS_ASSUMED_SIZE
4918	&& (/*ar->type == AR_FULL
4919	||*/ (ar->type == AR_SECTION
4920	&& ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4921	{
4922	gfc_error ("Rightmost upper bound of assumed size array section "
4923	"not specified at %L", &ar->where);
4924	return false;
4925	}
4926
4927	if (ar->type == AR_FULL)
4928	return true;
4929
4930	if (as->rank != ar->dimen)
4931	{
4932	gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4933	&ar->where, ar->dimen, as->rank);
4934	return false;
4935	}
4936
4937	/* ar->codimen == 0 is a local array. */
4938	if (as->corank != ar->codimen && ar->codimen != 0)
4939	{
4940	gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4941	&ar->where, ar->codimen, as->corank);
4942	return false;
4943	}
4944
4945	for (i = 0; i < as->rank; i++)
4946	if (!check_dimension (i, ar, as))
4947	return false;
4948
4949	/* Local access has no coarray spec. */
4950	if (ar->codimen != 0)
4951	for (i = as->rank; i < as->rank + as->corank; i++)
4952	{
4953	if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
4954	&& ar->dimen_type[i] != DIMEN_THIS_IMAGE)
4955	{
4956	gfc_error ("Coindex of codimension %d must be a scalar at %L",
4957	i + 1 - as->rank, &ar->where);
4958	return false;
4959	}
4960	if (!check_dimension (i, ar, as))
4961	return false;
4962	}
4963
4964	return true;
4965	}
4966
4967
4968	/* Resolve one part of an array index. */
4969
4970	static bool
4971	gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4972	int force_index_integer_kind)
4973	{
4974	gfc_typespec ts;
4975
4976	if (index == NULL)
4977	return true;
4978
4979	if (!gfc_resolve_expr (index))
4980	return false;
4981
4982	if (check_scalar && index->rank != 0)
4983	{
4984	gfc_error ("Array index at %L must be scalar", &index->where);
4985	return false;
4986	}
4987
4988	if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4989	{
4990	gfc_error ("Array index at %L must be of INTEGER type, found %s",
4991	&index->where, gfc_basic_typename (index->ts.type));
4992	return false;
4993	}
4994
4995	if (index->ts.type == BT_REAL)
4996	if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L",
4997	&index->where))
4998	return false;
4999
5000	if ((index->ts.kind != gfc_index_integer_kind
5001	&& force_index_integer_kind)
5002	|| index->ts.type != BT_INTEGER)
5003	{
5004	gfc_clear_ts (&ts);
5005	ts.type = BT_INTEGER;
5006	ts.kind = gfc_index_integer_kind;
5007
5008	gfc_convert_type_warn (index, &ts, 2, 0);
5009	}
5010
5011	return true;
5012	}
5013
5014	/* Resolve one part of an array index. */
5015
5016	bool
5017	gfc_resolve_index (gfc_expr *index, int check_scalar)
5018	{
5019	return gfc_resolve_index_1 (index, check_scalar, force_index_integer_kind: 1);
5020	}
5021
5022	/* Resolve a dim argument to an intrinsic function. */
5023
5024	bool
5025	gfc_resolve_dim_arg (gfc_expr *dim)
5026	{
5027	if (dim == NULL)
5028	return true;
5029
5030	if (!gfc_resolve_expr (dim))
5031	return false;
5032
5033	if (dim->rank != 0)
5034	{
5035	gfc_error ("Argument dim at %L must be scalar", &dim->where);
5036	return false;
5037
5038	}
5039
5040	if (dim->ts.type != BT_INTEGER)
5041	{
5042	gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
5043	return false;
5044	}
5045
5046	if (dim->ts.kind != gfc_index_integer_kind)
5047	{
5048	gfc_typespec ts;
5049
5050	gfc_clear_ts (&ts);
5051	ts.type = BT_INTEGER;
5052	ts.kind = gfc_index_integer_kind;
5053
5054	gfc_convert_type_warn (dim, &ts, 2, 0);
5055	}
5056
5057	return true;
5058	}
5059
5060	/* Given an expression that contains array references, update those array
5061	references to point to the right array specifications. While this is
5062	filled in during matching, this information is difficult to save and load
5063	in a module, so we take care of it here.
5064
5065	The idea here is that the original array reference comes from the
5066	base symbol. We traverse the list of reference structures, setting
5067	the stored reference to references. Component references can
5068	provide an additional array specification. */
5069	static void
5070	resolve_assoc_var (gfc_symbol* sym, bool resolve_target);
5071
5072	static bool
5073	find_array_spec (gfc_expr *e)
5074	{
5075	gfc_array_spec *as;
5076	gfc_component *c;
5077	gfc_ref *ref;
5078	bool class_as = false;
5079
5080	if (e->symtree->n.sym->assoc)
5081	{
5082	if (e->symtree->n.sym->assoc->target)
5083	gfc_resolve_expr (e->symtree->n.sym->assoc->target);
5084	resolve_assoc_var (sym: e->symtree->n.sym, resolve_target: false);
5085	}
5086
5087	if (e->symtree->n.sym->ts.type == BT_CLASS)
5088	{
5089	as = CLASS_DATA (e->symtree->n.sym)->as;
5090	class_as = true;
5091	}
5092	else
5093	as = e->symtree->n.sym->as;
5094
5095	for (ref = e->ref; ref; ref = ref->next)
5096	switch (ref->type)
5097	{
5098	case REF_ARRAY:
5099	if (as == NULL)
5100	{
5101	locus loc = ref->u.ar.where.lb ? ref->u.ar.where : e->where;
5102	gfc_error ("Invalid array reference of a non-array entity at %L",
5103	&loc);
5104	return false;
5105	}
5106
5107	ref->u.ar.as = as;
5108	as = NULL;
5109	break;
5110
5111	case REF_COMPONENT:
5112	c = ref->u.c.component;
5113	if (c->attr.dimension)
5114	{
5115	if (as != NULL && !(class_as && as == c->as))
5116	gfc_internal_error ("find_array_spec(): unused as(1)");
5117	as = c->as;
5118	}
5119
5120	break;
5121
5122	case REF_SUBSTRING:
5123	case REF_INQUIRY:
5124	break;
5125	}
5126
5127	if (as != NULL)
5128	gfc_internal_error ("find_array_spec(): unused as(2)");
5129
5130	return true;
5131	}
5132
5133
5134	/* Resolve an array reference. */
5135
5136	static bool
5137	resolve_array_ref (gfc_array_ref *ar)
5138	{
5139	int i, check_scalar;
5140	gfc_expr *e;
5141
5142	for (i = 0; i < ar->dimen + ar->codimen; i++)
5143	{
5144	check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
5145
5146	/* Do not force gfc_index_integer_kind for the start. We can
5147	do fine with any integer kind. This avoids temporary arrays
5148	created for indexing with a vector. */
5149	if (!gfc_resolve_index_1 (index: ar->start[i], check_scalar, force_index_integer_kind: 0))
5150	return false;
5151	if (!gfc_resolve_index (index: ar->end[i], check_scalar))
5152	return false;
5153	if (!gfc_resolve_index (index: ar->stride[i], check_scalar))
5154	return false;
5155
5156	e = ar->start[i];
5157
5158	if (ar->dimen_type[i] == DIMEN_UNKNOWN)
5159	switch (e->rank)
5160	{
5161	case 0:
5162	ar->dimen_type[i] = DIMEN_ELEMENT;
5163	break;
5164
5165	case 1:
5166	ar->dimen_type[i] = DIMEN_VECTOR;
5167	if (e->expr_type == EXPR_VARIABLE
5168	&& e->symtree->n.sym->ts.type == BT_DERIVED)
5169	ar->start[i] = gfc_get_parentheses (e);
5170	break;
5171
5172	default:
5173	gfc_error ("Array index at %L is an array of rank %d",
5174	&ar->c_where[i], e->rank);
5175	return false;
5176	}
5177
5178	/* Fill in the upper bound, which may be lower than the
5179	specified one for something like a(2:10:5), which is
5180	identical to a(2:7:5). Only relevant for strides not equal
5181	to one. Don't try a division by zero. */
5182	if (ar->dimen_type[i] == DIMEN_RANGE
5183	&& ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
5184	&& mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
5185	&& mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
5186	{
5187	mpz_t size, end;
5188
5189	if (gfc_ref_dimen_size (ar, dimen: i, &size, &end))
5190	{
5191	if (ar->end[i] == NULL)
5192	{
5193	ar->end[i] =
5194	gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
5195	&ar->where);
5196	mpz_set (ar->end[i]->value.integer, end);
5197	}
5198	else if (ar->end[i]->ts.type == BT_INTEGER
5199	&& ar->end[i]->expr_type == EXPR_CONSTANT)
5200	{
5201	mpz_set (ar->end[i]->value.integer, end);
5202	}
5203	else
5204	gcc_unreachable ();
5205
5206	mpz_clear (size);
5207	mpz_clear (end);
5208	}
5209	}
5210	}
5211
5212	if (ar->type == AR_FULL)
5213	{
5214	if (ar->as->rank == 0)
5215	ar->type = AR_ELEMENT;
5216
5217	/* Make sure array is the same as array(:,:), this way
5218	we don't need to special case all the time. */
5219	ar->dimen = ar->as->rank;
5220	for (i = 0; i < ar->dimen; i++)
5221	{
5222	ar->dimen_type[i] = DIMEN_RANGE;
5223
5224	gcc_assert (ar->start[i] == NULL);
5225	gcc_assert (ar->end[i] == NULL);
5226	gcc_assert (ar->stride[i] == NULL);
5227	}
5228	}
5229
5230	/* If the reference type is unknown, figure out what kind it is. */
5231
5232	if (ar->type == AR_UNKNOWN)
5233	{
5234	ar->type = AR_ELEMENT;
5235	for (i = 0; i < ar->dimen; i++)
5236	if (ar->dimen_type[i] == DIMEN_RANGE
5237	|| ar->dimen_type[i] == DIMEN_VECTOR)
5238	{
5239	ar->type = AR_SECTION;
5240	break;
5241	}
5242	}
5243
5244	if (!ar->as->cray_pointee && !compare_spec_to_ref (ar))
5245	return false;
5246
5247	if (ar->as->corank && ar->codimen == 0)
5248	{
5249	int n;
5250	ar->codimen = ar->as->corank;
5251	for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
5252	ar->dimen_type[n] = DIMEN_THIS_IMAGE;
5253	}
5254
5255	return true;
5256	}
5257
5258
5259	bool
5260	gfc_resolve_substring (gfc_ref *ref, bool *equal_length)
5261	{
5262	int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
5263
5264	if (ref->u.ss.start != NULL)
5265	{
5266	if (!gfc_resolve_expr (ref->u.ss.start))
5267	return false;
5268
5269	if (ref->u.ss.start->ts.type != BT_INTEGER)
5270	{
5271	gfc_error ("Substring start index at %L must be of type INTEGER",
5272	&ref->u.ss.start->where);
5273	return false;
5274	}
5275
5276	if (ref->u.ss.start->rank != 0)
5277	{
5278	gfc_error ("Substring start index at %L must be scalar",
5279	&ref->u.ss.start->where);
5280	return false;
5281	}
5282
5283	if (compare_bound_int (a: ref->u.ss.start, b: 1) == CMP_LT
5284	&& (compare_bound (a: ref->u.ss.end, b: ref->u.ss.start) == CMP_EQ
5285	|| compare_bound (a: ref->u.ss.end, b: ref->u.ss.start) == CMP_GT))
5286	{
5287	gfc_error ("Substring start index at %L is less than one",
5288	&ref->u.ss.start->where);
5289	return false;
5290	}
5291	}
5292
5293	if (ref->u.ss.end != NULL)
5294	{
5295	if (!gfc_resolve_expr (ref->u.ss.end))
5296	return false;
5297
5298	if (ref->u.ss.end->ts.type != BT_INTEGER)
5299	{
5300	gfc_error ("Substring end index at %L must be of type INTEGER",
5301	&ref->u.ss.end->where);
5302	return false;
5303	}
5304
5305	if (ref->u.ss.end->rank != 0)
5306	{
5307	gfc_error ("Substring end index at %L must be scalar",
5308	&ref->u.ss.end->where);
5309	return false;
5310	}
5311
5312	if (ref->u.ss.length != NULL
5313	&& compare_bound (a: ref->u.ss.end, b: ref->u.ss.length->length) == CMP_GT
5314	&& (compare_bound (a: ref->u.ss.end, b: ref->u.ss.start) == CMP_EQ
5315	|| compare_bound (a: ref->u.ss.end, b: ref->u.ss.start) == CMP_GT))
5316	{
5317	gfc_error ("Substring end index at %L exceeds the string length",
5318	&ref->u.ss.start->where);
5319	return false;
5320	}
5321
5322	if (compare_bound_mpz_t (a: ref->u.ss.end,
5323	b: gfc_integer_kinds[k].huge) == CMP_GT
5324	&& (compare_bound (a: ref->u.ss.end, b: ref->u.ss.start) == CMP_EQ
5325	|| compare_bound (a: ref->u.ss.end, b: ref->u.ss.start) == CMP_GT))
5326	{
5327	gfc_error ("Substring end index at %L is too large",
5328	&ref->u.ss.end->where);
5329	return false;
5330	}
5331	/* If the substring has the same length as the original
5332	variable, the reference itself can be deleted. */
5333
5334	if (ref->u.ss.length != NULL
5335	&& compare_bound (a: ref->u.ss.end, b: ref->u.ss.length->length) == CMP_EQ
5336	&& compare_bound_int (a: ref->u.ss.start, b: 1) == CMP_EQ)
5337	*equal_length = true;
5338	}
5339
5340	return true;
5341	}
5342
5343
5344	/* This function supplies missing substring charlens. */
5345
5346	void
5347	gfc_resolve_substring_charlen (gfc_expr *e)
5348	{
5349	gfc_ref *char_ref;
5350	gfc_expr *start, *end;
5351	gfc_typespec *ts = NULL;
5352	mpz_t diff;
5353
5354	for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
5355	{
5356	if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY)
5357	break;
5358	if (char_ref->type == REF_COMPONENT)
5359	ts = &char_ref->u.c.component->ts;
5360	}
5361
5362	if (!char_ref || char_ref->type == REF_INQUIRY)
5363	return;
5364
5365	gcc_assert (char_ref->next == NULL);
5366
5367	if (e->ts.u.cl)
5368	{
5369	if (e->ts.u.cl->length)
5370	gfc_free_expr (e->ts.u.cl->length);
5371	else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy)
5372	return;
5373	}
5374
5375	if (!e->ts.u.cl)
5376	e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5377
5378	if (char_ref->u.ss.start)
5379	start = gfc_copy_expr (char_ref->u.ss.start);
5380	else
5381	start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
5382
5383	if (char_ref->u.ss.end)
5384	end = gfc_copy_expr (char_ref->u.ss.end);
5385	else if (e->expr_type == EXPR_VARIABLE)
5386	{
5387	if (!ts)
5388	ts = &e->symtree->n.sym->ts;
5389	end = gfc_copy_expr (ts->u.cl->length);
5390	}
5391	else
5392	end = NULL;
5393
5394	if (!start || !end)
5395	{
5396	gfc_free_expr (start);
5397	gfc_free_expr (end);
5398	return;
5399	}
5400
5401	/* Length = (end - start + 1).
5402	Check first whether it has a constant length. */
5403	if (gfc_dep_difference (end, start, &diff))
5404	{
5405	gfc_expr *len = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
5406	&e->where);
5407
5408	mpz_add_ui (len->value.integer, diff, 1);
5409	mpz_clear (diff);
5410	e->ts.u.cl->length = len;
5411	/* The check for length < 0 is handled below */
5412	}
5413	else
5414	{
5415	e->ts.u.cl->length = gfc_subtract (end, start);
5416	e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
5417	gfc_get_int_expr (gfc_charlen_int_kind,
5418	NULL, 1));
5419	}
5420
5421	/* F2008, 6.4.1: Both the starting point and the ending point shall
5422	be within the range 1, 2, ..., n unless the starting point exceeds
5423	the ending point, in which case the substring has length zero. */
5424
5425	if (mpz_cmp_si (e->ts.u.cl->length->value.integer, 0) < 0)
5426	mpz_set_si (e->ts.u.cl->length->value.integer, 0);
5427
5428	e->ts.u.cl->length->ts.type = BT_INTEGER;
5429	e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5430
5431	/* Make sure that the length is simplified. */
5432	gfc_simplify_expr (e->ts.u.cl->length, 1);
5433	gfc_resolve_expr (e->ts.u.cl->length);
5434	}
5435
5436
5437	/* Resolve subtype references. */
5438
5439	bool
5440	gfc_resolve_ref (gfc_expr *expr)
5441	{
5442	int current_part_dimension, n_components, seen_part_dimension, dim;
5443	gfc_ref *ref, **prev, *array_ref;
5444	bool equal_length;
5445
5446	for (ref = expr->ref; ref; ref = ref->next)
5447	if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
5448	{
5449	if (!find_array_spec (e: expr))
5450	return false;
5451	break;
5452	}
5453
5454	for (prev = &expr->ref; *prev != NULL;
5455	prev = *prev == NULL ? prev : &(*prev)->next)
5456	switch ((*prev)->type)
5457	{
5458	case REF_ARRAY:
5459	if (!resolve_array_ref (ar: &(*prev)->u.ar))
5460	return false;
5461	break;
5462
5463	case REF_COMPONENT:
5464	case REF_INQUIRY:
5465	break;
5466
5467	case REF_SUBSTRING:
5468	equal_length = false;
5469	if (!gfc_resolve_substring (ref: *prev, equal_length: &equal_length))
5470	return false;
5471
5472	if (expr->expr_type != EXPR_SUBSTRING && equal_length)
5473	{
5474	/* Remove the reference and move the charlen, if any. */
5475	ref = *prev;
5476	*prev = ref->next;
5477	ref->next = NULL;
5478	expr->ts.u.cl = ref->u.ss.length;
5479	ref->u.ss.length = NULL;
5480	gfc_free_ref_list (ref);
5481	}
5482	break;
5483	}
5484
5485	/* Check constraints on part references. */
5486
5487	current_part_dimension = 0;
5488	seen_part_dimension = 0;
5489	n_components = 0;
5490	array_ref = NULL;
5491
5492	for (ref = expr->ref; ref; ref = ref->next)
5493	{
5494	switch (ref->type)
5495	{
5496	case REF_ARRAY:
5497	array_ref = ref;
5498	switch (ref->u.ar.type)
5499	{
5500	case AR_FULL:
5501	/* Coarray scalar. */
5502	if (ref->u.ar.as->rank == 0)
5503	{
5504	current_part_dimension = 0;
5505	break;
5506	}
5507	/* Fall through. */
5508	case AR_SECTION:
5509	current_part_dimension = 1;
5510	break;
5511
5512	case AR_ELEMENT:
5513	array_ref = NULL;
5514	current_part_dimension = 0;
5515	break;
5516
5517	case AR_UNKNOWN:
5518	gfc_internal_error ("resolve_ref(): Bad array reference");
5519	}
5520
5521	break;
5522
5523	case REF_COMPONENT:
5524	if (current_part_dimension || seen_part_dimension)
5525	{
5526	/* F03:C614. */
5527	if (ref->u.c.component->attr.pointer
5528	|| ref->u.c.component->attr.proc_pointer
5529	|| (ref->u.c.component->ts.type == BT_CLASS
5530	&& CLASS_DATA (ref->u.c.component)->attr.pointer))
5531	{
5532	gfc_error ("Component to the right of a part reference "
5533	"with nonzero rank must not have the POINTER "
5534	"attribute at %L", &expr->where);
5535	return false;
5536	}
5537	else if (ref->u.c.component->attr.allocatable
5538	|| (ref->u.c.component->ts.type == BT_CLASS
5539	&& CLASS_DATA (ref->u.c.component)->attr.allocatable))
5540
5541	{
5542	gfc_error ("Component to the right of a part reference "
5543	"with nonzero rank must not have the ALLOCATABLE "
5544	"attribute at %L", &expr->where);
5545	return false;
5546	}
5547	}
5548
5549	n_components++;
5550	break;
5551
5552	case REF_SUBSTRING:
5553	break;
5554
5555	case REF_INQUIRY:
5556	/* Implement requirement in note 9.7 of F2018 that the result of the
5557	LEN inquiry be a scalar. */
5558	if (ref->u.i == INQUIRY_LEN && array_ref
5559	&& ((expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->length)
5560	|| expr->ts.type == BT_INTEGER))
5561	{
5562	array_ref->u.ar.type = AR_ELEMENT;
5563	expr->rank = 0;
5564	/* INQUIRY_LEN is not evaluated from the rest of the expr
5565	but directly from the string length. This means that setting
5566	the array indices to one does not matter but might trigger
5567	a runtime bounds error. Suppress the check. */
5568	expr->no_bounds_check = 1;
5569	for (dim = 0; dim < array_ref->u.ar.dimen; dim++)
5570	{
5571	array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT;
5572	if (array_ref->u.ar.start[dim])
5573	gfc_free_expr (array_ref->u.ar.start[dim]);
5574	array_ref->u.ar.start[dim]
5575	= gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
5576	if (array_ref->u.ar.end[dim])
5577	gfc_free_expr (array_ref->u.ar.end[dim]);
5578	if (array_ref->u.ar.stride[dim])
5579	gfc_free_expr (array_ref->u.ar.stride[dim]);
5580	}
5581	}
5582	break;
5583	}
5584
5585	if (((ref->type == REF_COMPONENT && n_components > 1)
5586	|| ref->next == NULL)
5587	&& current_part_dimension
5588	&& seen_part_dimension)
5589	{
5590	gfc_error ("Two or more part references with nonzero rank must "
5591	"not be specified at %L", &expr->where);
5592	return false;
5593	}
5594
5595	if (ref->type == REF_COMPONENT)
5596	{
5597	if (current_part_dimension)
5598	seen_part_dimension = 1;
5599
5600	/* reset to make sure */
5601	current_part_dimension = 0;
5602	}
5603	}
5604
5605	return true;
5606	}
5607
5608
5609	/* Given an expression, determine its shape. This is easier than it sounds.
5610	Leaves the shape array NULL if it is not possible to determine the shape. */
5611
5612	static void
5613	expression_shape (gfc_expr *e)
5614	{
5615	mpz_t array[GFC_MAX_DIMENSIONS];
5616	int i;
5617
5618	if (e->rank <= 0 || e->shape != NULL)
5619	return;
5620
5621	for (i = 0; i < e->rank; i++)
5622	if (!gfc_array_dimen_size (e, i, &array[i]))
5623	goto fail;
5624
5625	e->shape = gfc_get_shape (e->rank);
5626
5627	memcpy (dest: e->shape, src: array, n: e->rank * sizeof (mpz_t));
5628
5629	return;
5630
5631	fail:
5632	for (i--; i >= 0; i--)
5633	mpz_clear (array[i]);
5634	}
5635
5636
5637	/* Given a variable expression node, compute the rank of the expression by
5638	examining the base symbol and any reference structures it may have. */
5639
5640	void
5641	gfc_expression_rank (gfc_expr *e)
5642	{
5643	gfc_ref *ref;
5644	int i, rank;
5645
5646	/* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5647	could lead to serious confusion... */
5648	gcc_assert (e->expr_type != EXPR_COMPCALL);
5649
5650	if (e->ref == NULL)
5651	{
5652	if (e->expr_type == EXPR_ARRAY)
5653	goto done;
5654	/* Constructors can have a rank different from one via RESHAPE(). */
5655
5656	e->rank = ((e->symtree == NULL || e->symtree->n.sym->as == NULL)
5657	? 0 : e->symtree->n.sym->as->rank);
5658	goto done;
5659	}
5660
5661	rank = 0;
5662
5663	for (ref = e->ref; ref; ref = ref->next)
5664	{
5665	if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
5666	&& ref->u.c.component->attr.function && !ref->next)
5667	rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
5668
5669	if (ref->type != REF_ARRAY)
5670	continue;
5671
5672	if (ref->u.ar.type == AR_FULL)
5673	{
5674	rank = ref->u.ar.as->rank;
5675	break;
5676	}
5677
5678	if (ref->u.ar.type == AR_SECTION)
5679	{
5680	/* Figure out the rank of the section. */
5681	if (rank != 0)
5682	gfc_internal_error ("gfc_expression_rank(): Two array specs");
5683
5684	for (i = 0; i < ref->u.ar.dimen; i++)
5685	if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5686	|| ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5687	rank++;
5688
5689	break;
5690	}
5691	}
5692
5693	e->rank = rank;
5694
5695	done:
5696	expression_shape (e);
5697	}
5698
5699
5700	/* Given two expressions, check that their rank is conformable, i.e. either
5701	both have the same rank or at least one is a scalar. */
5702
5703	bool
5704	gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2)
5705	{
5706	if (op1->expr_type == EXPR_VARIABLE)
5707	gfc_expression_rank (e: op1);
5708	if (op2->expr_type == EXPR_VARIABLE)
5709	gfc_expression_rank (e: op2);
5710
5711	return (op1->rank == 0 || op2->rank == 0 || op1->rank == op2->rank);
5712	}
5713
5714
5715	static void
5716	add_caf_get_intrinsic (gfc_expr *e)
5717	{
5718	gfc_expr *wrapper, *tmp_expr;
5719	gfc_ref *ref;
5720	int n;
5721
5722	for (ref = e->ref; ref; ref = ref->next)
5723	if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5724	break;
5725	if (ref == NULL)
5726	return;
5727
5728	for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
5729	if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
5730	return;
5731
5732	tmp_expr = XCNEW (gfc_expr);
5733	*tmp_expr = *e;
5734	wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET,
5735	"caf_get", tmp_expr->where, 1, tmp_expr);
5736	wrapper->ts = e->ts;
5737	wrapper->rank = e->rank;
5738	if (e->rank)
5739	wrapper->shape = gfc_copy_shape (e->shape, e->rank);
5740	*e = *wrapper;
5741	free (ptr: wrapper);
5742	}
5743
5744
5745	static void
5746	remove_caf_get_intrinsic (gfc_expr *e)
5747	{
5748	gcc_assert (e->expr_type == EXPR_FUNCTION && e->value.function.isym
5749	&& e->value.function.isym->id == GFC_ISYM_CAF_GET);
5750	gfc_expr *e2 = e->value.function.actual->expr;
5751	e->value.function.actual->expr = NULL;
5752	gfc_free_actual_arglist (e->value.function.actual);
5753	gfc_free_shape (shape: &e->shape, rank: e->rank);
5754	*e = *e2;
5755	free (ptr: e2);
5756	}
5757
5758
5759	/* Resolve a variable expression. */
5760
5761	static bool
5762	resolve_variable (gfc_expr *e)
5763	{
5764	gfc_symbol *sym;
5765	bool t;
5766
5767	t = true;
5768
5769	if (e->symtree == NULL)
5770	return false;
5771	sym = e->symtree->n.sym;
5772
5773	/* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5774	as ts.type is set to BT_ASSUMED in resolve_symbol. */
5775	if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
5776	{
5777	if (!actual_arg || inquiry_argument)
5778	{
5779	gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5780	"be used as actual argument", sym->name, &e->where);
5781	return false;
5782	}
5783	}
5784	/* TS 29113, 407b. */
5785	else if (e->ts.type == BT_ASSUMED)
5786	{
5787	if (!actual_arg)
5788	{
5789	gfc_error ("Assumed-type variable %s at %L may only be used "
5790	"as actual argument", sym->name, &e->where);
5791	return false;
5792	}
5793	else if (inquiry_argument && !first_actual_arg)
5794	{
5795	/* FIXME: It doesn't work reliably as inquiry_argument is not set
5796	for all inquiry functions in resolve_function; the reason is
5797	that the function-name resolution happens too late in that
5798	function. */
5799	gfc_error ("Assumed-type variable %s at %L as actual argument to "
5800	"an inquiry function shall be the first argument",
5801	sym->name, &e->where);
5802	return false;
5803	}
5804	}
5805	/* TS 29113, C535b. */
5806	else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
5807	&& sym->ts.u.derived && CLASS_DATA (sym)
5808	&& CLASS_DATA (sym)->as
5809	&& CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
5810	|| (sym->ts.type != BT_CLASS && sym->as
5811	&& sym->as->type == AS_ASSUMED_RANK))
5812	&& !sym->attr.select_rank_temporary)
5813	{
5814	if (!actual_arg
5815	&& !(cs_base && cs_base->current
5816	&& cs_base->current->op == EXEC_SELECT_RANK))
5817	{
5818	gfc_error ("Assumed-rank variable %s at %L may only be used as "
5819	"actual argument", sym->name, &e->where);
5820	return false;
5821	}
5822	else if (inquiry_argument && !first_actual_arg)
5823	{
5824	/* FIXME: It doesn't work reliably as inquiry_argument is not set
5825	for all inquiry functions in resolve_function; the reason is
5826	that the function-name resolution happens too late in that
5827	function. */
5828	gfc_error ("Assumed-rank variable %s at %L as actual argument "
5829	"to an inquiry function shall be the first argument",
5830	sym->name, &e->where);
5831	return false;
5832	}
5833	}
5834
5835	if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref
5836	&& !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
5837	&& e->ref->next == NULL))
5838	{
5839	gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5840	"a subobject reference", sym->name, &e->ref->u.ar.where);
5841	return false;
5842	}
5843	/* TS 29113, 407b. */
5844	else if (e->ts.type == BT_ASSUMED && e->ref
5845	&& !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
5846	&& e->ref->next == NULL))
5847	{
5848	gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5849	"reference", sym->name, &e->ref->u.ar.where);
5850	return false;
5851	}
5852
5853	/* TS 29113, C535b. */
5854	if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
5855	&& sym->ts.u.derived && CLASS_DATA (sym)
5856	&& CLASS_DATA (sym)->as
5857	&& CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
5858	|| (sym->ts.type != BT_CLASS && sym->as
5859	&& sym->as->type == AS_ASSUMED_RANK))
5860	&& e->ref
5861	&& !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
5862	&& e->ref->next == NULL))
5863	{
5864	gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5865	"reference", sym->name, &e->ref->u.ar.where);
5866	return false;
5867	}
5868
5869	/* For variables that are used in an associate (target => object) where
5870	the object's basetype is array valued while the target is scalar,
5871	the ts' type of the component refs is still array valued, which
5872	can't be translated that way. */
5873	if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS
5874	&& sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS
5875	&& sym->assoc->target->ts.u.derived
5876	&& CLASS_DATA (sym->assoc->target)
5877	&& CLASS_DATA (sym->assoc->target)->as)
5878	{
5879	gfc_ref *ref = e->ref;
5880	while (ref)
5881	{
5882	switch (ref->type)
5883	{
5884	case REF_COMPONENT:
5885	ref->u.c.sym = sym->ts.u.derived;
5886	/* Stop the loop. */
5887	ref = NULL;
5888	break;
5889	default:
5890	ref = ref->next;
5891	break;
5892	}
5893	}
5894	}
5895
5896	/* If this is an associate-name, it may be parsed with an array reference
5897	in error even though the target is scalar. Fail directly in this case.
5898	TODO Understand why class scalar expressions must be excluded. */
5899	if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
5900	{
5901	if (sym->ts.type == BT_CLASS)
5902	gfc_fix_class_refs (e);
5903	if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
5904	{
5905	/* Unambiguously scalar! */
5906	if (sym->assoc->target
5907	&& (sym->assoc->target->expr_type == EXPR_CONSTANT
5908	|| sym->assoc->target->expr_type == EXPR_STRUCTURE))
5909	gfc_error ("Scalar variable %qs has an array reference at %L",
5910	sym->name, &e->where);
5911	return false;
5912	}
5913	else if (sym->attr.dimension && (!e->ref || e->ref->type != REF_ARRAY))
5914	{
5915	/* This can happen because the parser did not detect that the
5916	associate name is an array and the expression had no array
5917	part_ref. */
5918	gfc_ref *ref = gfc_get_ref ();
5919	ref->type = REF_ARRAY;
5920	ref->u.ar.type = AR_FULL;
5921	if (sym->as)
5922	{
5923	ref->u.ar.as = sym->as;
5924	ref->u.ar.dimen = sym->as->rank;
5925	}
5926	ref->next = e->ref;
5927	e->ref = ref;
5928
5929	}
5930	}
5931
5932	if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
5933	sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
5934
5935	/* On the other hand, the parser may not have known this is an array;
5936	in this case, we have to add a FULL reference. */
5937	if (sym->assoc && sym->attr.dimension && !e->ref)
5938	{
5939	e->ref = gfc_get_ref ();
5940	e->ref->type = REF_ARRAY;
5941	e->ref->u.ar.type = AR_FULL;
5942	e->ref->u.ar.dimen = 0;
5943	}
5944
5945	/* Like above, but for class types, where the checking whether an array
5946	ref is present is more complicated. Furthermore make sure not to add
5947	the full array ref to _vptr or _len refs. */
5948	if (sym->assoc && sym->ts.type == BT_CLASS && sym->ts.u.derived
5949	&& CLASS_DATA (sym)
5950	&& CLASS_DATA (sym)->attr.dimension
5951	&& (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype))
5952	{
5953	gfc_ref *ref, *newref;
5954
5955	newref = gfc_get_ref ();
5956	newref->type = REF_ARRAY;
5957	newref->u.ar.type = AR_FULL;
5958	newref->u.ar.dimen = 0;
5959	/* Because this is an associate var and the first ref either is a ref to
5960	the _data component or not, no traversal of the ref chain is
5961	needed. The array ref needs to be inserted after the _data ref,
5962	or when that is not present, which may happened for polymorphic
5963	types, then at the first position. */
5964	ref = e->ref;
5965	if (!ref)
5966	e->ref = newref;
5967	else if (ref->type == REF_COMPONENT
5968	&& strcmp (s1: "_data", s2: ref->u.c.component->name) == 0)
5969	{
5970	if (!ref->next || ref->next->type != REF_ARRAY)
5971	{
5972	newref->next = ref->next;
5973	ref->next = newref;
5974	}
5975	else
5976	/* Array ref present already. */
5977	gfc_free_ref_list (newref);
5978	}
5979	else if (ref->type == REF_ARRAY)
5980	/* Array ref present already. */
5981	gfc_free_ref_list (newref);
5982	else
5983	{
5984	newref->next = ref;
5985	e->ref = newref;
5986	}
5987	}
5988
5989	if (e->ref && !gfc_resolve_ref (expr: e))
5990	return false;
5991
5992	if (sym->attr.flavor == FL_PROCEDURE
5993	&& (!sym->attr.function
5994	|| (sym->attr.function && sym->result
5995	&& sym->result->attr.proc_pointer
5996	&& !sym->result->attr.function)))
5997	{
5998	e->ts.type = BT_PROCEDURE;
5999	goto resolve_procedure;
6000	}
6001
6002	if (sym->ts.type != BT_UNKNOWN)
6003	gfc_variable_attr (e, &e->ts);
6004	else if (sym->attr.flavor == FL_PROCEDURE
6005	&& sym->attr.function && sym->result
6006	&& sym->result->ts.type != BT_UNKNOWN
6007	&& sym->result->attr.proc_pointer)
6008	e->ts = sym->result->ts;
6009	else
6010	{
6011	/* Must be a simple variable reference. */
6012	if (!gfc_set_default_type (sym, 1, sym->ns))
6013	return false;
6014	e->ts = sym->ts;
6015	}
6016
6017	if (check_assumed_size_reference (sym, e))
6018	return false;
6019
6020	/* Deal with forward references to entries during gfc_resolve_code, to
6021	satisfy, at least partially, 12.5.2.5. */
6022	if (gfc_current_ns->entries
6023	&& current_entry_id == sym->entry_id
6024	&& cs_base
6025	&& cs_base->current
6026	&& cs_base->current->op != EXEC_ENTRY)
6027	{
6028	gfc_entry_list *entry;
6029	gfc_formal_arglist *formal;
6030	int n;
6031	bool seen, saved_specification_expr;
6032
6033	/* If the symbol is a dummy... */
6034	if (sym->attr.dummy && sym->ns == gfc_current_ns)
6035	{
6036	entry = gfc_current_ns->entries;
6037	seen = false;
6038
6039	/* ...test if the symbol is a parameter of previous entries. */
6040	for (; entry && entry->id <= current_entry_id; entry = entry->next)
6041	for (formal = entry->sym->formal; formal; formal = formal->next)
6042	{
6043	if (formal->sym && sym->name == formal->sym->name)
6044	{
6045	seen = true;
6046	break;
6047	}
6048	}
6049
6050	/* If it has not been seen as a dummy, this is an error. */
6051	if (!seen)
6052	{
6053	if (specification_expr)
6054	gfc_error ("Variable %qs, used in a specification expression"
6055	", is referenced at %L before the ENTRY statement "
6056	"in which it is a parameter",
6057	sym->name, &cs_base->current->loc);
6058	else
6059	gfc_error ("Variable %qs is used at %L before the ENTRY "
6060	"statement in which it is a parameter",
6061	sym->name, &cs_base->current->loc);
6062	t = false;
6063	}
6064	}
6065
6066	/* Now do the same check on the specification expressions. */
6067	saved_specification_expr = specification_expr;
6068	specification_expr = true;
6069	if (sym->ts.type == BT_CHARACTER
6070	&& !gfc_resolve_expr (sym->ts.u.cl->length))
6071	t = false;
6072
6073	if (sym->as)
6074	for (n = 0; n < sym->as->rank; n++)
6075	{
6076	if (!gfc_resolve_expr (sym->as->lower[n]))
6077	t = false;
6078	if (!gfc_resolve_expr (sym->as->upper[n]))
6079	t = false;
6080	}
6081	specification_expr = saved_specification_expr;
6082
6083	if (t)
6084	/* Update the symbol's entry level. */
6085	sym->entry_id = current_entry_id + 1;
6086	}
6087
6088	/* If a symbol has been host_associated mark it. This is used latter,
6089	to identify if aliasing is possible via host association. */
6090	if (sym->attr.flavor == FL_VARIABLE
6091	&& gfc_current_ns->parent
6092	&& (gfc_current_ns->parent == sym->ns
6093	|| (gfc_current_ns->parent->parent
6094	&& gfc_current_ns->parent->parent == sym->ns)))
6095	sym->attr.host_assoc = 1;
6096
6097	if (gfc_current_ns->proc_name
6098	&& sym->attr.dimension
6099	&& (sym->ns != gfc_current_ns
6100	|| sym->attr.use_assoc
6101	|| sym->attr.in_common))
6102	gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
6103
6104	resolve_procedure:
6105	if (t && !resolve_procedure_expression (expr: e))
6106	t = false;
6107
6108	/* F2008, C617 and C1229. */
6109	if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
6110	&& gfc_is_coindexed (e))
6111	{
6112	gfc_ref *ref, *ref2 = NULL;
6113
6114	for (ref = e->ref; ref; ref = ref->next)
6115	{
6116	if (ref->type == REF_COMPONENT)
6117	ref2 = ref;
6118	if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
6119	break;
6120	}
6121
6122	for ( ; ref; ref = ref->next)
6123	if (ref->type == REF_COMPONENT)
6124	break;
6125
6126	/* Expression itself is not coindexed object. */
6127	if (ref && e->ts.type == BT_CLASS)
6128	{
6129	gfc_error ("Polymorphic subobject of coindexed object at %L",
6130	&e->where);
6131	t = false;
6132	}
6133
6134	/* Expression itself is coindexed object. */
6135	if (ref == NULL)
6136	{
6137	gfc_component *c;
6138	c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
6139	for ( ; c; c = c->next)
6140	if (c->attr.allocatable && c->ts.type == BT_CLASS)
6141	{
6142	gfc_error ("Coindexed object with polymorphic allocatable "
6143	"subcomponent at %L", &e->where);
6144	t = false;
6145	break;
6146	}
6147	}
6148	}
6149
6150	if (t)
6151	gfc_expression_rank (e);
6152
6153	if (t && flag_coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e))
6154	add_caf_get_intrinsic (e);
6155
6156	if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym != sym->result)
6157	gfc_warning (opt: OPT_Wdeprecated_declarations,
6158	"Using variable %qs at %L is deprecated",
6159	sym->name, &e->where);
6160	/* Simplify cases where access to a parameter array results in a
6161	single constant. Suppress errors since those will have been
6162	issued before, as warnings. */
6163	if (e->rank == 0 && sym->as && sym->attr.flavor == FL_PARAMETER)
6164	{
6165	gfc_push_suppress_errors ();
6166	gfc_simplify_expr (e, 1);
6167	gfc_pop_suppress_errors ();
6168	}
6169
6170	return t;
6171	}
6172
6173
6174	/* Checks to see that the correct symbol has been host associated.
6175	The only situations where this arises are:
6176	(i) That in which a twice contained function is parsed after
6177	the host association is made. On detecting this, change
6178	the symbol in the expression and convert the array reference
6179	into an actual arglist if the old symbol is a variable; or
6180	(ii) That in which an external function is typed but not declared
6181	explicitly to be external. Here, the old symbol is changed
6182	from a variable to an external function. */
6183	static bool
6184	check_host_association (gfc_expr *e)
6185	{
6186	gfc_symbol *sym, *old_sym;
6187	gfc_symtree *st;
6188	int n;
6189	gfc_ref *ref;
6190	gfc_actual_arglist *arg, *tail = NULL;
6191	bool retval = e->expr_type == EXPR_FUNCTION;
6192
6193	/* If the expression is the result of substitution in
6194	interface.cc(gfc_extend_expr) because there is no way in
6195	which the host association can be wrong. */
6196	if (e->symtree == NULL
6197	|| e->symtree->n.sym == NULL
6198	|| e->user_operator)
6199	return retval;
6200
6201	old_sym = e->symtree->n.sym;
6202
6203	if (gfc_current_ns->parent
6204	&& old_sym->ns != gfc_current_ns)
6205	{
6206	/* Use the 'USE' name so that renamed module symbols are
6207	correctly handled. */
6208	gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
6209
6210	if (sym && old_sym != sym
6211	&& sym->attr.flavor == FL_PROCEDURE
6212	&& sym->attr.contained)
6213	{
6214	/* Clear the shape, since it might not be valid. */
6215	gfc_free_shape (shape: &e->shape, rank: e->rank);
6216
6217	/* Give the expression the right symtree! */
6218	gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
6219	gcc_assert (st != NULL);
6220
6221	if (old_sym->attr.flavor == FL_PROCEDURE
6222	|| e->expr_type == EXPR_FUNCTION)
6223	{
6224	/* Original was function so point to the new symbol, since
6225	the actual argument list is already attached to the
6226	expression. */
6227	e->value.function.esym = NULL;
6228	e->symtree = st;
6229	}
6230	else
6231	{
6232	/* Original was variable so convert array references into
6233	an actual arglist. This does not need any checking now
6234	since resolve_function will take care of it. */
6235	e->value.function.actual = NULL;
6236	e->expr_type = EXPR_FUNCTION;
6237	e->symtree = st;
6238
6239	/* Ambiguity will not arise if the array reference is not
6240	the last reference. */
6241	for (ref = e->ref; ref; ref = ref->next)
6242	if (ref->type == REF_ARRAY && ref->next == NULL)
6243	break;
6244
6245	if ((ref == NULL || ref->type != REF_ARRAY)
6246	&& sym->attr.proc == PROC_INTERNAL)
6247	{
6248	gfc_error ("%qs at %L is host associated at %L into "
6249	"a contained procedure with an internal "
6250	"procedure of the same name", sym->name,
6251	&old_sym->declared_at, &e->where);
6252	return false;
6253	}
6254
6255	if (ref == NULL)
6256	return false;
6257
6258	gcc_assert (ref->type == REF_ARRAY);
6259
6260	/* Grab the start expressions from the array ref and
6261	copy them into actual arguments. */
6262	for (n = 0; n < ref->u.ar.dimen; n++)
6263	{
6264	arg = gfc_get_actual_arglist ();
6265	arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
6266	if (e->value.function.actual == NULL)
6267	tail = e->value.function.actual = arg;
6268	else
6269	{
6270	tail->next = arg;
6271	tail = arg;
6272	}
6273	}
6274
6275	/* Dump the reference list and set the rank. */
6276	gfc_free_ref_list (e->ref);
6277	e->ref = NULL;
6278	e->rank = sym->as ? sym->as->rank : 0;
6279	}
6280
6281	gfc_resolve_expr (e);
6282	sym->refs++;
6283	}
6284	/* This case corresponds to a call, from a block or a contained
6285	procedure, to an external function, which has not been declared
6286	as being external in the main program but has been typed. */
6287	else if (sym && old_sym != sym
6288	&& !e->ref
6289	&& sym->ts.type == BT_UNKNOWN
6290	&& old_sym->ts.type != BT_UNKNOWN
6291	&& sym->attr.flavor == FL_PROCEDURE
6292	&& old_sym->attr.flavor == FL_VARIABLE
6293	&& sym->ns->parent == old_sym->ns
6294	&& sym->ns->proc_name
6295	&& sym->ns->proc_name->attr.proc != PROC_MODULE
6296	&& (sym->ns->proc_name->attr.flavor == FL_LABEL
6297	|| sym->ns->proc_name->attr.flavor == FL_PROCEDURE))
6298	{
6299	old_sym->attr.flavor = FL_PROCEDURE;
6300	old_sym->attr.external = 1;
6301	old_sym->attr.function = 1;
6302	old_sym->result = old_sym;
6303	gfc_resolve_expr (e);
6304	}
6305	}
6306	/* This might have changed! */
6307	return e->expr_type == EXPR_FUNCTION;
6308	}
6309
6310
6311	static void
6312	gfc_resolve_character_operator (gfc_expr *e)
6313	{
6314	gfc_expr *op1 = e->value.op.op1;
6315	gfc_expr *op2 = e->value.op.op2;
6316	gfc_expr *e1 = NULL;
6317	gfc_expr *e2 = NULL;
6318
6319	gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
6320
6321	if (op1->ts.u.cl && op1->ts.u.cl->length)
6322	e1 = gfc_copy_expr (op1->ts.u.cl->length);
6323	else if (op1->expr_type == EXPR_CONSTANT)
6324	e1 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
6325	op1->value.character.length);
6326
6327	if (op2->ts.u.cl && op2->ts.u.cl->length)
6328	e2 = gfc_copy_expr (op2->ts.u.cl->length);
6329	else if (op2->expr_type == EXPR_CONSTANT)
6330	e2 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
6331	op2->value.character.length);
6332
6333	e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
6334
6335	if (!e1 || !e2)
6336	{
6337	gfc_free_expr (e1);
6338	gfc_free_expr (e2);
6339
6340	return;
6341	}
6342
6343	e->ts.u.cl->length = gfc_add (e1, e2);
6344	e->ts.u.cl->length->ts.type = BT_INTEGER;
6345	e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
6346	gfc_simplify_expr (e->ts.u.cl->length, 0);
6347	gfc_resolve_expr (e->ts.u.cl->length);
6348
6349	return;
6350	}
6351
6352
6353	/* Ensure that an character expression has a charlen and, if possible, a
6354	length expression. */
6355
6356	static void
6357	fixup_charlen (gfc_expr *e)
6358	{
6359	/* The cases fall through so that changes in expression type and the need
6360	for multiple fixes are picked up. In all circumstances, a charlen should
6361	be available for the middle end to hang a backend_decl on. */
6362	switch (e->expr_type)
6363	{
6364	case EXPR_OP:
6365	gfc_resolve_character_operator (e);
6366	/* FALLTHRU */
6367
6368	case EXPR_ARRAY:
6369	if (e->expr_type == EXPR_ARRAY)
6370	gfc_resolve_character_array_constructor (e);
6371	/* FALLTHRU */
6372
6373	case EXPR_SUBSTRING:
6374	if (!e->ts.u.cl && e->ref)
6375	gfc_resolve_substring_charlen (e);
6376	/* FALLTHRU */
6377
6378	default:
6379	if (!e->ts.u.cl)
6380	e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
6381
6382	break;
6383	}
6384	}
6385
6386
6387	/* Update an actual argument to include the passed-object for type-bound
6388	procedures at the right position. */
6389
6390	static gfc_actual_arglist*
6391	update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
6392	const char *name)
6393	{
6394	gcc_assert (argpos > 0);
6395
6396	if (argpos == 1)
6397	{
6398	gfc_actual_arglist* result;
6399
6400	result = gfc_get_actual_arglist ();
6401	result->expr = po;
6402	result->next = lst;
6403	if (name)
6404	result->name = name;
6405
6406	return result;
6407	}
6408
6409	if (lst)
6410	lst->next = update_arglist_pass (lst: lst->next, po, argpos: argpos - 1, name);
6411	else
6412	lst = update_arglist_pass (NULL, po, argpos: argpos - 1, name);
6413	return lst;
6414	}
6415
6416
6417	/* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
6418
6419	static gfc_expr*
6420	extract_compcall_passed_object (gfc_expr* e)
6421	{
6422	gfc_expr* po;
6423
6424	if (e->expr_type == EXPR_UNKNOWN)
6425	{
6426	gfc_error ("Error in typebound call at %L",
6427	&e->where);
6428	return NULL;
6429	}
6430
6431	gcc_assert (e->expr_type == EXPR_COMPCALL);
6432
6433	if (e->value.compcall.base_object)
6434	po = gfc_copy_expr (e->value.compcall.base_object);
6435	else
6436	{
6437	po = gfc_get_expr ();
6438	po->expr_type = EXPR_VARIABLE;
6439	po->symtree = e->symtree;
6440	po->ref = gfc_copy_ref (e->ref);
6441	po->where = e->where;
6442	}
6443
6444	if (!gfc_resolve_expr (po))
6445	return NULL;
6446
6447	return po;
6448	}
6449
6450
6451	/* Update the arglist of an EXPR_COMPCALL expression to include the
6452	passed-object. */
6453
6454	static bool
6455	update_compcall_arglist (gfc_expr* e)
6456	{
6457	gfc_expr* po;
6458	gfc_typebound_proc* tbp;
6459
6460	tbp = e->value.compcall.tbp;
6461
6462	if (tbp->error)
6463	return false;
6464
6465	po = extract_compcall_passed_object (e);
6466	if (!po)
6467	return false;
6468
6469	if (tbp->nopass || e->value.compcall.ignore_pass)
6470	{
6471	gfc_free_expr (po);
6472	return true;
6473	}
6474
6475	if (tbp->pass_arg_num <= 0)
6476	return false;
6477
6478	e->value.compcall.actual = update_arglist_pass (lst: e->value.compcall.actual, po,
6479	argpos: tbp->pass_arg_num,
6480	name: tbp->pass_arg);
6481
6482	return true;
6483	}
6484
6485
6486	/* Extract the passed object from a PPC call (a copy of it). */
6487
6488	static gfc_expr*
6489	extract_ppc_passed_object (gfc_expr *e)
6490	{
6491	gfc_expr *po;
6492	gfc_ref **ref;
6493
6494	po = gfc_get_expr ();
6495	po->expr_type = EXPR_VARIABLE;
6496	po->symtree = e->symtree;
6497	po->ref = gfc_copy_ref (e->ref);
6498	po->where = e->where;
6499
6500	/* Remove PPC reference. */
6501	ref = &po->ref;
6502	while ((*ref)->next)
6503	ref = &(*ref)->next;
6504	gfc_free_ref_list (*ref);
6505	*ref = NULL;
6506
6507	if (!gfc_resolve_expr (po))
6508	return NULL;
6509
6510	return po;
6511	}
6512
6513
6514	/* Update the actual arglist of a procedure pointer component to include the
6515	passed-object. */
6516
6517	static bool
6518	update_ppc_arglist (gfc_expr* e)
6519	{
6520	gfc_expr* po;
6521	gfc_component *ppc;
6522	gfc_typebound_proc* tb;
6523
6524	ppc = gfc_get_proc_ptr_comp (e);
6525	if (!ppc)
6526	return false;
6527
6528	tb = ppc->tb;
6529
6530	if (tb->error)
6531	return false;
6532	else if (tb->nopass)
6533	return true;
6534
6535	po = extract_ppc_passed_object (e);
6536	if (!po)
6537	return false;
6538
6539	/* F08:R739. */
6540	if (po->rank != 0)
6541	{
6542	gfc_error ("Passed-object at %L must be scalar", &e->where);
6543	return false;
6544	}
6545
6546	/* F08:C611. */
6547	if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
6548	{
6549	gfc_error ("Base object for procedure-pointer component call at %L is of"
6550	" ABSTRACT type %qs", &e->where, po->ts.u.derived->name);
6551	return false;
6552	}
6553
6554	gcc_assert (tb->pass_arg_num > 0);
6555	e->value.compcall.actual = update_arglist_pass (lst: e->value.compcall.actual, po,
6556	argpos: tb->pass_arg_num,
6557	name: tb->pass_arg);
6558
6559	return true;
6560	}
6561
6562
6563	/* Check that the object a TBP is called on is valid, i.e. it must not be
6564	of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
6565
6566	static bool
6567	check_typebound_baseobject (gfc_expr* e)
6568	{
6569	gfc_expr* base;
6570	bool return_value = false;
6571
6572	base = extract_compcall_passed_object (e);
6573	if (!base)
6574	return false;
6575
6576	if (base->ts.type != BT_DERIVED && base->ts.type != BT_CLASS)
6577	{
6578	gfc_error ("Error in typebound call at %L", &e->where);
6579	goto cleanup;
6580	}
6581
6582	if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok)
6583	return false;
6584
6585	/* F08:C611. */
6586	if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
6587	{
6588	gfc_error ("Base object for type-bound procedure call at %L is of"
6589	" ABSTRACT type %qs", &e->where, base->ts.u.derived->name);
6590	goto cleanup;
6591	}
6592
6593	/* F08:C1230. If the procedure called is NOPASS,
6594	the base object must be scalar. */
6595	if (e->value.compcall.tbp->nopass && base->rank != 0)
6596	{
6597	gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
6598	" be scalar", &e->where);
6599	goto cleanup;
6600	}
6601
6602	return_value = true;
6603
6604	cleanup:
6605	gfc_free_expr (base);
6606	return return_value;
6607	}
6608
6609
6610	/* Resolve a call to a type-bound procedure, either function or subroutine,
6611	statically from the data in an EXPR_COMPCALL expression. The adapted
6612	arglist and the target-procedure symtree are returned. */
6613
6614	static bool
6615	resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
6616	gfc_actual_arglist** actual)
6617	{
6618	gcc_assert (e->expr_type == EXPR_COMPCALL);
6619	gcc_assert (!e->value.compcall.tbp->is_generic);
6620
6621	/* Update the actual arglist for PASS. */
6622	if (!update_compcall_arglist (e))
6623	return false;
6624
6625	*actual = e->value.compcall.actual;
6626	*target = e->value.compcall.tbp->u.specific;
6627
6628	gfc_free_ref_list (e->ref);
6629	e->ref = NULL;
6630	e->value.compcall.actual = NULL;
6631
6632	/* If we find a deferred typebound procedure, check for derived types
6633	that an overriding typebound procedure has not been missed. */
6634	if (e->value.compcall.name
6635	&& !e->value.compcall.tbp->non_overridable
6636	&& e->value.compcall.base_object
6637	&& e->value.compcall.base_object->ts.type == BT_DERIVED)
6638	{
6639	gfc_symtree *st;
6640	gfc_symbol *derived;
6641
6642	/* Use the derived type of the base_object. */
6643	derived = e->value.compcall.base_object->ts.u.derived;
6644	st = NULL;
6645
6646	/* If necessary, go through the inheritance chain. */
6647	while (!st && derived)
6648	{
6649	/* Look for the typebound procedure 'name'. */
6650	if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
6651	st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
6652	e->value.compcall.name);
6653	if (!st)
6654	derived = gfc_get_derived_super_type (derived);
6655	}
6656
6657	/* Now find the specific name in the derived type namespace. */
6658	if (st && st->n.tb && st->n.tb->u.specific)
6659	gfc_find_sym_tree (st->n.tb->u.specific->name,
6660	derived->ns, 1, &st);
6661	if (st)
6662	*target = st;
6663	}
6664	return true;
6665	}
6666
6667
6668	/* Get the ultimate declared type from an expression. In addition,
6669	return the last class/derived type reference and the copy of the
6670	reference list. If check_types is set true, derived types are
6671	identified as well as class references. */
6672	static gfc_symbol*
6673	get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
6674	gfc_expr *e, bool check_types)
6675	{
6676	gfc_symbol *declared;
6677	gfc_ref *ref;
6678
6679	declared = NULL;
6680	if (class_ref)
6681	*class_ref = NULL;
6682	if (new_ref)
6683	*new_ref = gfc_copy_ref (e->ref);
6684
6685	for (ref = e->ref; ref; ref = ref->next)
6686	{
6687	if (ref->type != REF_COMPONENT)
6688	continue;
6689
6690	if ((ref->u.c.component->ts.type == BT_CLASS
6691	|| (check_types && gfc_bt_struct (ref->u.c.component->ts.type)))
6692	&& ref->u.c.component->attr.flavor != FL_PROCEDURE)
6693	{
6694	declared = ref->u.c.component->ts.u.derived;
6695	if (class_ref)
6696	*class_ref = ref;
6697	}
6698	}
6699
6700	if (declared == NULL)
6701	declared = e->symtree->n.sym->ts.u.derived;
6702
6703	return declared;
6704	}
6705
6706
6707	/* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
6708	which of the specific bindings (if any) matches the arglist and transform
6709	the expression into a call of that binding. */
6710
6711	static bool
6712	resolve_typebound_generic_call (gfc_expr* e, const char **name)
6713	{
6714	gfc_typebound_proc* genproc;
6715	const char* genname;
6716	gfc_symtree *st;
6717	gfc_symbol *derived;
6718
6719	gcc_assert (e->expr_type == EXPR_COMPCALL);
6720	genname = e->value.compcall.name;
6721	genproc = e->value.compcall.tbp;
6722
6723	if (!genproc->is_generic)
6724	return true;
6725
6726	/* Try the bindings on this type and in the inheritance hierarchy. */
6727	for (; genproc; genproc = genproc->overridden)
6728	{
6729	gfc_tbp_generic* g;
6730
6731	gcc_assert (genproc->is_generic);
6732	for (g = genproc->u.generic; g; g = g->next)
6733	{
6734	gfc_symbol* target;
6735	gfc_actual_arglist* args;
6736	bool matches;
6737
6738	gcc_assert (g->specific);
6739
6740	if (g->specific->error)
6741	continue;
6742
6743	target = g->specific->u.specific->n.sym;
6744
6745	/* Get the right arglist by handling PASS/NOPASS. */
6746	args = gfc_copy_actual_arglist (e->value.compcall.actual);
6747	if (!g->specific->nopass)
6748	{
6749	gfc_expr* po;
6750	po = extract_compcall_passed_object (e);
6751	if (!po)
6752	{
6753	gfc_free_actual_arglist (args);
6754	return false;
6755	}
6756
6757	gcc_assert (g->specific->pass_arg_num > 0);
6758	gcc_assert (!g->specific->error);
6759	args = update_arglist_pass (lst: args, po, argpos: g->specific->pass_arg_num,
6760	name: g->specific->pass_arg);
6761	}
6762	resolve_actual_arglist (arg: args, ptype: target->attr.proc,
6763	no_formal_args: is_external_proc (sym: target)
6764	&& gfc_sym_get_dummy_args (target) == NULL);
6765
6766	/* Check if this arglist matches the formal. */
6767	matches = gfc_arglist_matches_symbol (&args, target);
6768
6769	/* Clean up and break out of the loop if we've found it. */
6770	gfc_free_actual_arglist (args);
6771	if (matches)
6772	{
6773	e->value.compcall.tbp = g->specific;
6774	genname = g->specific_st->name;
6775	/* Pass along the name for CLASS methods, where the vtab
6776	procedure pointer component has to be referenced. */
6777	if (name)
6778	*name = genname;
6779	goto success;
6780	}
6781	}
6782	}
6783
6784	/* Nothing matching found! */
6785	gfc_error ("Found no matching specific binding for the call to the GENERIC"
6786	" %qs at %L", genname, &e->where);
6787	return false;
6788
6789	success:
6790	/* Make sure that we have the right specific instance for the name. */
6791	derived = get_declared_from_expr (NULL, NULL, e, check_types: true);
6792
6793	st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
6794	if (st)
6795	e->value.compcall.tbp = st->n.tb;
6796
6797	return true;
6798	}
6799
6800
6801	/* Resolve a call to a type-bound subroutine. */
6802
6803	static bool
6804	resolve_typebound_call (gfc_code* c, const char **name, bool *overridable)
6805	{
6806	gfc_actual_arglist* newactual;
6807	gfc_symtree* target;
6808
6809	/* Check that's really a SUBROUTINE. */
6810	if (!c->expr1->value.compcall.tbp->subroutine)
6811	{
6812	if (!c->expr1->value.compcall.tbp->is_generic
6813	&& c->expr1->value.compcall.tbp->u.specific
6814	&& c->expr1->value.compcall.tbp->u.specific->n.sym
6815	&& c->expr1->value.compcall.tbp->u.specific->n.sym->attr.subroutine)
6816	c->expr1->value.compcall.tbp->subroutine = 1;
6817	else
6818	{
6819	gfc_error ("%qs at %L should be a SUBROUTINE",
6820	c->expr1->value.compcall.name, &c->loc);
6821	return false;
6822	}
6823	}
6824
6825	if (!check_typebound_baseobject (e: c->expr1))
6826	return false;
6827
6828	/* Pass along the name for CLASS methods, where the vtab
6829	procedure pointer component has to be referenced. */
6830	if (name)
6831	*name = c->expr1->value.compcall.name;
6832
6833	if (!resolve_typebound_generic_call (e: c->expr1, name))
6834	return false;
6835
6836	/* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
6837	if (overridable)
6838	*overridable = !c->expr1->value.compcall.tbp->non_overridable;
6839
6840	/* Transform into an ordinary EXEC_CALL for now. */
6841
6842	if (!resolve_typebound_static (e: c->expr1, target: &target, actual: &newactual))
6843	return false;
6844
6845	c->ext.actual = newactual;
6846	c->symtree = target;
6847	c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
6848
6849	gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
6850
6851	gfc_free_expr (c->expr1);
6852	c->expr1 = gfc_get_expr ();
6853	c->expr1->expr_type = EXPR_FUNCTION;
6854	c->expr1->symtree = target;
6855	c->expr1->where = c->loc;
6856
6857	return resolve_call (c);
6858	}
6859
6860
6861	/* Resolve a component-call expression. */
6862	static bool
6863	resolve_compcall (gfc_expr* e, const char **name)
6864	{
6865	gfc_actual_arglist* newactual;
6866	gfc_symtree* target;
6867
6868	/* Check that's really a FUNCTION. */
6869	if (!e->value.compcall.tbp->function)
6870	{
6871	gfc_error ("%qs at %L should be a FUNCTION",
6872	e->value.compcall.name, &e->where);
6873	return false;
6874	}
6875
6876
6877	/* These must not be assign-calls! */
6878	gcc_assert (!e->value.compcall.assign);
6879
6880	if (!check_typebound_baseobject (e))
6881	return false;
6882
6883	/* Pass along the name for CLASS methods, where the vtab
6884	procedure pointer component has to be referenced. */
6885	if (name)
6886	*name = e->value.compcall.name;
6887
6888	if (!resolve_typebound_generic_call (e, name))
6889	return false;
6890	gcc_assert (!e->value.compcall.tbp->is_generic);
6891
6892	/* Take the rank from the function's symbol. */
6893	if (e->value.compcall.tbp->u.specific->n.sym->as)
6894	e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
6895
6896	/* For now, we simply transform it into an EXPR_FUNCTION call with the same
6897	arglist to the TBP's binding target. */
6898
6899	if (!resolve_typebound_static (e, target: &target, actual: &newactual))
6900	return false;
6901
6902	e->value.function.actual = newactual;
6903	e->value.function.name = NULL;
6904	e->value.function.esym = target->n.sym;
6905	e->value.function.isym = NULL;
6906	e->symtree = target;
6907	e->ts = target->n.sym->ts;
6908	e->expr_type = EXPR_FUNCTION;
6909
6910	/* Resolution is not necessary if this is a class subroutine; this
6911	function only has to identify the specific proc. Resolution of
6912	the call will be done next in resolve_typebound_call. */
6913	return gfc_resolve_expr (e);
6914	}
6915
6916
6917	static bool resolve_fl_derived (gfc_symbol *sym);
6918
6919
6920	/* Resolve a typebound function, or 'method'. First separate all
6921	the non-CLASS references by calling resolve_compcall directly. */
6922
6923	static bool
6924	resolve_typebound_function (gfc_expr* e)
6925	{
6926	gfc_symbol *declared;
6927	gfc_component *c;
6928	gfc_ref *new_ref;
6929	gfc_ref *class_ref;
6930	gfc_symtree *st;
6931	const char *name;
6932	gfc_typespec ts;
6933	gfc_expr *expr;
6934	bool overridable;
6935
6936	st = e->symtree;
6937
6938	/* Deal with typebound operators for CLASS objects. */
6939	expr = e->value.compcall.base_object;
6940	overridable = !e->value.compcall.tbp->non_overridable;
6941	if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
6942	{
6943	/* Since the typebound operators are generic, we have to ensure
6944	that any delays in resolution are corrected and that the vtab
6945	is present. */
6946	ts = expr->ts;
6947	declared = ts.u.derived;
6948	c = gfc_find_component (declared, "_vptr", true, true, NULL);
6949	if (c->ts.u.derived == NULL)
6950	c->ts.u.derived = gfc_find_derived_vtab (declared);
6951
6952	if (!resolve_compcall (e, name: &name))
6953	return false;
6954
6955	/* Use the generic name if it is there. */
6956	name = name ? name : e->value.function.esym->name;
6957	e->symtree = expr->symtree;
6958	e->ref = gfc_copy_ref (expr->ref);
6959	get_declared_from_expr (class_ref: &class_ref, NULL, e, check_types: false);
6960
6961	/* Trim away the extraneous references that emerge from nested
6962	use of interface.cc (extend_expr). */
6963	if (class_ref && class_ref->next)
6964	{
6965	gfc_free_ref_list (class_ref->next);
6966	class_ref->next = NULL;
6967	}
6968	else if (e->ref && !class_ref && expr->ts.type != BT_CLASS)
6969	{
6970	gfc_free_ref_list (e->ref);
6971	e->ref = NULL;
6972	}
6973
6974	gfc_add_vptr_component (e);
6975	gfc_add_component_ref (e, name);
6976	e->value.function.esym = NULL;
6977	if (expr->expr_type != EXPR_VARIABLE)
6978	e->base_expr = expr;
6979	return true;
6980	}
6981
6982	if (st == NULL)
6983	return resolve_compcall (e, NULL);
6984
6985	if (!gfc_resolve_ref (expr: e))
6986	return false;
6987
6988	/* Get the CLASS declared type. */
6989	declared = get_declared_from_expr (class_ref: &class_ref, new_ref: &new_ref, e, check_types: true);
6990
6991	if (!resolve_fl_derived (sym: declared))
6992	return false;
6993
6994	/* Weed out cases of the ultimate component being a derived type. */
6995	if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
6996	|| (!class_ref && st->n.sym->ts.type != BT_CLASS))
6997	{
6998	gfc_free_ref_list (new_ref);
6999	return resolve_compcall (e, NULL);
7000	}
7001
7002	c = gfc_find_component (declared, "_data", true, true, NULL);
7003
7004	/* Treat the call as if it is a typebound procedure, in order to roll
7005	out the correct name for the specific function. */
7006	if (!resolve_compcall (e, name: &name))
7007	{
7008	gfc_free_ref_list (new_ref);
7009	return false;
7010	}
7011	ts = e->ts;
7012
7013	if (overridable)
7014	{
7015	/* Convert the expression to a procedure pointer component call. */
7016	e->value.function.esym = NULL;
7017	e->symtree = st;
7018
7019	if (new_ref)
7020	e->ref = new_ref;
7021
7022	/* '_vptr' points to the vtab, which contains the procedure pointers. */
7023	gfc_add_vptr_component (e);
7024	gfc_add_component_ref (e, name);
7025
7026	/* Recover the typespec for the expression. This is really only
7027	necessary for generic procedures, where the additional call
7028	to gfc_add_component_ref seems to throw the collection of the
7029	correct typespec. */
7030	e->ts = ts;
7031	}
7032	else if (new_ref)
7033	gfc_free_ref_list (new_ref);
7034
7035	return true;
7036	}
7037
7038	/* Resolve a typebound subroutine, or 'method'. First separate all
7039	the non-CLASS references by calling resolve_typebound_call
7040	directly. */
7041
7042	static bool
7043	resolve_typebound_subroutine (gfc_code *code)
7044	{
7045	gfc_symbol *declared;
7046	gfc_component *c;
7047	gfc_ref *new_ref;
7048	gfc_ref *class_ref;
7049	gfc_symtree *st;
7050	const char *name;
7051	gfc_typespec ts;
7052	gfc_expr *expr;
7053	bool overridable;
7054
7055	st = code->expr1->symtree;
7056
7057	/* Deal with typebound operators for CLASS objects. */
7058	expr = code->expr1->value.compcall.base_object;
7059	overridable = !code->expr1->value.compcall.tbp->non_overridable;
7060	if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
7061	{
7062	/* If the base_object is not a variable, the corresponding actual
7063	argument expression must be stored in e->base_expression so
7064	that the corresponding tree temporary can be used as the base
7065	object in gfc_conv_procedure_call. */
7066	if (expr->expr_type != EXPR_VARIABLE)
7067	{
7068	gfc_actual_arglist *args;
7069
7070	args= code->expr1->value.function.actual;
7071	for (; args; args = args->next)
7072	if (expr == args->expr)
7073	expr = args->expr;
7074	}
7075
7076	/* Since the typebound operators are generic, we have to ensure
7077	that any delays in resolution are corrected and that the vtab
7078	is present. */
7079	declared = expr->ts.u.derived;
7080	c = gfc_find_component (declared, "_vptr", true, true, NULL);
7081	if (c->ts.u.derived == NULL)
7082	c->ts.u.derived = gfc_find_derived_vtab (declared);
7083
7084	if (!resolve_typebound_call (c: code, name: &name, NULL))
7085	return false;
7086
7087	/* Use the generic name if it is there. */
7088	name = name ? name : code->expr1->value.function.esym->name;
7089	code->expr1->symtree = expr->symtree;
7090	code->expr1->ref = gfc_copy_ref (expr->ref);
7091
7092	/* Trim away the extraneous references that emerge from nested
7093	use of interface.cc (extend_expr). */
7094	get_declared_from_expr (class_ref: &class_ref, NULL, e: code->expr1, check_types: false);
7095	if (class_ref && class_ref->next)
7096	{
7097	gfc_free_ref_list (class_ref->next);
7098	class_ref->next = NULL;
7099	}
7100	else if (code->expr1->ref && !class_ref)
7101	{
7102	gfc_free_ref_list (code->expr1->ref);
7103	code->expr1->ref = NULL;
7104	}
7105
7106	/* Now use the procedure in the vtable. */
7107	gfc_add_vptr_component (code->expr1);
7108	gfc_add_component_ref (code->expr1, name);
7109	code->expr1->value.function.esym = NULL;
7110	if (expr->expr_type != EXPR_VARIABLE)
7111	code->expr1->base_expr = expr;
7112	return true;
7113	}
7114
7115	if (st == NULL)
7116	return resolve_typebound_call (c: code, NULL, NULL);
7117
7118	if (!gfc_resolve_ref (expr: code->expr1))
7119	return false;
7120
7121	/* Get the CLASS declared type. */
7122	get_declared_from_expr (class_ref: &class_ref, new_ref: &new_ref, e: code->expr1, check_types: true);
7123
7124	/* Weed out cases of the ultimate component being a derived type. */
7125	if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
7126	|| (!class_ref && st->n.sym->ts.type != BT_CLASS))
7127	{
7128	gfc_free_ref_list (new_ref);
7129	return resolve_typebound_call (c: code, NULL, NULL);
7130	}
7131
7132	if (!resolve_typebound_call (c: code, name: &name, overridable: &overridable))
7133	{
7134	gfc_free_ref_list (new_ref);
7135	return false;
7136	}
7137	ts = code->expr1->ts;
7138
7139	if (overridable)
7140	{
7141	/* Convert the expression to a procedure pointer component call. */
7142	code->expr1->value.function.esym = NULL;
7143	code->expr1->symtree = st;
7144
7145	if (new_ref)
7146	code->expr1->ref = new_ref;
7147
7148	/* '_vptr' points to the vtab, which contains the procedure pointers. */
7149	gfc_add_vptr_component (code->expr1);
7150	gfc_add_component_ref (code->expr1, name);
7151
7152	/* Recover the typespec for the expression. This is really only
7153	necessary for generic procedures, where the additional call
7154	to gfc_add_component_ref seems to throw the collection of the
7155	correct typespec. */
7156	code->expr1->ts = ts;
7157	}
7158	else if (new_ref)
7159	gfc_free_ref_list (new_ref);
7160
7161	return true;
7162	}
7163
7164
7165	/* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
7166
7167	static bool
7168	resolve_ppc_call (gfc_code* c)
7169	{
7170	gfc_component *comp;
7171
7172	comp = gfc_get_proc_ptr_comp (c->expr1);
7173	gcc_assert (comp != NULL);
7174
7175	c->resolved_sym = c->expr1->symtree->n.sym;
7176	c->expr1->expr_type = EXPR_VARIABLE;
7177
7178	if (!comp->attr.subroutine)
7179	gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
7180
7181	if (!gfc_resolve_ref (expr: c->expr1))
7182	return false;
7183
7184	if (!update_ppc_arglist (e: c->expr1))
7185	return false;
7186
7187	c->ext.actual = c->expr1->value.compcall.actual;
7188
7189	if (!resolve_actual_arglist (arg: c->ext.actual, ptype: comp->attr.proc,
7190	no_formal_args: !(comp->ts.interface
7191	&& comp->ts.interface->formal)))
7192	return false;
7193
7194	if (!pure_subroutine (sym: comp->ts.interface, name: comp->name, loc: &c->expr1->where))
7195	return false;
7196
7197	gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
7198
7199	return true;
7200	}
7201
7202
7203	/* Resolve a Function Call to a Procedure Pointer Component (Function). */
7204
7205	static bool
7206	resolve_expr_ppc (gfc_expr* e)
7207	{
7208	gfc_component *comp;
7209
7210	comp = gfc_get_proc_ptr_comp (e);
7211	gcc_assert (comp != NULL);
7212
7213	/* Convert to EXPR_FUNCTION. */
7214	e->expr_type = EXPR_FUNCTION;
7215	e->value.function.isym = NULL;
7216	e->value.function.actual = e->value.compcall.actual;
7217	e->ts = comp->ts;
7218	if (comp->as != NULL)
7219	e->rank = comp->as->rank;
7220
7221	if (!comp->attr.function)
7222	gfc_add_function (&comp->attr, comp->name, &e->where);
7223
7224	if (!gfc_resolve_ref (expr: e))
7225	return false;
7226
7227	if (!resolve_actual_arglist (arg: e->value.function.actual, ptype: comp->attr.proc,
7228	no_formal_args: !(comp->ts.interface
7229	&& comp->ts.interface->formal)))
7230	return false;
7231
7232	if (!update_ppc_arglist (e))
7233	return false;
7234
7235	if (!check_pure_function(e))
7236	return false;
7237
7238	gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
7239
7240	return true;
7241	}
7242
7243
7244	static bool
7245	gfc_is_expandable_expr (gfc_expr *e)
7246	{
7247	gfc_constructor *con;
7248
7249	if (e->expr_type == EXPR_ARRAY)
7250	{
7251	/* Traverse the constructor looking for variables that are flavor
7252	parameter. Parameters must be expanded since they are fully used at
7253	compile time. */
7254	con = gfc_constructor_first (base: e->value.constructor);
7255	for (; con; con = gfc_constructor_next (ctor: con))
7256	{
7257	if (con->expr->expr_type == EXPR_VARIABLE
7258	&& con->expr->symtree
7259	&& (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
7260	|| con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
7261	return true;
7262	if (con->expr->expr_type == EXPR_ARRAY
7263	&& gfc_is_expandable_expr (e: con->expr))
7264	return true;
7265	}
7266	}
7267
7268	return false;
7269	}
7270
7271
7272	/* Sometimes variables in specification expressions of the result
7273	of module procedures in submodules wind up not being the 'real'
7274	dummy. Find this, if possible, in the namespace of the first
7275	formal argument. */
7276
7277	static void
7278	fixup_unique_dummy (gfc_expr *e)
7279	{
7280	gfc_symtree *st = NULL;
7281	gfc_symbol *s = NULL;
7282
7283	if (e->symtree->n.sym->ns->proc_name
7284	&& e->symtree->n.sym->ns->proc_name->formal)
7285	s = e->symtree->n.sym->ns->proc_name->formal->sym;
7286
7287	if (s != NULL)
7288	st = gfc_find_symtree (s->ns->sym_root, e->symtree->n.sym->name);
7289
7290	if (st != NULL
7291	&& st->n.sym != NULL
7292	&& st->n.sym->attr.dummy)
7293	e->symtree = st;
7294	}
7295
7296	/* Resolve an expression. That is, make sure that types of operands agree
7297	with their operators, intrinsic operators are converted to function calls
7298	for overloaded types and unresolved function references are resolved. */
7299
7300	bool
7301	gfc_resolve_expr (gfc_expr *e)
7302	{
7303	bool t;
7304	bool inquiry_save, actual_arg_save, first_actual_arg_save;
7305
7306	if (e == NULL || e->do_not_resolve_again)
7307	return true;
7308
7309	/* inquiry_argument only applies to variables. */
7310	inquiry_save = inquiry_argument;
7311	actual_arg_save = actual_arg;
7312	first_actual_arg_save = first_actual_arg;
7313
7314	if (e->expr_type != EXPR_VARIABLE)
7315	{
7316	inquiry_argument = false;
7317	actual_arg = false;
7318	first_actual_arg = false;
7319	}
7320	else if (e->symtree != NULL
7321	&& *e->symtree->name == '@'
7322	&& e->symtree->n.sym->attr.dummy)
7323	{
7324	/* Deal with submodule specification expressions that are not
7325	found to be referenced in module.cc(read_cleanup). */
7326	fixup_unique_dummy (e);
7327	}
7328
7329	switch (e->expr_type)
7330	{
7331	case EXPR_OP:
7332	t = resolve_operator (e);
7333	break;
7334
7335	case EXPR_FUNCTION:
7336	case EXPR_VARIABLE:
7337
7338	if (check_host_association (e))
7339	t = resolve_function (expr: e);
7340	else
7341	t = resolve_variable (e);
7342
7343	if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
7344	&& e->ref->type != REF_SUBSTRING)
7345	gfc_resolve_substring_charlen (e);
7346
7347	break;
7348
7349	case EXPR_COMPCALL:
7350	t = resolve_typebound_function (e);
7351	break;
7352
7353	case EXPR_SUBSTRING:
7354	t = gfc_resolve_ref (expr: e);
7355	break;
7356
7357	case EXPR_CONSTANT:
7358	case EXPR_NULL:
7359	t = true;
7360	break;
7361
7362	case EXPR_PPC:
7363	t = resolve_expr_ppc (e);
7364	break;
7365
7366	case EXPR_ARRAY:
7367	t = false;
7368	if (!gfc_resolve_ref (expr: e))
7369	break;
7370
7371	t = gfc_resolve_array_constructor (e);
7372	/* Also try to expand a constructor. */
7373	if (t)
7374	{
7375	gfc_expression_rank (e);
7376	if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
7377	gfc_expand_constructor (e, false);
7378	}
7379
7380	/* This provides the opportunity for the length of constructors with
7381	character valued function elements to propagate the string length
7382	to the expression. */
7383	if (t && e->ts.type == BT_CHARACTER)
7384	{
7385	/* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
7386	here rather then add a duplicate test for it above. */
7387	gfc_expand_constructor (e, false);
7388	t = gfc_resolve_character_array_constructor (e);
7389	}
7390
7391	break;
7392
7393	case EXPR_STRUCTURE:
7394	t = gfc_resolve_ref (expr: e);
7395	if (!t)
7396	break;
7397
7398	t = resolve_structure_cons (expr: e, init: 0);
7399	if (!t)
7400	break;
7401
7402	t = gfc_simplify_expr (e, 0);
7403	break;
7404
7405	default:
7406	gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
7407	}
7408
7409	if (e->ts.type == BT_CHARACTER && t && !e->ts.u.cl)
7410	fixup_charlen (e);
7411
7412	inquiry_argument = inquiry_save;
7413	actual_arg = actual_arg_save;
7414	first_actual_arg = first_actual_arg_save;
7415
7416	/* For some reason, resolving these expressions a second time mangles
7417	the typespec of the expression itself. */
7418	if (t && e->expr_type == EXPR_VARIABLE
7419	&& e->symtree->n.sym->attr.select_rank_temporary
7420	&& UNLIMITED_POLY (e->symtree->n.sym))
7421	e->do_not_resolve_again = 1;
7422
7423	return t;
7424	}
7425
7426
7427	/* Resolve an expression from an iterator. They must be scalar and have
7428	INTEGER or (optionally) REAL type. */
7429
7430	static bool
7431	gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
7432	const char *name_msgid)
7433	{
7434	if (!gfc_resolve_expr (e: expr))
7435	return false;
7436
7437	if (expr->rank != 0)
7438	{
7439	gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
7440	return false;
7441	}
7442
7443	if (expr->ts.type != BT_INTEGER)
7444	{
7445	if (expr->ts.type == BT_REAL)
7446	{
7447	if (real_ok)
7448	return gfc_notify_std (GFC_STD_F95_DEL,
7449	"%s at %L must be integer",
7450	_(name_msgid), &expr->where);
7451	else
7452	{
7453	gfc_error ("%s at %L must be INTEGER", _(name_msgid),
7454	&expr->where);
7455	return false;
7456	}
7457	}
7458	else
7459	{
7460	gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
7461	return false;
7462	}
7463	}
7464	return true;
7465	}
7466
7467
7468	/* Resolve the expressions in an iterator structure. If REAL_OK is
7469	false allow only INTEGER type iterators, otherwise allow REAL types.
7470	Set own_scope to true for ac-implied-do and data-implied-do as those
7471	have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
7472
7473	bool
7474	gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
7475	{
7476	if (!gfc_resolve_iterator_expr (expr: iter->var, real_ok, name_msgid: "Loop variable"))
7477	return false;
7478
7479	if (!gfc_check_vardef_context (iter->var, false, false, own_scope,
7480	_("iterator variable")))
7481	return false;
7482
7483	if (!gfc_resolve_iterator_expr (expr: iter->start, real_ok,
7484	name_msgid: "Start expression in DO loop"))
7485	return false;
7486
7487	if (!gfc_resolve_iterator_expr (expr: iter->end, real_ok,
7488	name_msgid: "End expression in DO loop"))
7489	return false;
7490
7491	if (!gfc_resolve_iterator_expr (expr: iter->step, real_ok,
7492	name_msgid: "Step expression in DO loop"))
7493	return false;
7494
7495	/* Convert start, end, and step to the same type as var. */
7496	if (iter->start->ts.kind != iter->var->ts.kind
7497	|| iter->start->ts.type != iter->var->ts.type)
7498	gfc_convert_type (iter->start, &iter->var->ts, 1);
7499
7500	if (iter->end->ts.kind != iter->var->ts.kind
7501	|| iter->end->ts.type != iter->var->ts.type)
7502	gfc_convert_type (iter->end, &iter->var->ts, 1);
7503
7504	if (iter->step->ts.kind != iter->var->ts.kind
7505	|| iter->step->ts.type != iter->var->ts.type)
7506	gfc_convert_type (iter->step, &iter->var->ts, 1);
7507
7508	if (iter->step->expr_type == EXPR_CONSTANT)
7509	{
7510	if ((iter->step->ts.type == BT_INTEGER
7511	&& mpz_cmp_ui (iter->step->value.integer, 0) == 0)
7512	|| (iter->step->ts.type == BT_REAL
7513	&& mpfr_sgn (iter->step->value.real) == 0))
7514	{
7515	gfc_error ("Step expression in DO loop at %L cannot be zero",
7516	&iter->step->where);
7517	return false;
7518	}
7519	}
7520
7521	if (iter->start->expr_type == EXPR_CONSTANT
7522	&& iter->end->expr_type == EXPR_CONSTANT
7523	&& iter->step->expr_type == EXPR_CONSTANT)
7524	{
7525	int sgn, cmp;
7526	if (iter->start->ts.type == BT_INTEGER)
7527	{
7528	sgn = mpz_cmp_ui (iter->step->value.integer, 0);
7529	cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
7530	}
7531	else
7532	{
7533	sgn = mpfr_sgn (iter->step->value.real);
7534	cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
7535	}
7536	if (warn_zerotrip && ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0)))
7537	gfc_warning (opt: OPT_Wzerotrip,
7538	"DO loop at %L will be executed zero times",
7539	&iter->step->where);
7540	}
7541
7542	if (iter->end->expr_type == EXPR_CONSTANT
7543	&& iter->end->ts.type == BT_INTEGER
7544	&& iter->step->expr_type == EXPR_CONSTANT
7545	&& iter->step->ts.type == BT_INTEGER
7546	&& (mpz_cmp_si (iter->step->value.integer, -1L) == 0
7547	|| mpz_cmp_si (iter->step->value.integer, 1L) == 0))
7548	{
7549	bool is_step_positive = mpz_cmp_ui (iter->step->value.integer, 1) == 0;
7550	int k = gfc_validate_kind (BT_INTEGER, iter->end->ts.kind, false);
7551
7552	if (is_step_positive
7553	&& mpz_cmp (iter->end->value.integer, gfc_integer_kinds[k].huge) == 0)
7554	gfc_warning (opt: OPT_Wundefined_do_loop,
7555	"DO loop at %L is undefined as it overflows",
7556	&iter->step->where);
7557	else if (!is_step_positive
7558	&& mpz_cmp (iter->end->value.integer,
7559	gfc_integer_kinds[k].min_int) == 0)
7560	gfc_warning (opt: OPT_Wundefined_do_loop,
7561	"DO loop at %L is undefined as it underflows",
7562	&iter->step->where);
7563	}
7564
7565	return true;
7566	}
7567
7568
7569	/* Traversal function for find_forall_index. f == 2 signals that
7570	that variable itself is not to be checked - only the references. */
7571
7572	static bool
7573	forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
7574	{
7575	if (expr->expr_type != EXPR_VARIABLE)
7576	return false;
7577
7578	/* A scalar assignment */
7579	if (!expr->ref || *f == 1)
7580	{
7581	if (expr->symtree->n.sym == sym)
7582	return true;
7583	else
7584	return false;
7585	}
7586
7587	if (*f == 2)
7588	*f = 1;
7589	return false;
7590	}
7591
7592
7593	/* Check whether the FORALL index appears in the expression or not.
7594	Returns true if SYM is found in EXPR. */
7595
7596	bool
7597	find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
7598	{
7599	if (gfc_traverse_expr (expr, sym, forall_index, f))
7600	return true;
7601	else
7602	return false;
7603	}
7604
7605
7606	/* Resolve a list of FORALL iterators. The FORALL index-name is constrained
7607	to be a scalar INTEGER variable. The subscripts and stride are scalar
7608	INTEGERs, and if stride is a constant it must be nonzero.
7609	Furthermore "A subscript or stride in a forall-triplet-spec shall
7610	not contain a reference to any index-name in the
7611	forall-triplet-spec-list in which it appears." (7.5.4.1) */
7612
7613	static void
7614	resolve_forall_iterators (gfc_forall_iterator *it)
7615	{
7616	gfc_forall_iterator *iter, *iter2;
7617
7618	for (iter = it; iter; iter = iter->next)
7619	{
7620	if (gfc_resolve_expr (e: iter->var)
7621	&& (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
7622	gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
7623	&iter->var->where);
7624
7625	if (gfc_resolve_expr (e: iter->start)
7626	&& (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
7627	gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
7628	&iter->start->where);
7629	if (iter->var->ts.kind != iter->start->ts.kind)
7630	gfc_convert_type (iter->start, &iter->var->ts, 1);
7631
7632	if (gfc_resolve_expr (e: iter->end)
7633	&& (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
7634	gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
7635	&iter->end->where);
7636	if (iter->var->ts.kind != iter->end->ts.kind)
7637	gfc_convert_type (iter->end, &iter->var->ts, 1);
7638
7639	if (gfc_resolve_expr (e: iter->stride))
7640	{
7641	if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
7642	gfc_error ("FORALL stride expression at %L must be a scalar %s",
7643	&iter->stride->where, "INTEGER");
7644
7645	if (iter->stride->expr_type == EXPR_CONSTANT
7646	&& mpz_cmp_ui (iter->stride->value.integer, 0) == 0)
7647	gfc_error ("FORALL stride expression at %L cannot be zero",
7648	&iter->stride->where);
7649	}
7650	if (iter->var->ts.kind != iter->stride->ts.kind)
7651	gfc_convert_type (iter->stride, &iter->var->ts, 1);
7652	}
7653
7654	for (iter = it; iter; iter = iter->next)
7655	for (iter2 = iter; iter2; iter2 = iter2->next)
7656	{
7657	if (find_forall_index (expr: iter2->start, sym: iter->var->symtree->n.sym, f: 0)
7658	|| find_forall_index (expr: iter2->end, sym: iter->var->symtree->n.sym, f: 0)
7659	|| find_forall_index (expr: iter2->stride, sym: iter->var->symtree->n.sym, f: 0))
7660	gfc_error ("FORALL index %qs may not appear in triplet "
7661	"specification at %L", iter->var->symtree->name,
7662	&iter2->start->where);
7663	}
7664	}
7665
7666
7667	/* Given a pointer to a symbol that is a derived type, see if it's
7668	inaccessible, i.e. if it's defined in another module and the components are
7669	PRIVATE. The search is recursive if necessary. Returns zero if no
7670	inaccessible components are found, nonzero otherwise. */
7671
7672	static bool
7673	derived_inaccessible (gfc_symbol *sym)
7674	{
7675	gfc_component *c;
7676
7677	if (sym->attr.use_assoc && sym->attr.private_comp)
7678	return 1;
7679
7680	for (c = sym->components; c; c = c->next)
7681	{
7682	/* Prevent an infinite loop through this function. */
7683	if (c->ts.type == BT_DERIVED
7684	&& (c->attr.pointer || c->attr.allocatable)
7685	&& sym == c->ts.u.derived)
7686	continue;
7687
7688	if (c->ts.type == BT_DERIVED && derived_inaccessible (sym: c->ts.u.derived))
7689	return 1;
7690	}
7691
7692	return 0;
7693	}
7694
7695
7696	/* Resolve the argument of a deallocate expression. The expression must be
7697	a pointer or a full array. */
7698
7699	static bool
7700	resolve_deallocate_expr (gfc_expr *e)
7701	{
7702	symbol_attribute attr;
7703	int allocatable, pointer;
7704	gfc_ref *ref;
7705	gfc_symbol *sym;
7706	gfc_component *c;
7707	bool unlimited;
7708
7709	if (!gfc_resolve_expr (e))
7710	return false;
7711
7712	if (e->expr_type != EXPR_VARIABLE)
7713	goto bad;
7714
7715	sym = e->symtree->n.sym;
7716	unlimited = UNLIMITED_POLY(sym);
7717
7718	if (sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym))
7719	{
7720	allocatable = CLASS_DATA (sym)->attr.allocatable;
7721	pointer = CLASS_DATA (sym)->attr.class_pointer;
7722	}
7723	else
7724	{
7725	allocatable = sym->attr.allocatable;
7726	pointer = sym->attr.pointer;
7727	}
7728	for (ref = e->ref; ref; ref = ref->next)
7729	{
7730	switch (ref->type)
7731	{
7732	case REF_ARRAY:
7733	if (ref->u.ar.type != AR_FULL
7734	&& !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
7735	&& ref->u.ar.codimen && gfc_ref_this_image (ref)))
7736	allocatable = 0;
7737	break;
7738
7739	case REF_COMPONENT:
7740	c = ref->u.c.component;
7741	if (c->ts.type == BT_CLASS)
7742	{
7743	allocatable = CLASS_DATA (c)->attr.allocatable;
7744	pointer = CLASS_DATA (c)->attr.class_pointer;
7745	}
7746	else
7747	{
7748	allocatable = c->attr.allocatable;
7749	pointer = c->attr.pointer;
7750	}
7751	break;
7752
7753	case REF_SUBSTRING:
7754	case REF_INQUIRY:
7755	allocatable = 0;
7756	break;
7757	}
7758	}
7759
7760	attr = gfc_expr_attr (e);
7761
7762	if (allocatable == 0 && attr.pointer == 0 && !unlimited)
7763	{
7764	bad:
7765	gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7766	&e->where);
7767	return false;
7768	}
7769
7770	/* F2008, C644. */
7771	if (gfc_is_coindexed (e))
7772	{
7773	gfc_error ("Coindexed allocatable object at %L", &e->where);
7774	return false;
7775	}
7776
7777	if (pointer
7778	&& !gfc_check_vardef_context (e, true, true, false,
7779	_("DEALLOCATE object")))
7780	return false;
7781	if (!gfc_check_vardef_context (e, false, true, false,
7782	_("DEALLOCATE object")))
7783	return false;
7784
7785	return true;
7786	}
7787
7788
7789	/* Returns true if the expression e contains a reference to the symbol sym. */
7790	static bool
7791	sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
7792	{
7793	if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
7794	return true;
7795
7796	return false;
7797	}
7798
7799	bool
7800	gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
7801	{
7802	return gfc_traverse_expr (e, sym, sym_in_expr, 0);
7803	}
7804
7805
7806	/* Given the expression node e for an allocatable/pointer of derived type to be
7807	allocated, get the expression node to be initialized afterwards (needed for
7808	derived types with default initializers, and derived types with allocatable
7809	components that need nullification.) */
7810
7811	gfc_expr *
7812	gfc_expr_to_initialize (gfc_expr *e)
7813	{
7814	gfc_expr *result;
7815	gfc_ref *ref;
7816	int i;
7817
7818	result = gfc_copy_expr (e);
7819
7820	/* Change the last array reference from AR_ELEMENT to AR_FULL. */
7821	for (ref = result->ref; ref; ref = ref->next)
7822	if (ref->type == REF_ARRAY && ref->next == NULL)
7823	{
7824	if (ref->u.ar.dimen == 0
7825	&& ref->u.ar.as && ref->u.ar.as->corank)
7826	return result;
7827
7828	ref->u.ar.type = AR_FULL;
7829
7830	for (i = 0; i < ref->u.ar.dimen; i++)
7831	ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
7832
7833	break;
7834	}
7835
7836	gfc_free_shape (shape: &result->shape, rank: result->rank);
7837
7838	/* Recalculate rank, shape, etc. */
7839	gfc_resolve_expr (e: result);
7840	return result;
7841	}
7842
7843
7844	/* If the last ref of an expression is an array ref, return a copy of the
7845	expression with that one removed. Otherwise, a copy of the original
7846	expression. This is used for allocate-expressions and pointer assignment
7847	LHS, where there may be an array specification that needs to be stripped
7848	off when using gfc_check_vardef_context. */
7849
7850	static gfc_expr*
7851	remove_last_array_ref (gfc_expr* e)
7852	{
7853	gfc_expr* e2;
7854	gfc_ref** r;
7855
7856	e2 = gfc_copy_expr (e);
7857	for (r = &e2->ref; *r; r = &(*r)->next)
7858	if ((*r)->type == REF_ARRAY && !(*r)->next)
7859	{
7860	gfc_free_ref_list (*r);
7861	*r = NULL;
7862	break;
7863	}
7864
7865	return e2;
7866	}
7867
7868
7869	/* Used in resolve_allocate_expr to check that a allocation-object and
7870	a source-expr are conformable. This does not catch all possible
7871	cases; in particular a runtime checking is needed. */
7872
7873	static bool
7874	conformable_arrays (gfc_expr *e1, gfc_expr *e2)
7875	{
7876	gfc_ref *tail;
7877	for (tail = e2->ref; tail && tail->next; tail = tail->next);
7878
7879	/* First compare rank. */
7880	if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank))
7881	|| (!tail && e1->rank != e2->rank))
7882	{
7883	gfc_error ("Source-expr at %L must be scalar or have the "
7884	"same rank as the allocate-object at %L",
7885	&e1->where, &e2->where);
7886	return false;
7887	}
7888
7889	if (e1->shape)
7890	{
7891	int i;
7892	mpz_t s;
7893
7894	mpz_init (s);
7895
7896	for (i = 0; i < e1->rank; i++)
7897	{
7898	if (tail->u.ar.start[i] == NULL)
7899	break;
7900
7901	if (tail->u.ar.end[i])
7902	{
7903	mpz_set (s, tail->u.ar.end[i]->value.integer);
7904	mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
7905	mpz_add_ui (s, s, 1);
7906	}
7907	else
7908	{
7909	mpz_set (s, tail->u.ar.start[i]->value.integer);
7910	}
7911
7912	if (mpz_cmp (e1->shape[i], s) != 0)
7913	{
7914	gfc_error ("Source-expr at %L and allocate-object at %L must "
7915	"have the same shape", &e1->where, &e2->where);
7916	mpz_clear (s);
7917	return false;
7918	}
7919	}
7920
7921	mpz_clear (s);
7922	}
7923
7924	return true;
7925	}
7926
7927
7928	/* Resolve the expression in an ALLOCATE statement, doing the additional
7929	checks to see whether the expression is OK or not. The expression must
7930	have a trailing array reference that gives the size of the array. */
7931
7932	static bool
7933	resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
7934	{
7935	int i, pointer, allocatable, dimension, is_abstract;
7936	int codimension;
7937	bool coindexed;
7938	bool unlimited;
7939	symbol_attribute attr;
7940	gfc_ref *ref, *ref2;
7941	gfc_expr *e2;
7942	gfc_array_ref *ar;
7943	gfc_symbol *sym = NULL;
7944	gfc_alloc *a;
7945	gfc_component *c;
7946	bool t;
7947
7948	/* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7949	checking of coarrays. */
7950	for (ref = e->ref; ref; ref = ref->next)
7951	if (ref->next == NULL)
7952	break;
7953
7954	if (ref && ref->type == REF_ARRAY)
7955	ref->u.ar.in_allocate = true;
7956
7957	if (!gfc_resolve_expr (e))
7958	goto failure;
7959
7960	/* Make sure the expression is allocatable or a pointer. If it is
7961	pointer, the next-to-last reference must be a pointer. */
7962
7963	ref2 = NULL;
7964	if (e->symtree)
7965	sym = e->symtree->n.sym;
7966
7967	/* Check whether ultimate component is abstract and CLASS. */
7968	is_abstract = 0;
7969
7970	/* Is the allocate-object unlimited polymorphic? */
7971	unlimited = UNLIMITED_POLY(e);
7972
7973	if (e->expr_type != EXPR_VARIABLE)
7974	{
7975	allocatable = 0;
7976	attr = gfc_expr_attr (e);
7977	pointer = attr.pointer;
7978	dimension = attr.dimension;
7979	codimension = attr.codimension;
7980	}
7981	else
7982	{
7983	if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
7984	{
7985	allocatable = CLASS_DATA (sym)->attr.allocatable;
7986	pointer = CLASS_DATA (sym)->attr.class_pointer;
7987	dimension = CLASS_DATA (sym)->attr.dimension;
7988	codimension = CLASS_DATA (sym)->attr.codimension;
7989	is_abstract = CLASS_DATA (sym)->attr.abstract;
7990	}
7991	else
7992	{
7993	allocatable = sym->attr.allocatable;
7994	pointer = sym->attr.pointer;
7995	dimension = sym->attr.dimension;
7996	codimension = sym->attr.codimension;
7997	}
7998
7999	coindexed = false;
8000
8001	for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
8002	{
8003	switch (ref->type)
8004	{
8005	case REF_ARRAY:
8006	if (ref->u.ar.codimen > 0)
8007	{
8008	int n;
8009	for (n = ref->u.ar.dimen;
8010	n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
8011	if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
8012	{
8013	coindexed = true;
8014	break;
8015	}
8016	}
8017
8018	if (ref->next != NULL)
8019	pointer = 0;
8020	break;
8021
8022	case REF_COMPONENT:
8023	/* F2008, C644. */
8024	if (coindexed)
8025	{
8026	gfc_error ("Coindexed allocatable object at %L",
8027	&e->where);
8028	goto failure;
8029	}
8030
8031	c = ref->u.c.component;
8032	if (c->ts.type == BT_CLASS)
8033	{
8034	allocatable = CLASS_DATA (c)->attr.allocatable;
8035	pointer = CLASS_DATA (c)->attr.class_pointer;
8036	dimension = CLASS_DATA (c)->attr.dimension;
8037	codimension = CLASS_DATA (c)->attr.codimension;
8038	is_abstract = CLASS_DATA (c)->attr.abstract;
8039	}
8040	else
8041	{
8042	allocatable = c->attr.allocatable;
8043	pointer = c->attr.pointer;
8044	dimension = c->attr.dimension;
8045	codimension = c->attr.codimension;
8046	is_abstract = c->attr.abstract;
8047	}
8048	break;
8049
8050	case REF_SUBSTRING:
8051	case REF_INQUIRY:
8052	allocatable = 0;
8053	pointer = 0;
8054	break;
8055	}
8056	}
8057	}
8058
8059	/* Check for F08:C628 (F2018:C932). Each allocate-object shall be a data
8060	pointer or an allocatable variable. */
8061	if (allocatable == 0 && pointer == 0)
8062	{
8063	gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
8064	&e->where);
8065	goto failure;
8066	}
8067
8068	/* Some checks for the SOURCE tag. */
8069	if (code->expr3)
8070	{
8071	/* Check F03:C631. */
8072	if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
8073	{
8074	gfc_error ("Type of entity at %L is type incompatible with "
8075	"source-expr at %L", &e->where, &code->expr3->where);
8076	goto failure;
8077	}
8078
8079	/* Check F03:C632 and restriction following Note 6.18. */
8080	if (code->expr3->rank > 0 && !conformable_arrays (e1: code->expr3, e2: e))
8081	goto failure;
8082
8083	/* Check F03:C633. */
8084	if (code->expr3->ts.kind != e->ts.kind && !unlimited)
8085	{
8086	gfc_error ("The allocate-object at %L and the source-expr at %L "
8087	"shall have the same kind type parameter",
8088	&e->where, &code->expr3->where);
8089	goto failure;
8090	}
8091
8092	/* Check F2008, C642. */
8093	if (code->expr3->ts.type == BT_DERIVED
8094	&& ((codimension && gfc_expr_attr (code->expr3).lock_comp)
8095	|| (code->expr3->ts.u.derived->from_intmod
8096	== INTMOD_ISO_FORTRAN_ENV
8097	&& code->expr3->ts.u.derived->intmod_sym_id
8098	== ISOFORTRAN_LOCK_TYPE)))
8099	{
8100	gfc_error ("The source-expr at %L shall neither be of type "
8101	"LOCK_TYPE nor have a LOCK_TYPE component if "
8102	"allocate-object at %L is a coarray",
8103	&code->expr3->where, &e->where);
8104	goto failure;
8105	}
8106
8107	/* Check TS18508, C702/C703. */
8108	if (code->expr3->ts.type == BT_DERIVED
8109	&& ((codimension && gfc_expr_attr (code->expr3).event_comp)
8110	|| (code->expr3->ts.u.derived->from_intmod
8111	== INTMOD_ISO_FORTRAN_ENV
8112	&& code->expr3->ts.u.derived->intmod_sym_id
8113	== ISOFORTRAN_EVENT_TYPE)))
8114	{
8115	gfc_error ("The source-expr at %L shall neither be of type "
8116	"EVENT_TYPE nor have a EVENT_TYPE component if "
8117	"allocate-object at %L is a coarray",
8118	&code->expr3->where, &e->where);
8119	goto failure;
8120	}
8121	}
8122
8123	/* Check F08:C629. */
8124	if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
8125	&& !code->expr3)
8126	{
8127	gcc_assert (e->ts.type == BT_CLASS);
8128	gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
8129	"type-spec or source-expr", sym->name, &e->where);
8130	goto failure;
8131	}
8132
8133	/* Check F08:C632. */
8134	if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred
8135	&& !UNLIMITED_POLY (e))
8136	{
8137	int cmp;
8138
8139	if (!e->ts.u.cl->length)
8140	goto failure;
8141
8142	cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
8143	code->ext.alloc.ts.u.cl->length);
8144	if (cmp == 1 || cmp == -1 || cmp == -3)
8145	{
8146	gfc_error ("Allocating %s at %L with type-spec requires the same "
8147	"character-length parameter as in the declaration",
8148	sym->name, &e->where);
8149	goto failure;
8150	}
8151	}
8152
8153	/* In the variable definition context checks, gfc_expr_attr is used
8154	on the expression. This is fooled by the array specification
8155	present in e, thus we have to eliminate that one temporarily. */
8156	e2 = remove_last_array_ref (e);
8157	t = true;
8158	if (t && pointer)
8159	t = gfc_check_vardef_context (e2, true, true, false,
8160	_("ALLOCATE object"));
8161	if (t)
8162	t = gfc_check_vardef_context (e2, false, true, false,
8163	_("ALLOCATE object"));
8164	gfc_free_expr (e2);
8165	if (!t)
8166	goto failure;
8167
8168	code->ext.alloc.expr3_not_explicit = 0;
8169	if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
8170	&& !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
8171	{
8172	/* For class arrays, the initialization with SOURCE is done
8173	using _copy and trans_call. It is convenient to exploit that
8174	when the allocated type is different from the declared type but
8175	no SOURCE exists by setting expr3. */
8176	code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
8177	code->ext.alloc.expr3_not_explicit = 1;
8178	}
8179	else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED
8180	&& e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
8181	&& e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
8182	{
8183	/* We have to zero initialize the integer variable. */
8184	code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
8185	code->ext.alloc.expr3_not_explicit = 1;
8186	}
8187
8188	if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
8189	{
8190	/* Make sure the vtab symbol is present when
8191	the module variables are generated. */
8192	gfc_typespec ts = e->ts;
8193	if (code->expr3)
8194	ts = code->expr3->ts;
8195	else if (code->ext.alloc.ts.type == BT_DERIVED)
8196	ts = code->ext.alloc.ts;
8197
8198	/* Finding the vtab also publishes the type's symbol. Therefore this
8199	statement is necessary. */
8200	gfc_find_derived_vtab (ts.u.derived);
8201	}
8202	else if (unlimited && !UNLIMITED_POLY (code->expr3))
8203	{
8204	/* Again, make sure the vtab symbol is present when
8205	the module variables are generated. */
8206	gfc_typespec *ts = NULL;
8207	if (code->expr3)
8208	ts = &code->expr3->ts;
8209	else
8210	ts = &code->ext.alloc.ts;
8211
8212	gcc_assert (ts);
8213
8214	/* Finding the vtab also publishes the type's symbol. Therefore this
8215	statement is necessary. */
8216	gfc_find_vtab (ts);
8217	}
8218
8219	if (dimension == 0 && codimension == 0)
8220	goto success;
8221
8222	/* Make sure the last reference node is an array specification. */
8223
8224	if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
8225	|| (dimension && ref2->u.ar.dimen == 0))
8226	{
8227	/* F08:C633. */
8228	if (code->expr3)
8229	{
8230	if (!gfc_notify_std (GFC_STD_F2008, "Array specification required "
8231	"in ALLOCATE statement at %L", &e->where))
8232	goto failure;
8233	if (code->expr3->rank != 0)
8234	*array_alloc_wo_spec = true;
8235	else
8236	{
8237	gfc_error ("Array specification or array-valued SOURCE= "
8238	"expression required in ALLOCATE statement at %L",
8239	&e->where);
8240	goto failure;
8241	}
8242	}
8243	else
8244	{
8245	gfc_error ("Array specification required in ALLOCATE statement "
8246	"at %L", &e->where);
8247	goto failure;
8248	}
8249	}
8250
8251	/* Make sure that the array section reference makes sense in the
8252	context of an ALLOCATE specification. */
8253
8254	ar = &ref2->u.ar;
8255
8256	if (codimension)
8257	for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
8258	{
8259	switch (ar->dimen_type[i])
8260	{
8261	case DIMEN_THIS_IMAGE:
8262	gfc_error ("Coarray specification required in ALLOCATE statement "
8263	"at %L", &e->where);
8264	goto failure;
8265
8266	case DIMEN_RANGE:
8267	/* F2018:R937:
8268	* allocate-coshape-spec is [ lower-bound-expr : ] upper-bound-expr
8269	*/
8270	if (ar->start[i] == 0 || ar->end[i] == 0 || ar->stride[i] != NULL)
8271	{
8272	gfc_error ("Bad coarray specification in ALLOCATE statement "
8273	"at %L", &e->where);
8274	goto failure;
8275	}
8276	else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1)
8277	{
8278	gfc_error ("Upper cobound is less than lower cobound at %L",
8279	&ar->start[i]->where);
8280	goto failure;
8281	}
8282	break;
8283
8284	case DIMEN_ELEMENT:
8285	if (ar->start[i]->expr_type == EXPR_CONSTANT)
8286	{
8287	gcc_assert (ar->start[i]->ts.type == BT_INTEGER);
8288	if (mpz_cmp_si (ar->start[i]->value.integer, 1) < 0)
8289	{
8290	gfc_error ("Upper cobound is less than lower cobound "
8291	"of 1 at %L", &ar->start[i]->where);
8292	goto failure;
8293	}
8294	}
8295	break;
8296
8297	case DIMEN_STAR:
8298	break;
8299
8300	default:
8301	gfc_error ("Bad array specification in ALLOCATE statement at %L",
8302	&e->where);
8303	goto failure;
8304
8305	}
8306	}
8307	for (i = 0; i < ar->dimen; i++)
8308	{
8309	if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
8310	goto check_symbols;
8311
8312	switch (ar->dimen_type[i])
8313	{
8314	case DIMEN_ELEMENT:
8315	break;
8316
8317	case DIMEN_RANGE:
8318	if (ar->start[i] != NULL
8319	&& ar->end[i] != NULL
8320	&& ar->stride[i] == NULL)
8321	break;
8322
8323	/* Fall through. */
8324
8325	case DIMEN_UNKNOWN:
8326	case DIMEN_VECTOR:
8327	case DIMEN_STAR:
8328	case DIMEN_THIS_IMAGE:
8329	gfc_error ("Bad array specification in ALLOCATE statement at %L",
8330	&e->where);
8331	goto failure;
8332	}
8333
8334	check_symbols:
8335	for (a = code->ext.alloc.list; a; a = a->next)
8336	{
8337	sym = a->expr->symtree->n.sym;
8338
8339	/* TODO - check derived type components. */
8340	if (gfc_bt_struct (sym->ts.type) || sym->ts.type == BT_CLASS)
8341	continue;
8342
8343	if ((ar->start[i] != NULL
8344	&& gfc_find_sym_in_expr (sym, e: ar->start[i]))
8345	|| (ar->end[i] != NULL
8346	&& gfc_find_sym_in_expr (sym, e: ar->end[i])))
8347	{
8348	gfc_error ("%qs must not appear in the array specification at "
8349	"%L in the same ALLOCATE statement where it is "
8350	"itself allocated", sym->name, &ar->where);
8351	goto failure;
8352	}
8353	}
8354	}
8355
8356	for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
8357	{
8358	if (ar->dimen_type[i] == DIMEN_ELEMENT
8359	|| ar->dimen_type[i] == DIMEN_RANGE)
8360	{
8361	if (i == (ar->dimen + ar->codimen - 1))
8362	{
8363	gfc_error ("Expected %<*%> in coindex specification in ALLOCATE "
8364	"statement at %L", &e->where);
8365	goto failure;
8366	}
8367	continue;
8368	}
8369
8370	if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
8371	&& ar->stride[i] == NULL)
8372	break;
8373
8374	gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
8375	&e->where);
8376	goto failure;
8377	}
8378
8379	success:
8380	return true;
8381
8382	failure:
8383	return false;
8384	}
8385
8386
8387	static void
8388	resolve_allocate_deallocate (gfc_code *code, const char *fcn)
8389	{
8390	gfc_expr *stat, *errmsg, *pe, *qe;
8391	gfc_alloc *a, *p, *q;
8392
8393	stat = code->expr1;
8394	errmsg = code->expr2;
8395
8396	/* Check the stat variable. */
8397	if (stat)
8398	{
8399	if (!gfc_check_vardef_context (stat, false, false, false,
8400	_("STAT variable")))
8401	goto done_stat;
8402
8403	if (stat->ts.type != BT_INTEGER
8404	|| stat->rank > 0)
8405	gfc_error ("Stat-variable at %L must be a scalar INTEGER "
8406	"variable", &stat->where);
8407
8408	if (stat->expr_type == EXPR_CONSTANT || stat->symtree == NULL)
8409	goto done_stat;
8410
8411	/* F2018:9.7.4: The stat-variable shall not be allocated or deallocated
8412	* within the ALLOCATE or DEALLOCATE statement in which it appears ...
8413	*/
8414	for (p = code->ext.alloc.list; p; p = p->next)
8415	if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
8416	{
8417	gfc_ref *ref1, *ref2;
8418	bool found = true;
8419
8420	for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
8421	ref1 = ref1->next, ref2 = ref2->next)
8422	{
8423	if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
8424	continue;
8425	if (ref1->u.c.component->name != ref2->u.c.component->name)
8426	{
8427	found = false;
8428	break;
8429	}
8430	}
8431
8432	if (found)
8433	{
8434	gfc_error ("Stat-variable at %L shall not be %sd within "
8435	"the same %s statement", &stat->where, fcn, fcn);
8436	break;
8437	}
8438	}
8439	}
8440
8441	done_stat:
8442
8443	/* Check the errmsg variable. */
8444	if (errmsg)
8445	{
8446	if (!stat)
8447	gfc_warning (opt: 0, "ERRMSG at %L is useless without a STAT tag",
8448	&errmsg->where);
8449
8450	if (!gfc_check_vardef_context (errmsg, false, false, false,
8451	_("ERRMSG variable")))
8452	goto done_errmsg;
8453
8454	/* F18:R928 alloc-opt is ERRMSG = errmsg-variable
8455	F18:R930 errmsg-variable is scalar-default-char-variable
8456	F18:R906 default-char-variable is variable
8457	F18:C906 default-char-variable shall be default character. */
8458	if (errmsg->ts.type != BT_CHARACTER
8459	|| errmsg->rank > 0
8460	|| errmsg->ts.kind != gfc_default_character_kind)
8461	gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
8462	"variable", &errmsg->where);
8463
8464	if (errmsg->expr_type == EXPR_CONSTANT || errmsg->symtree == NULL)
8465	goto done_errmsg;
8466
8467	/* F2018:9.7.5: The errmsg-variable shall not be allocated or deallocated
8468	* within the ALLOCATE or DEALLOCATE statement in which it appears ...
8469	*/
8470	for (p = code->ext.alloc.list; p; p = p->next)
8471	if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
8472	{
8473	gfc_ref *ref1, *ref2;
8474	bool found = true;
8475
8476	for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
8477	ref1 = ref1->next, ref2 = ref2->next)
8478	{
8479	if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
8480	continue;
8481	if (ref1->u.c.component->name != ref2->u.c.component->name)
8482	{
8483	found = false;
8484	break;
8485	}
8486	}
8487
8488	if (found)
8489	{
8490	gfc_error ("Errmsg-variable at %L shall not be %sd within "
8491	"the same %s statement", &errmsg->where, fcn, fcn);
8492	break;
8493	}
8494	}
8495	}
8496
8497	done_errmsg:
8498
8499	/* Check that an allocate-object appears only once in the statement. */
8500
8501	for (p = code->ext.alloc.list; p; p = p->next)
8502	{
8503	pe = p->expr;
8504	for (q = p->next; q; q = q->next)
8505	{
8506	qe = q->expr;
8507	if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
8508	{
8509	/* This is a potential collision. */
8510	gfc_ref *pr = pe->ref;
8511	gfc_ref *qr = qe->ref;
8512
8513	/* Follow the references until
8514	a) They start to differ, in which case there is no error;
8515	you can deallocate a%b and a%c in a single statement
8516	b) Both of them stop, which is an error
8517	c) One of them stops, which is also an error. */
8518	while (1)
8519	{
8520	if (pr == NULL && qr == NULL)
8521	{
8522	gfc_error ("Allocate-object at %L also appears at %L",
8523	&pe->where, &qe->where);
8524	break;
8525	}
8526	else if (pr != NULL && qr == NULL)
8527	{
8528	gfc_error ("Allocate-object at %L is subobject of"
8529	" object at %L", &pe->where, &qe->where);
8530	break;
8531	}
8532	else if (pr == NULL && qr != NULL)
8533	{
8534	gfc_error ("Allocate-object at %L is subobject of"
8535	" object at %L", &qe->where, &pe->where);
8536	break;
8537	}
8538	/* Here, pr != NULL && qr != NULL */
8539	gcc_assert(pr->type == qr->type);
8540	if (pr->type == REF_ARRAY)
8541	{
8542	/* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
8543	which are legal. */
8544	gcc_assert (qr->type == REF_ARRAY);
8545
8546	if (pr->next && qr->next)
8547	{
8548	int i;
8549	gfc_array_ref *par = &(pr->u.ar);
8550	gfc_array_ref *qar = &(qr->u.ar);
8551
8552	for (i=0; i<par->dimen; i++)
8553	{
8554	if ((par->start[i] != NULL
8555	|| qar->start[i] != NULL)
8556	&& gfc_dep_compare_expr (par->start[i],
8557	qar->start[i]) != 0)
8558	goto break_label;
8559	}
8560	}
8561	}
8562	else
8563	{
8564	if (pr->u.c.component->name != qr->u.c.component->name)
8565	break;
8566	}
8567
8568	pr = pr->next;
8569	qr = qr->next;
8570	}
8571	break_label:
8572	;
8573	}
8574	}
8575	}
8576
8577	if (strcmp (s1: fcn, s2: "ALLOCATE") == 0)
8578	{
8579	bool arr_alloc_wo_spec = false;
8580
8581	/* Resolving the expr3 in the loop over all objects to allocate would
8582	execute loop invariant code for each loop item. Therefore do it just
8583	once here. */
8584	if (code->expr3 && code->expr3->mold
8585	&& code->expr3->ts.type == BT_DERIVED)
8586	{
8587	/* Default initialization via MOLD (non-polymorphic). */
8588	gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
8589	if (rhs != NULL)
8590	{
8591	gfc_resolve_expr (e: rhs);
8592	gfc_free_expr (code->expr3);
8593	code->expr3 = rhs;
8594	}
8595	}
8596	for (a = code->ext.alloc.list; a; a = a->next)
8597	resolve_allocate_expr (e: a->expr, code, array_alloc_wo_spec: &arr_alloc_wo_spec);
8598
8599	if (arr_alloc_wo_spec && code->expr3)
8600	{
8601	/* Mark the allocate to have to take the array specification
8602	from the expr3. */
8603	code->ext.alloc.arr_spec_from_expr3 = 1;
8604	}
8605	}
8606	else
8607	{
8608	for (a = code->ext.alloc.list; a; a = a->next)
8609	resolve_deallocate_expr (e: a->expr);
8610	}
8611	}
8612
8613
8614	/************ SELECT CASE resolution subroutines ************/
8615
8616	/* Callback function for our mergesort variant. Determines interval
8617	overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
8618	op1 > op2. Assumes we're not dealing with the default case.
8619	We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
8620	There are nine situations to check. */
8621
8622	static int
8623	compare_cases (const gfc_case *op1, const gfc_case *op2)
8624	{
8625	int retval;
8626
8627	if (op1->low == NULL) /* op1 = (:L) */
8628	{
8629	/* op2 = (:N), so overlap. */
8630	retval = 0;
8631	/* op2 = (M:) or (M:N), L < M */
8632	if (op2->low != NULL
8633	&& gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
8634	retval = -1;
8635	}
8636	else if (op1->high == NULL) /* op1 = (K:) */
8637	{
8638	/* op2 = (M:), so overlap. */
8639	retval = 0;
8640	/* op2 = (:N) or (M:N), K > N */
8641	if (op2->high != NULL
8642	&& gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
8643	retval = 1;
8644	}
8645	else /* op1 = (K:L) */
8646	{
8647	if (op2->low == NULL) /* op2 = (:N), K > N */
8648	retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
8649	? 1 : 0;
8650	else if (op2->high == NULL) /* op2 = (M:), L < M */
8651	retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
8652	? -1 : 0;
8653	else /* op2 = (M:N) */
8654	{
8655	retval = 0;
8656	/* L < M */
8657	if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
8658	retval = -1;
8659	/* K > N */
8660	else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
8661	retval = 1;
8662	}
8663	}
8664
8665	return retval;
8666	}
8667
8668
8669	/* Merge-sort a double linked case list, detecting overlap in the
8670	process. LIST is the head of the double linked case list before it
8671	is sorted. Returns the head of the sorted list if we don't see any
8672	overlap, or NULL otherwise. */
8673
8674	static gfc_case *
8675	check_case_overlap (gfc_case *list)
8676	{
8677	gfc_case *p, *q, *e, *tail;
8678	int insize, nmerges, psize, qsize, cmp, overlap_seen;
8679
8680	/* If the passed list was empty, return immediately. */
8681	if (!list)
8682	return NULL;
8683
8684	overlap_seen = 0;
8685	insize = 1;
8686
8687	/* Loop unconditionally. The only exit from this loop is a return
8688	statement, when we've finished sorting the case list. */
8689	for (;;)
8690	{
8691	p = list;
8692	list = NULL;
8693	tail = NULL;
8694
8695	/* Count the number of merges we do in this pass. */
8696	nmerges = 0;
8697
8698	/* Loop while there exists a merge to be done. */
8699	while (p)
8700	{
8701	int i;
8702
8703	/* Count this merge. */
8704	nmerges++;
8705
8706	/* Cut the list in two pieces by stepping INSIZE places
8707	forward in the list, starting from P. */
8708	psize = 0;
8709	q = p;
8710	for (i = 0; i < insize; i++)
8711	{
8712	psize++;
8713	q = q->right;
8714	if (!q)
8715	break;
8716	}
8717	qsize = insize;
8718
8719	/* Now we have two lists. Merge them! */
8720	while (psize > 0 || (qsize > 0 && q != NULL))
8721	{
8722	/* See from which the next case to merge comes from. */
8723	if (psize == 0)
8724	{
8725	/* P is empty so the next case must come from Q. */
8726	e = q;
8727	q = q->right;
8728	qsize--;
8729	}
8730	else if (qsize == 0 || q == NULL)
8731	{
8732	/* Q is empty. */
8733	e = p;
8734	p = p->right;
8735	psize--;
8736	}
8737	else
8738	{
8739	cmp = compare_cases (op1: p, op2: q);
8740	if (cmp < 0)
8741	{
8742	/* The whole case range for P is less than the
8743	one for Q. */
8744	e = p;
8745	p = p->right;
8746	psize--;
8747	}
8748	else if (cmp > 0)
8749	{
8750	/* The whole case range for Q is greater than
8751	the case range for P. */
8752	e = q;
8753	q = q->right;
8754	qsize--;
8755	}
8756	else
8757	{
8758	/* The cases overlap, or they are the same
8759	element in the list. Either way, we must
8760	issue an error and get the next case from P. */
8761	/* FIXME: Sort P and Q by line number. */
8762	gfc_error ("CASE label at %L overlaps with CASE "
8763	"label at %L", &p->where, &q->where);
8764	overlap_seen = 1;
8765	e = p;
8766	p = p->right;
8767	psize--;
8768	}
8769	}
8770
8771	/* Add the next element to the merged list. */
8772	if (tail)
8773	tail->right = e;
8774	else
8775	list = e;
8776	e->left = tail;
8777	tail = e;
8778	}
8779
8780	/* P has now stepped INSIZE places along, and so has Q. So
8781	they're the same. */
8782	p = q;
8783	}
8784	tail->right = NULL;
8785
8786	/* If we have done only one merge or none at all, we've
8787	finished sorting the cases. */
8788	if (nmerges <= 1)
8789	{
8790	if (!overlap_seen)
8791	return list;
8792	else
8793	return NULL;
8794	}
8795
8796	/* Otherwise repeat, merging lists twice the size. */
8797	insize *= 2;
8798	}
8799	}
8800
8801
8802	/* Check to see if an expression is suitable for use in a CASE statement.
8803	Makes sure that all case expressions are scalar constants of the same
8804	type. Return false if anything is wrong. */
8805
8806	static bool
8807	validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
8808	{
8809	if (e == NULL) return true;
8810
8811	if (e->ts.type != case_expr->ts.type)
8812	{
8813	gfc_error ("Expression in CASE statement at %L must be of type %s",
8814	&e->where, gfc_basic_typename (case_expr->ts.type));
8815	return false;
8816	}
8817
8818	/* C805 (R808) For a given case-construct, each case-value shall be of
8819	the same type as case-expr. For character type, length differences
8820	are allowed, but the kind type parameters shall be the same. */
8821
8822	if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
8823	{
8824	gfc_error ("Expression in CASE statement at %L must be of kind %d",
8825	&e->where, case_expr->ts.kind);
8826	return false;
8827	}
8828
8829	/* Convert the case value kind to that of case expression kind,
8830	if needed */
8831
8832	if (e->ts.kind != case_expr->ts.kind)
8833	gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
8834
8835	if (e->rank != 0)
8836	{
8837	gfc_error ("Expression in CASE statement at %L must be scalar",
8838	&e->where);
8839	return false;
8840	}
8841
8842	return true;
8843	}
8844
8845
8846	/* Given a completely parsed select statement, we:
8847
8848	- Validate all expressions and code within the SELECT.
8849	- Make sure that the selection expression is not of the wrong type.
8850	- Make sure that no case ranges overlap.
8851	- Eliminate unreachable cases and unreachable code resulting from
8852	removing case labels.
8853
8854	The standard does allow unreachable cases, e.g. CASE (5:3). But
8855	they are a hassle for code generation, and to prevent that, we just
8856	cut them out here. This is not necessary for overlapping cases
8857	because they are illegal and we never even try to generate code.
8858
8859	We have the additional caveat that a SELECT construct could have
8860	been a computed GOTO in the source code. Fortunately we can fairly
8861	easily work around that here: The case_expr for a "real" SELECT CASE
8862	is in code->expr1, but for a computed GOTO it is in code->expr2. All
8863	we have to do is make sure that the case_expr is a scalar integer
8864	expression. */
8865
8866	static void
8867	resolve_select (gfc_code *code, bool select_type)
8868	{
8869	gfc_code *body;
8870	gfc_expr *case_expr;
8871	gfc_case *cp, *default_case, *tail, *head;
8872	int seen_unreachable;
8873	int seen_logical;
8874	int ncases;
8875	bt type;
8876	bool t;
8877
8878	if (code->expr1 == NULL)
8879	{
8880	/* This was actually a computed GOTO statement. */
8881	case_expr = code->expr2;
8882	if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
8883	gfc_error ("Selection expression in computed GOTO statement "
8884	"at %L must be a scalar integer expression",
8885	&case_expr->where);
8886
8887	/* Further checking is not necessary because this SELECT was built
8888	by the compiler, so it should always be OK. Just move the
8889	case_expr from expr2 to expr so that we can handle computed
8890	GOTOs as normal SELECTs from here on. */
8891	code->expr1 = code->expr2;
8892	code->expr2 = NULL;
8893	return;
8894	}
8895
8896	case_expr = code->expr1;
8897	type = case_expr->ts.type;
8898
8899	/* F08:C830. */
8900	if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
8901	{
8902	gfc_error ("Argument of SELECT statement at %L cannot be %s",
8903	&case_expr->where, gfc_typename (case_expr));
8904
8905	/* Punt. Going on here just produce more garbage error messages. */
8906	return;
8907	}
8908
8909	/* F08:R842. */
8910	if (!select_type && case_expr->rank != 0)
8911	{
8912	gfc_error ("Argument of SELECT statement at %L must be a scalar "
8913	"expression", &case_expr->where);
8914
8915	/* Punt. */
8916	return;
8917	}
8918
8919	/* Raise a warning if an INTEGER case value exceeds the range of
8920	the case-expr. Later, all expressions will be promoted to the
8921	largest kind of all case-labels. */
8922
8923	if (type == BT_INTEGER)
8924	for (body = code->block; body; body = body->block)
8925	for (cp = body->ext.block.case_list; cp; cp = cp->next)
8926	{
8927	if (cp->low
8928	&& gfc_check_integer_range (p: cp->low->value.integer,
8929	kind: case_expr->ts.kind) != ARITH_OK)
8930	gfc_warning (opt: 0, "Expression in CASE statement at %L is "
8931	"not in the range of %s", &cp->low->where,
8932	gfc_typename (case_expr));
8933
8934	if (cp->high
8935	&& cp->low != cp->high
8936	&& gfc_check_integer_range (p: cp->high->value.integer,
8937	kind: case_expr->ts.kind) != ARITH_OK)
8938	gfc_warning (opt: 0, "Expression in CASE statement at %L is "
8939	"not in the range of %s", &cp->high->where,
8940	gfc_typename (case_expr));
8941	}
8942
8943	/* PR 19168 has a long discussion concerning a mismatch of the kinds
8944	of the SELECT CASE expression and its CASE values. Walk the lists
8945	of case values, and if we find a mismatch, promote case_expr to
8946	the appropriate kind. */
8947
8948	if (type == BT_LOGICAL || type == BT_INTEGER)
8949	{
8950	for (body = code->block; body; body = body->block)
8951	{
8952	/* Walk the case label list. */
8953	for (cp = body->ext.block.case_list; cp; cp = cp->next)
8954	{
8955	/* Intercept the DEFAULT case. It does not have a kind. */
8956	if (cp->low == NULL && cp->high == NULL)
8957	continue;
8958
8959	/* Unreachable case ranges are discarded, so ignore. */
8960	if (cp->low != NULL && cp->high != NULL
8961	&& cp->low != cp->high
8962	&& gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
8963	continue;
8964
8965	if (cp->low != NULL
8966	&& case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
8967	gfc_convert_type_warn (case_expr, &cp->low->ts, 1, 0);
8968
8969	if (cp->high != NULL
8970	&& case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
8971	gfc_convert_type_warn (case_expr, &cp->high->ts, 1, 0);
8972	}
8973	}
8974	}
8975
8976	/* Assume there is no DEFAULT case. */
8977	default_case = NULL;
8978	head = tail = NULL;
8979	ncases = 0;
8980	seen_logical = 0;
8981
8982	for (body = code->block; body; body = body->block)
8983	{
8984	/* Assume the CASE list is OK, and all CASE labels can be matched. */
8985	t = true;
8986	seen_unreachable = 0;
8987
8988	/* Walk the case label list, making sure that all case labels
8989	are legal. */
8990	for (cp = body->ext.block.case_list; cp; cp = cp->next)
8991	{
8992	/* Count the number of cases in the whole construct. */
8993	ncases++;
8994
8995	/* Intercept the DEFAULT case. */
8996	if (cp->low == NULL && cp->high == NULL)
8997	{
8998	if (default_case != NULL)
8999	{
9000	gfc_error ("The DEFAULT CASE at %L cannot be followed "
9001	"by a second DEFAULT CASE at %L",
9002	&default_case->where, &cp->where);
9003	t = false;
9004	break;
9005	}
9006	else
9007	{
9008	default_case = cp;
9009	continue;
9010	}
9011	}
9012
9013	/* Deal with single value cases and case ranges. Errors are
9014	issued from the validation function. */
9015	if (!validate_case_label_expr (e: cp->low, case_expr)
9016	|| !validate_case_label_expr (e: cp->high, case_expr))
9017	{
9018	t = false;
9019	break;
9020	}
9021
9022	if (type == BT_LOGICAL
9023	&& ((cp->low == NULL || cp->high == NULL)
9024	|| cp->low != cp->high))
9025	{
9026	gfc_error ("Logical range in CASE statement at %L is not "
9027	"allowed",
9028	cp->low ? &cp->low->where : &cp->high->where);
9029	t = false;
9030	break;
9031	}
9032
9033	if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
9034	{
9035	int value;
9036	value = cp->low->value.logical == 0 ? 2 : 1;
9037	if (value & seen_logical)
9038	{
9039	gfc_error ("Constant logical value in CASE statement "
9040	"is repeated at %L",
9041	&cp->low->where);
9042	t = false;
9043	break;
9044	}
9045	seen_logical |= value;
9046	}
9047
9048	if (cp->low != NULL && cp->high != NULL
9049	&& cp->low != cp->high
9050	&& gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
9051	{
9052	if (warn_surprising)
9053	gfc_warning (opt: OPT_Wsurprising,
9054	"Range specification at %L can never be matched",
9055	&cp->where);
9056
9057	cp->unreachable = 1;
9058	seen_unreachable = 1;
9059	}
9060	else
9061	{
9062	/* If the case range can be matched, it can also overlap with
9063	other cases. To make sure it does not, we put it in a
9064	double linked list here. We sort that with a merge sort
9065	later on to detect any overlapping cases. */
9066	if (!head)
9067	{
9068	head = tail = cp;
9069	head->right = head->left = NULL;
9070	}
9071	else
9072	{
9073	tail->right = cp;
9074	tail->right->left = tail;
9075	tail = tail->right;
9076	tail->right = NULL;
9077	}
9078	}
9079	}
9080
9081	/* It there was a failure in the previous case label, give up
9082	for this case label list. Continue with the next block. */
9083	if (!t)
9084	continue;
9085
9086	/* See if any case labels that are unreachable have been seen.
9087	If so, we eliminate them. This is a bit of a kludge because
9088	the case lists for a single case statement (label) is a
9089	single forward linked lists. */
9090	if (seen_unreachable)
9091	{
9092	/* Advance until the first case in the list is reachable. */
9093	while (body->ext.block.case_list != NULL
9094	&& body->ext.block.case_list->unreachable)
9095	{
9096	gfc_case *n = body->ext.block.case_list;
9097	body->ext.block.case_list = body->ext.block.case_list->next;
9098	n->next = NULL;
9099	gfc_free_case_list (n);
9100	}
9101
9102	/* Strip all other unreachable cases. */
9103	if (body->ext.block.case_list)
9104	{
9105	for (cp = body->ext.block.case_list; cp && cp->next; cp = cp->next)
9106	{
9107	if (cp->next->unreachable)
9108	{
9109	gfc_case *n = cp->next;
9110	cp->next = cp->next->next;
9111	n->next = NULL;
9112	gfc_free_case_list (n);
9113	}
9114	}
9115	}
9116	}
9117	}
9118
9119	/* See if there were overlapping cases. If the check returns NULL,
9120	there was overlap. In that case we don't do anything. If head
9121	is non-NULL, we prepend the DEFAULT case. The sorted list can
9122	then used during code generation for SELECT CASE constructs with
9123	a case expression of a CHARACTER type. */
9124	if (head)
9125	{
9126	head = check_case_overlap (list: head);
9127
9128	/* Prepend the default_case if it is there. */
9129	if (head != NULL && default_case)
9130	{
9131	default_case->left = NULL;
9132	default_case->right = head;
9133	head->left = default_case;
9134	}
9135	}
9136
9137	/* Eliminate dead blocks that may be the result if we've seen
9138	unreachable case labels for a block. */
9139	for (body = code; body && body->block; body = body->block)
9140	{
9141	if (body->block->ext.block.case_list == NULL)
9142	{
9143	/* Cut the unreachable block from the code chain. */
9144	gfc_code *c = body->block;
9145	body->block = c->block;
9146
9147	/* Kill the dead block, but not the blocks below it. */
9148	c->block = NULL;
9149	gfc_free_statements (c);
9150	}
9151	}
9152
9153	/* More than two cases is legal but insane for logical selects.
9154	Issue a warning for it. */
9155	if (warn_surprising && type == BT_LOGICAL && ncases > 2)
9156	gfc_warning (opt: OPT_Wsurprising,
9157	"Logical SELECT CASE block at %L has more that two cases",
9158	&code->loc);
9159	}
9160
9161
9162	/* Check if a derived type is extensible. */
9163
9164	bool
9165	gfc_type_is_extensible (gfc_symbol *sym)
9166	{
9167	return !(sym->attr.is_bind_c || sym->attr.sequence
9168	|| (sym->attr.is_class
9169	&& sym->components->ts.u.derived->attr.unlimited_polymorphic));
9170	}
9171
9172
9173	static void
9174	resolve_types (gfc_namespace *ns);
9175
9176	/* Resolve an associate-name: Resolve target and ensure the type-spec is
9177	correct as well as possibly the array-spec. */
9178
9179	static void
9180	resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
9181	{
9182	gfc_expr* target;
9183	bool parentheses = false;
9184
9185	gcc_assert (sym->assoc);
9186	gcc_assert (sym->attr.flavor == FL_VARIABLE);
9187
9188	/* If this is for SELECT TYPE, the target may not yet be set. In that
9189	case, return. Resolution will be called later manually again when
9190	this is done. */
9191	target = sym->assoc->target;
9192	if (!target)
9193	return;
9194	gcc_assert (!sym->assoc->dangling);
9195
9196	if (target->expr_type == EXPR_OP
9197	&& target->value.op.op == INTRINSIC_PARENTHESES
9198	&& target->value.op.op1->expr_type == EXPR_VARIABLE)
9199	{
9200	sym->assoc->target = gfc_copy_expr (target->value.op.op1);
9201	gfc_free_expr (target);
9202	target = sym->assoc->target;
9203	parentheses = true;
9204	}
9205
9206	if (resolve_target && !gfc_resolve_expr (e: target))
9207	return;
9208
9209	/* For variable targets, we get some attributes from the target. */
9210	if (target->expr_type == EXPR_VARIABLE)
9211	{
9212	gfc_symbol *tsym, *dsym;
9213
9214	gcc_assert (target->symtree);
9215	tsym = target->symtree->n.sym;
9216
9217	if (gfc_expr_attr (target).proc_pointer)
9218	{
9219	gfc_error ("Associating entity %qs at %L is a procedure pointer",
9220	tsym->name, &target->where);
9221	return;
9222	}
9223
9224	if (tsym->attr.flavor == FL_PROCEDURE && tsym->generic
9225	&& (dsym = gfc_find_dt_in_generic (tsym)) != NULL
9226	&& dsym->attr.flavor == FL_DERIVED)
9227	{
9228	gfc_error ("Derived type %qs cannot be used as a variable at %L",
9229	tsym->name, &target->where);
9230	return;
9231	}
9232
9233	if (tsym->attr.flavor == FL_PROCEDURE)
9234	{
9235	bool is_error = true;
9236	if (tsym->attr.function && tsym->result == tsym)
9237	for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent)
9238	if (tsym == ns->proc_name)
9239	{
9240	is_error = false;
9241	break;
9242	}
9243	if (is_error)
9244	{
9245	gfc_error ("Associating entity %qs at %L is a procedure name",
9246	tsym->name, &target->where);
9247	return;
9248	}
9249	}
9250
9251	sym->attr.asynchronous = tsym->attr.asynchronous;
9252	sym->attr.volatile_ = tsym->attr.volatile_;
9253
9254	sym->attr.target = tsym->attr.target
9255	|| gfc_expr_attr (target).pointer;
9256	if (is_subref_array (target))
9257	sym->attr.subref_array_pointer = 1;
9258	}
9259	else if (target->ts.type == BT_PROCEDURE)
9260	{
9261	gfc_error ("Associating selector-expression at %L yields a procedure",
9262	&target->where);
9263	return;
9264	}
9265
9266	if (target->expr_type == EXPR_NULL)
9267	{
9268	gfc_error ("Selector at %L cannot be NULL()", &target->where);
9269	return;
9270	}
9271	else if (target->ts.type == BT_UNKNOWN)
9272	{
9273	gfc_error ("Selector at %L has no type", &target->where);
9274	return;
9275	}
9276
9277	/* Get type if this was not already set. Note that it can be
9278	some other type than the target in case this is a SELECT TYPE
9279	selector! So we must not update when the type is already there. */
9280	if (sym->ts.type == BT_UNKNOWN)
9281	sym->ts = target->ts;
9282
9283	gcc_assert (sym->ts.type != BT_UNKNOWN);
9284
9285	/* See if this is a valid association-to-variable. */
9286	sym->assoc->variable = ((target->expr_type == EXPR_VARIABLE
9287	&& !parentheses
9288	&& !gfc_has_vector_subscript (target))
9289	|| gfc_is_ptr_fcn (target));
9290
9291	/* Finally resolve if this is an array or not. */
9292	if (sym->attr.dimension && target->rank == 0)
9293	{
9294	/* primary.cc makes the assumption that a reference to an associate
9295	name followed by a left parenthesis is an array reference. */
9296	if (sym->ts.type != BT_CHARACTER)
9297	gfc_error ("Associate-name %qs at %L is used as array",
9298	sym->name, &sym->declared_at);
9299	sym->attr.dimension = 0;
9300	return;
9301	}
9302
9303	/* We cannot deal with class selectors that need temporaries. */
9304	if (target->ts.type == BT_CLASS
9305	&& gfc_ref_needs_temporary_p (target->ref))
9306	{
9307	gfc_error ("CLASS selector at %L needs a temporary which is not "
9308	"yet implemented", &target->where);
9309	return;
9310	}
9311
9312	if (target->ts.type == BT_CLASS)
9313	gfc_fix_class_refs (e: target);
9314
9315	if (target->rank != 0 && !sym->attr.select_rank_temporary)
9316	{
9317	gfc_array_spec *as;
9318	/* The rank may be incorrectly guessed at parsing, therefore make sure
9319	it is corrected now. */
9320	if (sym->ts.type != BT_CLASS && !sym->as)
9321	{
9322	if (!sym->as)
9323	sym->as = gfc_get_array_spec ();
9324	as = sym->as;
9325	as->rank = target->rank;
9326	as->type = AS_DEFERRED;
9327	as->corank = gfc_get_corank (target);
9328	sym->attr.dimension = 1;
9329	if (as->corank != 0)
9330	sym->attr.codimension = 1;
9331	}
9332	else if (sym->ts.type == BT_CLASS
9333	&& CLASS_DATA (sym) && !CLASS_DATA (sym)->as)
9334	{
9335	if (!CLASS_DATA (sym)->as)
9336	CLASS_DATA (sym)->as = gfc_get_array_spec ();
9337	as = CLASS_DATA (sym)->as;
9338	as->rank = target->rank;
9339	as->type = AS_DEFERRED;
9340	as->corank = gfc_get_corank (target);
9341	CLASS_DATA (sym)->attr.dimension = 1;
9342	if (as->corank != 0)
9343	CLASS_DATA (sym)->attr.codimension = 1;
9344	}
9345	}
9346	else if (!sym->attr.select_rank_temporary)
9347	{
9348	/* target's rank is 0, but the type of the sym is still array valued,
9349	which has to be corrected. */
9350	if (sym->ts.type == BT_CLASS && sym->ts.u.derived
9351	&& CLASS_DATA (sym) && CLASS_DATA (sym)->as)
9352	{
9353	gfc_array_spec *as;
9354	symbol_attribute attr;
9355	/* The associated variable's type is still the array type
9356	correct this now. */
9357	gfc_typespec *ts = &target->ts;
9358	gfc_ref *ref;
9359	gfc_component *c;
9360	for (ref = target->ref; ref != NULL; ref = ref->next)
9361	{
9362	switch (ref->type)
9363	{
9364	case REF_COMPONENT:
9365	ts = &ref->u.c.component->ts;
9366	break;
9367	case REF_ARRAY:
9368	if (ts->type == BT_CLASS)
9369	ts = &ts->u.derived->components->ts;
9370	break;
9371	default:
9372	break;
9373	}
9374	}
9375	/* Create a scalar instance of the current class type. Because the
9376	rank of a class array goes into its name, the type has to be
9377	rebuild. The alternative of (re-)setting just the attributes
9378	and as in the current type, destroys the type also in other
9379	places. */
9380	as = NULL;
9381	sym->ts = *ts;
9382	sym->ts.type = BT_CLASS;
9383	attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
9384	attr.class_ok = 0;
9385	attr.associate_var = 1;
9386	attr.dimension = attr.codimension = 0;
9387	attr.class_pointer = 1;
9388	if (!gfc_build_class_symbol (&sym->ts, &attr, &as))
9389	gcc_unreachable ();
9390	/* Make sure the _vptr is set. */
9391	c = gfc_find_component (sym->ts.u.derived, "_vptr", true, true, NULL);
9392	if (c->ts.u.derived == NULL)
9393	c->ts.u.derived = gfc_find_derived_vtab (sym->ts.u.derived);
9394	CLASS_DATA (sym)->attr.pointer = 1;
9395	CLASS_DATA (sym)->attr.class_pointer = 1;
9396	gfc_set_sym_referenced (sym->ts.u.derived);
9397	gfc_commit_symbol (sym->ts.u.derived);
9398	/* _vptr now has the _vtab in it, change it to the _vtype. */
9399	if (c->ts.u.derived->attr.vtab)
9400	c->ts.u.derived = c->ts.u.derived->ts.u.derived;
9401	c->ts.u.derived->ns->types_resolved = 0;
9402	resolve_types (ns: c->ts.u.derived->ns);
9403	}
9404	}
9405
9406	/* Mark this as an associate variable. */
9407	sym->attr.associate_var = 1;
9408
9409	/* Fix up the type-spec for CHARACTER types. */
9410	if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
9411	{
9412	if (!sym->ts.u.cl)
9413	sym->ts.u.cl = target->ts.u.cl;
9414
9415	if (sym->ts.deferred
9416	&& sym->ts.u.cl == target->ts.u.cl)
9417	{
9418	sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
9419	sym->ts.deferred = 1;
9420	}
9421
9422	if (!sym->ts.u.cl->length
9423	&& !sym->ts.deferred
9424	&& target->expr_type == EXPR_CONSTANT)
9425	{
9426	sym->ts.u.cl->length =
9427	gfc_get_int_expr (gfc_charlen_int_kind, NULL,
9428	target->value.character.length);
9429	}
9430	else if ((!sym->ts.u.cl->length
9431	|| sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9432	&& target->expr_type != EXPR_VARIABLE)
9433	{
9434	if (!sym->ts.deferred)
9435	{
9436	sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
9437	sym->ts.deferred = 1;
9438	}
9439
9440	/* This is reset in trans-stmt.cc after the assignment
9441	of the target expression to the associate name. */
9442	sym->attr.allocatable = 1;
9443	}
9444	}
9445
9446	/* If the target is a good class object, so is the associate variable. */
9447	if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
9448	sym->attr.class_ok = 1;
9449	}
9450
9451
9452	/* Ensure that SELECT TYPE expressions have the correct rank and a full
9453	array reference, where necessary. The symbols are artificial and so
9454	the dimension attribute and arrayspec can also be set. In addition,
9455	sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
9456	This is corrected here as well.*/
9457
9458	static void
9459	fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2,
9460	int rank, gfc_ref *ref)
9461	{
9462	gfc_ref *nref = (*expr1)->ref;
9463	gfc_symbol *sym1 = (*expr1)->symtree->n.sym;
9464	gfc_symbol *sym2;
9465	gfc_expr *selector = gfc_copy_expr (expr2);
9466
9467	(*expr1)->rank = rank;
9468	if (selector)
9469	{
9470	gfc_resolve_expr (e: selector);
9471	if (selector->expr_type == EXPR_OP
9472	&& selector->value.op.op == INTRINSIC_PARENTHESES)
9473	sym2 = selector->value.op.op1->symtree->n.sym;
9474	else if (selector->expr_type == EXPR_VARIABLE
9475	|| selector->expr_type == EXPR_FUNCTION)
9476	sym2 = selector->symtree->n.sym;
9477	else
9478	gcc_unreachable ();
9479	}
9480	else
9481	sym2 = NULL;
9482
9483	if (sym1->ts.type == BT_CLASS)
9484	{
9485	if ((*expr1)->ts.type != BT_CLASS)
9486	(*expr1)->ts = sym1->ts;
9487
9488	CLASS_DATA (sym1)->attr.dimension = 1;
9489	if (CLASS_DATA (sym1)->as == NULL && sym2)
9490	CLASS_DATA (sym1)->as
9491	= gfc_copy_array_spec (CLASS_DATA (sym2)->as);
9492	}
9493	else
9494	{
9495	sym1->attr.dimension = 1;
9496	if (sym1->as == NULL && sym2)
9497	sym1->as = gfc_copy_array_spec (sym2->as);
9498	}
9499
9500	for (; nref; nref = nref->next)
9501	if (nref->next == NULL)
9502	break;
9503
9504	if (ref && nref && nref->type != REF_ARRAY)
9505	nref->next = gfc_copy_ref (ref);
9506	else if (ref && !nref)
9507	(*expr1)->ref = gfc_copy_ref (ref);
9508	}
9509
9510
9511	static gfc_expr *
9512	build_loc_call (gfc_expr *sym_expr)
9513	{
9514	gfc_expr *loc_call;
9515	loc_call = gfc_get_expr ();
9516	loc_call->expr_type = EXPR_FUNCTION;
9517	gfc_get_sym_tree ("_loc", gfc_current_ns, &loc_call->symtree, false);
9518	loc_call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
9519	loc_call->symtree->n.sym->attr.intrinsic = 1;
9520	loc_call->symtree->n.sym->result = loc_call->symtree->n.sym;
9521	gfc_commit_symbol (loc_call->symtree->n.sym);
9522	loc_call->ts.type = BT_INTEGER;
9523	loc_call->ts.kind = gfc_index_integer_kind;
9524	loc_call->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LOC);
9525	loc_call->value.function.actual = gfc_get_actual_arglist ();
9526	loc_call->value.function.actual->expr = sym_expr;
9527	loc_call->where = sym_expr->where;
9528	return loc_call;
9529	}
9530
9531	/* Resolve a SELECT TYPE statement. */
9532
9533	static void
9534	resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
9535	{
9536	gfc_symbol *selector_type;
9537	gfc_code *body, *new_st, *if_st, *tail;
9538	gfc_code *class_is = NULL, *default_case = NULL;
9539	gfc_case *c;
9540	gfc_symtree *st;
9541	char name[GFC_MAX_SYMBOL_LEN + 12 + 1];
9542	gfc_namespace *ns;
9543	int error = 0;
9544	int rank = 0;
9545	gfc_ref* ref = NULL;
9546	gfc_expr *selector_expr = NULL;
9547
9548	ns = code->ext.block.ns;
9549	gfc_resolve (ns);
9550
9551	/* Check for F03:C813. */
9552	if (code->expr1->ts.type != BT_CLASS
9553	&& !(code->expr2 && code->expr2->ts.type == BT_CLASS))
9554	{
9555	gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
9556	"at %L", &code->loc);
9557	return;
9558	}
9559
9560	if (!code->expr1->symtree->n.sym->attr.class_ok)
9561	return;
9562
9563	if (code->expr2)
9564	{
9565	gfc_ref *ref2 = NULL;
9566	for (ref = code->expr2->ref; ref != NULL; ref = ref->next)
9567	if (ref->type == REF_COMPONENT
9568	&& ref->u.c.component->ts.type == BT_CLASS)
9569	ref2 = ref;
9570
9571	if (ref2)
9572	{
9573	if (code->expr1->symtree->n.sym->attr.untyped)
9574	code->expr1->symtree->n.sym->ts = ref2->u.c.component->ts;
9575	selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived;
9576	}
9577	else
9578	{
9579	if (code->expr1->symtree->n.sym->attr.untyped)
9580	code->expr1->symtree->n.sym->ts = code->expr2->ts;
9581	/* Sometimes the selector expression is given the typespec of the
9582	'_data' field, which is logical enough but inappropriate here. */
9583	if (code->expr2->ts.type == BT_DERIVED
9584	&& code->expr2->symtree
9585	&& code->expr2->symtree->n.sym->ts.type == BT_CLASS)
9586	code->expr2->ts = code->expr2->symtree->n.sym->ts;
9587	selector_type = CLASS_DATA (code->expr2)
9588	? CLASS_DATA (code->expr2)->ts.u.derived : code->expr2->ts.u.derived;
9589	}
9590
9591	if (code->expr2->rank
9592	&& code->expr1->ts.type == BT_CLASS
9593	&& CLASS_DATA (code->expr1)->as)
9594	CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
9595
9596	/* F2008: C803 The selector expression must not be coindexed. */
9597	if (gfc_is_coindexed (code->expr2))
9598	{
9599	gfc_error ("Selector at %L must not be coindexed",
9600	&code->expr2->where);
9601	return;
9602	}
9603
9604	}
9605	else
9606	{
9607	selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
9608
9609	if (gfc_is_coindexed (code->expr1))
9610	{
9611	gfc_error ("Selector at %L must not be coindexed",
9612	&code->expr1->where);
9613	return;
9614	}
9615	}
9616
9617	/* Loop over TYPE IS / CLASS IS cases. */
9618	for (body = code->block; body; body = body->block)
9619	{
9620	c = body->ext.block.case_list;
9621
9622	if (!error)
9623	{
9624	/* Check for repeated cases. */
9625	for (tail = code->block; tail; tail = tail->block)
9626	{
9627	gfc_case *d = tail->ext.block.case_list;
9628	if (tail == body)
9629	break;
9630
9631	if (c->ts.type == d->ts.type
9632	&& ((c->ts.type == BT_DERIVED
9633	&& c->ts.u.derived && d->ts.u.derived
9634	&& !strcmp (s1: c->ts.u.derived->name,
9635	s2: d->ts.u.derived->name))
9636	|| c->ts.type == BT_UNKNOWN
9637	|| (!(c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9638	&& c->ts.kind == d->ts.kind)))
9639	{
9640	gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
9641	&c->where, &d->where);
9642	return;
9643	}
9644	}
9645	}
9646
9647	/* Check F03:C815. */
9648	if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9649	&& selector_type
9650	&& !selector_type->attr.unlimited_polymorphic
9651	&& !gfc_type_is_extensible (sym: c->ts.u.derived))
9652	{
9653	gfc_error ("Derived type %qs at %L must be extensible",
9654	c->ts.u.derived->name, &c->where);
9655	error++;
9656	continue;
9657	}
9658
9659	/* Check F03:C816. */
9660	if (c->ts.type != BT_UNKNOWN
9661	&& selector_type && !selector_type->attr.unlimited_polymorphic
9662	&& ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
9663	|| !gfc_type_is_extension_of (selector_type, c->ts.u.derived)))
9664	{
9665	if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9666	gfc_error ("Derived type %qs at %L must be an extension of %qs",
9667	c->ts.u.derived->name, &c->where, selector_type->name);
9668	else
9669	gfc_error ("Unexpected intrinsic type %qs at %L",
9670	gfc_basic_typename (c->ts.type), &c->where);
9671	error++;
9672	continue;
9673	}
9674
9675	/* Check F03:C814. */
9676	if (c->ts.type == BT_CHARACTER
9677	&& (c->ts.u.cl->length != NULL || c->ts.deferred))
9678	{
9679	gfc_error ("The type-spec at %L shall specify that each length "
9680	"type parameter is assumed", &c->where);
9681	error++;
9682	continue;
9683	}
9684
9685	/* Intercept the DEFAULT case. */
9686	if (c->ts.type == BT_UNKNOWN)
9687	{
9688	/* Check F03:C818. */
9689	if (default_case)
9690	{
9691	gfc_error ("The DEFAULT CASE at %L cannot be followed "
9692	"by a second DEFAULT CASE at %L",
9693	&default_case->ext.block.case_list->where, &c->where);
9694	error++;
9695	continue;
9696	}
9697
9698	default_case = body;
9699	}
9700	}
9701
9702	if (error > 0)
9703	return;
9704
9705	/* Transform SELECT TYPE statement to BLOCK and associate selector to
9706	target if present. If there are any EXIT statements referring to the
9707	SELECT TYPE construct, this is no problem because the gfc_code
9708	reference stays the same and EXIT is equally possible from the BLOCK
9709	it is changed to. */
9710	code->op = EXEC_BLOCK;
9711	if (code->expr2)
9712	{
9713	gfc_association_list* assoc;
9714
9715	assoc = gfc_get_association_list ();
9716	assoc->st = code->expr1->symtree;
9717	assoc->target = gfc_copy_expr (code->expr2);
9718	assoc->target->where = code->expr2->where;
9719	/* assoc->variable will be set by resolve_assoc_var. */
9720
9721	code->ext.block.assoc = assoc;
9722	code->expr1->symtree->n.sym->assoc = assoc;
9723
9724	resolve_assoc_var (sym: code->expr1->symtree->n.sym, resolve_target: false);
9725	}
9726	else
9727	code->ext.block.assoc = NULL;
9728
9729	/* Ensure that the selector rank and arrayspec are available to
9730	correct expressions in which they might be missing. */
9731	if (code->expr2 && code->expr2->rank)
9732	{
9733	rank = code->expr2->rank;
9734	for (ref = code->expr2->ref; ref; ref = ref->next)
9735	if (ref->next == NULL)
9736	break;
9737	if (ref && ref->type == REF_ARRAY)
9738	ref = gfc_copy_ref (ref);
9739
9740	/* Fixup expr1 if necessary. */
9741	if (rank)
9742	fixup_array_ref (expr1: &code->expr1, expr2: code->expr2, rank, ref);
9743	}
9744	else if (code->expr1->rank)
9745	{
9746	rank = code->expr1->rank;
9747	for (ref = code->expr1->ref; ref; ref = ref->next)
9748	if (ref->next == NULL)
9749	break;
9750	if (ref && ref->type == REF_ARRAY)
9751	ref = gfc_copy_ref (ref);
9752	}
9753
9754	/* Add EXEC_SELECT to switch on type. */
9755	new_st = gfc_get_code (code->op);
9756	new_st->expr1 = code->expr1;
9757	new_st->expr2 = code->expr2;
9758	new_st->block = code->block;
9759	code->expr1 = code->expr2 = NULL;
9760	code->block = NULL;
9761	if (!ns->code)
9762	ns->code = new_st;
9763	else
9764	ns->code->next = new_st;
9765	code = new_st;
9766	code->op = EXEC_SELECT_TYPE;
9767
9768	/* Use the intrinsic LOC function to generate an integer expression
9769	for the vtable of the selector. Note that the rank of the selector
9770	expression has to be set to zero. */
9771	gfc_add_vptr_component (code->expr1);
9772	code->expr1->rank = 0;
9773	code->expr1 = build_loc_call (sym_expr: code->expr1);
9774	selector_expr = code->expr1->value.function.actual->expr;
9775
9776	/* Loop over TYPE IS / CLASS IS cases. */
9777	for (body = code->block; body; body = body->block)
9778	{
9779	gfc_symbol *vtab;
9780	gfc_expr *e;
9781	c = body->ext.block.case_list;
9782
9783	/* Generate an index integer expression for address of the
9784	TYPE/CLASS vtable and store it in c->low. The hash expression
9785	is stored in c->high and is used to resolve intrinsic cases. */
9786	if (c->ts.type != BT_UNKNOWN)
9787	{
9788	if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9789	{
9790	vtab = gfc_find_derived_vtab (c->ts.u.derived);
9791	gcc_assert (vtab);
9792	c->high = gfc_get_int_expr (gfc_integer_4_kind, NULL,
9793	c->ts.u.derived->hash_value);
9794	}
9795	else
9796	{
9797	vtab = gfc_find_vtab (&c->ts);
9798	gcc_assert (vtab && CLASS_DATA (vtab)->initializer);
9799	e = CLASS_DATA (vtab)->initializer;
9800	c->high = gfc_copy_expr (e);
9801	if (c->high->ts.kind != gfc_integer_4_kind)
9802	{
9803	gfc_typespec ts;
9804	ts.kind = gfc_integer_4_kind;
9805	ts.type = BT_INTEGER;
9806	gfc_convert_type_warn (c->high, &ts, 2, 0);
9807	}
9808	}
9809
9810	e = gfc_lval_expr_from_sym (vtab);
9811	c->low = build_loc_call (sym_expr: e);
9812	}
9813	else
9814	continue;
9815
9816	/* Associate temporary to selector. This should only be done
9817	when this case is actually true, so build a new ASSOCIATE
9818	that does precisely this here (instead of using the
9819	'global' one). */
9820
9821	if (c->ts.type == BT_CLASS)
9822	sprintf (s: name, format: "__tmp_class_%s", c->ts.u.derived->name);
9823	else if (c->ts.type == BT_DERIVED)
9824	sprintf (s: name, format: "__tmp_type_%s", c->ts.u.derived->name);
9825	else if (c->ts.type == BT_CHARACTER)
9826	{
9827	HOST_WIDE_INT charlen = 0;
9828	if (c->ts.u.cl && c->ts.u.cl->length
9829	&& c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9830	charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
9831	snprintf (s: name, maxlen: sizeof (name),
9832	format: "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
9833	gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
9834	}
9835	else
9836	sprintf (s: name, format: "__tmp_%s_%d", gfc_basic_typename (c->ts.type),
9837	c->ts.kind);
9838
9839	st = gfc_find_symtree (ns->sym_root, name);
9840	gcc_assert (st->n.sym->assoc);
9841	st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
9842	st->n.sym->assoc->target->where = selector_expr->where;
9843	if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
9844	{
9845	gfc_add_data_component (st->n.sym->assoc->target);
9846	/* Fixup the target expression if necessary. */
9847	if (rank)
9848	fixup_array_ref (expr1: &st->n.sym->assoc->target, NULL, rank, ref);
9849	}
9850
9851	new_st = gfc_get_code (EXEC_BLOCK);
9852	new_st->ext.block.ns = gfc_build_block_ns (ns);
9853	new_st->ext.block.ns->code = body->next;
9854	body->next = new_st;
9855
9856	/* Chain in the new list only if it is marked as dangling. Otherwise
9857	there is a CASE label overlap and this is already used. Just ignore,
9858	the error is diagnosed elsewhere. */
9859	if (st->n.sym->assoc->dangling)
9860	{
9861	new_st->ext.block.assoc = st->n.sym->assoc;
9862	st->n.sym->assoc->dangling = 0;
9863	}
9864
9865	resolve_assoc_var (sym: st->n.sym, resolve_target: false);
9866	}
9867
9868	/* Take out CLASS IS cases for separate treatment. */
9869	body = code;
9870	while (body && body->block)
9871	{
9872	if (body->block->ext.block.case_list->ts.type == BT_CLASS)
9873	{
9874	/* Add to class_is list. */
9875	if (class_is == NULL)
9876	{
9877	class_is = body->block;
9878	tail = class_is;
9879	}
9880	else
9881	{
9882	for (tail = class_is; tail->block; tail = tail->block) ;
9883	tail->block = body->block;
9884	tail = tail->block;
9885	}
9886	/* Remove from EXEC_SELECT list. */
9887	body->block = body->block->block;
9888	tail->block = NULL;
9889	}
9890	else
9891	body = body->block;
9892	}
9893
9894	if (class_is)
9895	{
9896	gfc_symbol *vtab;
9897
9898	if (!default_case)
9899	{
9900	/* Add a default case to hold the CLASS IS cases. */
9901	for (tail = code; tail->block; tail = tail->block) ;
9902	tail->block = gfc_get_code (EXEC_SELECT_TYPE);
9903	tail = tail->block;
9904	tail->ext.block.case_list = gfc_get_case ();
9905	tail->ext.block.case_list->ts.type = BT_UNKNOWN;
9906	tail->next = NULL;
9907	default_case = tail;
9908	}
9909
9910	/* More than one CLASS IS block? */
9911	if (class_is->block)
9912	{
9913	gfc_code **c1,*c2;
9914	bool swapped;
9915	/* Sort CLASS IS blocks by extension level. */
9916	do
9917	{
9918	swapped = false;
9919	for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
9920	{
9921	c2 = (*c1)->block;
9922	/* F03:C817 (check for doubles). */
9923	if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
9924	== c2->ext.block.case_list->ts.u.derived->hash_value)
9925	{
9926	gfc_error ("Double CLASS IS block in SELECT TYPE "
9927	"statement at %L",
9928	&c2->ext.block.case_list->where);
9929	return;
9930	}
9931	if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
9932	< c2->ext.block.case_list->ts.u.derived->attr.extension)
9933	{
9934	/* Swap. */
9935	(*c1)->block = c2->block;
9936	c2->block = *c1;
9937	*c1 = c2;
9938	swapped = true;
9939	}
9940	}
9941	}
9942	while (swapped);
9943	}
9944
9945	/* Generate IF chain. */
9946	if_st = gfc_get_code (EXEC_IF);
9947	new_st = if_st;
9948	for (body = class_is; body; body = body->block)
9949	{
9950	new_st->block = gfc_get_code (EXEC_IF);
9951	new_st = new_st->block;
9952	/* Set up IF condition: Call _gfortran_is_extension_of. */
9953	new_st->expr1 = gfc_get_expr ();
9954	new_st->expr1->expr_type = EXPR_FUNCTION;
9955	new_st->expr1->ts.type = BT_LOGICAL;
9956	new_st->expr1->ts.kind = 4;
9957	new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
9958	new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
9959	new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
9960	/* Set up arguments. */
9961	new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
9962	new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (selector_expr->symtree);
9963	new_st->expr1->value.function.actual->expr->where = code->loc;
9964	new_st->expr1->where = code->loc;
9965	gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
9966	vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
9967	st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
9968	new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
9969	new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
9970	new_st->expr1->value.function.actual->next->expr->where = code->loc;
9971	/* Set up types in formal arg list. */
9972	new_st->expr1->value.function.isym->formal = XCNEW (gfc_intrinsic_arg);
9973	new_st->expr1->value.function.isym->formal->ts = new_st->expr1->value.function.actual->expr->ts;
9974	new_st->expr1->value.function.isym->formal->next = XCNEW (gfc_intrinsic_arg);
9975	new_st->expr1->value.function.isym->formal->next->ts = new_st->expr1->value.function.actual->next->expr->ts;
9976
9977	new_st->next = body->next;
9978	}
9979	if (default_case->next)
9980	{
9981	new_st->block = gfc_get_code (EXEC_IF);
9982	new_st = new_st->block;
9983	new_st->next = default_case->next;
9984	}
9985
9986	/* Replace CLASS DEFAULT code by the IF chain. */
9987	default_case->next = if_st;
9988	}
9989
9990	/* Resolve the internal code. This cannot be done earlier because
9991	it requires that the sym->assoc of selectors is set already. */
9992	gfc_current_ns = ns;
9993	gfc_resolve_blocks (code->block, gfc_current_ns);
9994	gfc_current_ns = old_ns;
9995
9996	free (ptr: ref);
9997	}
9998
9999
10000	/* Resolve a SELECT RANK statement. */
10001
10002	static void
10003	resolve_select_rank (gfc_code *code, gfc_namespace *old_ns)
10004	{
10005	gfc_namespace *ns;
10006	gfc_code *body, *new_st, *tail;
10007	gfc_case *c;
10008	char tname[GFC_MAX_SYMBOL_LEN + 7];
10009	char name[2 * GFC_MAX_SYMBOL_LEN];
10010	gfc_symtree *st;
10011	gfc_expr *selector_expr = NULL;
10012	int case_value;
10013	HOST_WIDE_INT charlen = 0;
10014
10015	ns = code->ext.block.ns;
10016	gfc_resolve (ns);
10017
10018	code->op = EXEC_BLOCK;
10019	if (code->expr2)
10020	{
10021	gfc_association_list* assoc;
10022
10023	assoc = gfc_get_association_list ();
10024	assoc->st = code->expr1->symtree;
10025	assoc->target = gfc_copy_expr (code->expr2);
10026	assoc->target->where = code->expr2->where;
10027	/* assoc->variable will be set by resolve_assoc_var. */
10028
10029	code->ext.block.assoc = assoc;
10030	code->expr1->symtree->n.sym->assoc = assoc;
10031
10032	resolve_assoc_var (sym: code->expr1->symtree->n.sym, resolve_target: false);
10033	}
10034	else
10035	code->ext.block.assoc = NULL;
10036
10037	/* Loop over RANK cases. Note that returning on the errors causes a
10038	cascade of further errors because the case blocks do not compile
10039	correctly. */
10040	for (body = code->block; body; body = body->block)
10041	{
10042	c = body->ext.block.case_list;
10043	if (c->low)
10044	case_value = (int) mpz_get_si (c->low->value.integer);
10045	else
10046	case_value = -2;
10047
10048	/* Check for repeated cases. */
10049	for (tail = code->block; tail; tail = tail->block)
10050	{
10051	gfc_case *d = tail->ext.block.case_list;
10052	int case_value2;
10053
10054	if (tail == body)
10055	break;
10056
10057	/* Check F2018: C1153. */
10058	if (!c->low && !d->low)
10059	gfc_error ("RANK DEFAULT at %L is repeated at %L",
10060	&c->where, &d->where);
10061
10062	if (!c->low || !d->low)
10063	continue;
10064
10065	/* Check F2018: C1153. */
10066	case_value2 = (int) mpz_get_si (d->low->value.integer);
10067	if ((case_value == case_value2) && case_value == -1)
10068	gfc_error ("RANK (*) at %L is repeated at %L",
10069	&c->where, &d->where);
10070	else if (case_value == case_value2)
10071	gfc_error ("RANK (%i) at %L is repeated at %L",
10072	case_value, &c->where, &d->where);
10073	}
10074
10075	if (!c->low)
10076	continue;
10077
10078	/* Check F2018: C1155. */
10079	if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
10080	|| gfc_expr_attr (code->expr1).pointer))
10081	gfc_error ("RANK (*) at %L cannot be used with the pointer or "
10082	"allocatable selector at %L", &c->where, &code->expr1->where);
10083	}
10084
10085	/* Add EXEC_SELECT to switch on rank. */
10086	new_st = gfc_get_code (code->op);
10087	new_st->expr1 = code->expr1;
10088	new_st->expr2 = code->expr2;
10089	new_st->block = code->block;
10090	code->expr1 = code->expr2 = NULL;
10091	code->block = NULL;
10092	if (!ns->code)
10093	ns->code = new_st;
10094	else
10095	ns->code->next = new_st;
10096	code = new_st;
10097	code->op = EXEC_SELECT_RANK;
10098
10099	selector_expr = code->expr1;
10100
10101	/* Loop over SELECT RANK cases. */
10102	for (body = code->block; body; body = body->block)
10103	{
10104	c = body->ext.block.case_list;
10105	int case_value;
10106
10107	/* Pass on the default case. */
10108	if (c->low == NULL)
10109	continue;
10110
10111	/* Associate temporary to selector. This should only be done
10112	when this case is actually true, so build a new ASSOCIATE
10113	that does precisely this here (instead of using the
10114	'global' one). */
10115	if (c->ts.type == BT_CHARACTER && c->ts.u.cl && c->ts.u.cl->length
10116	&& c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
10117	charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
10118
10119	if (c->ts.type == BT_CLASS)
10120	sprintf (s: tname, format: "class_%s", c->ts.u.derived->name);
10121	else if (c->ts.type == BT_DERIVED)
10122	sprintf (s: tname, format: "type_%s", c->ts.u.derived->name);
10123	else if (c->ts.type != BT_CHARACTER)
10124	sprintf (s: tname, format: "%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind);
10125	else
10126	sprintf (s: tname, format: "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
10127	gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
10128
10129	case_value = (int) mpz_get_si (c->low->value.integer);
10130	if (case_value >= 0)
10131	sprintf (s: name, format: "__tmp_%s_rank_%d", tname, case_value);
10132	else
10133	sprintf (s: name, format: "__tmp_%s_rank_m%d", tname, -case_value);
10134
10135	st = gfc_find_symtree (ns->sym_root, name);
10136	gcc_assert (st->n.sym->assoc);
10137
10138	st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
10139	st->n.sym->assoc->target->where = selector_expr->where;
10140
10141	new_st = gfc_get_code (EXEC_BLOCK);
10142	new_st->ext.block.ns = gfc_build_block_ns (ns);
10143	new_st->ext.block.ns->code = body->next;
10144	body->next = new_st;
10145
10146	/* Chain in the new list only if it is marked as dangling. Otherwise
10147	there is a CASE label overlap and this is already used. Just ignore,
10148	the error is diagnosed elsewhere. */
10149	if (st->n.sym->assoc->dangling)
10150	{
10151	new_st->ext.block.assoc = st->n.sym->assoc;
10152	st->n.sym->assoc->dangling = 0;
10153	}
10154
10155	resolve_assoc_var (sym: st->n.sym, resolve_target: false);
10156	}
10157
10158	gfc_current_ns = ns;
10159	gfc_resolve_blocks (code->block, gfc_current_ns);
10160	gfc_current_ns = old_ns;
10161	}
10162
10163
10164	/* Resolve a transfer statement. This is making sure that:
10165	-- a derived type being transferred has only non-pointer components
10166	-- a derived type being transferred doesn't have private components, unless
10167	it's being transferred from the module where the type was defined
10168	-- we're not trying to transfer a whole assumed size array. */
10169
10170	static void
10171	resolve_transfer (gfc_code *code)
10172	{
10173	gfc_symbol *sym, *derived;
10174	gfc_ref *ref;
10175	gfc_expr *exp;
10176	bool write = false;
10177	bool formatted = false;
10178	gfc_dt *dt = code->ext.dt;
10179	gfc_symbol *dtio_sub = NULL;
10180
10181	exp = code->expr1;
10182
10183	while (exp != NULL && exp->expr_type == EXPR_OP
10184	&& exp->value.op.op == INTRINSIC_PARENTHESES)
10185	exp = exp->value.op.op1;
10186
10187	if (exp && exp->expr_type == EXPR_NULL
10188	&& code->ext.dt)
10189	{
10190	gfc_error ("Invalid context for NULL () intrinsic at %L",
10191	&exp->where);
10192	return;
10193	}
10194
10195	if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
10196	&& exp->expr_type != EXPR_FUNCTION
10197	&& exp->expr_type != EXPR_ARRAY
10198	&& exp->expr_type != EXPR_STRUCTURE))
10199	return;
10200
10201	/* If we are reading, the variable will be changed. Note that
10202	code->ext.dt may be NULL if the TRANSFER is related to
10203	an INQUIRE statement -- but in this case, we are not reading, either. */
10204	if (dt && dt->dt_io_kind->value.iokind == M_READ
10205	&& !gfc_check_vardef_context (exp, false, false, false,
10206	_("item in READ")))
10207	return;
10208
10209	const gfc_typespec *ts = exp->expr_type == EXPR_STRUCTURE
10210	|| exp->expr_type == EXPR_FUNCTION
10211	|| exp->expr_type == EXPR_ARRAY
10212	? &exp->ts : &exp->symtree->n.sym->ts;
10213
10214	/* Go to actual component transferred. */
10215	for (ref = exp->ref; ref; ref = ref->next)
10216	if (ref->type == REF_COMPONENT)
10217	ts = &ref->u.c.component->ts;
10218
10219	if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE
10220	&& (ts->type == BT_DERIVED || ts->type == BT_CLASS))
10221	{
10222	derived = ts->u.derived;
10223
10224	/* Determine when to use the formatted DTIO procedure. */
10225	if (dt && (dt->format_expr || dt->format_label))
10226	formatted = true;
10227
10228	write = dt->dt_io_kind->value.iokind == M_WRITE
10229	|| dt->dt_io_kind->value.iokind == M_PRINT;
10230	dtio_sub = gfc_find_specific_dtio_proc (derived, write, formatted);
10231
10232	if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE)
10233	{
10234	dt->udtio = exp;
10235	sym = exp->symtree->n.sym->ns->proc_name;
10236	/* Check to see if this is a nested DTIO call, with the
10237	dummy as the io-list object. */
10238	if (sym && sym == dtio_sub && sym->formal
10239	&& sym->formal->sym == exp->symtree->n.sym
10240	&& exp->ref == NULL)
10241	{
10242	if (!sym->attr.recursive)
10243	{
10244	gfc_error ("DTIO %s procedure at %L must be recursive",
10245	sym->name, &sym->declared_at);
10246	return;
10247	}
10248	}
10249	}
10250	}
10251
10252	if (ts->type == BT_CLASS && dtio_sub == NULL)
10253	{
10254	gfc_error ("Data transfer element at %L cannot be polymorphic unless "
10255	"it is processed by a defined input/output procedure",
10256	&code->loc);
10257	return;
10258	}
10259
10260	if (ts->type == BT_DERIVED)
10261	{
10262	/* Check that transferred derived type doesn't contain POINTER
10263	components unless it is processed by a defined input/output
10264	procedure". */
10265	if (ts->u.derived->attr.pointer_comp && dtio_sub == NULL)
10266	{
10267	gfc_error ("Data transfer element at %L cannot have POINTER "
10268	"components unless it is processed by a defined "
10269	"input/output procedure", &code->loc);
10270	return;
10271	}
10272
10273	/* F08:C935. */
10274	if (ts->u.derived->attr.proc_pointer_comp)
10275	{
10276	gfc_error ("Data transfer element at %L cannot have "
10277	"procedure pointer components", &code->loc);
10278	return;
10279	}
10280
10281	if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL)
10282	{
10283	gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
10284	"components unless it is processed by a defined "
10285	"input/output procedure", &code->loc);
10286	return;
10287	}
10288
10289	/* C_PTR and C_FUNPTR have private components which means they cannot
10290	be printed. However, if -std=gnu and not -pedantic, allow
10291	the component to be printed to help debugging. */
10292	if (ts->u.derived->ts.f90_type == BT_VOID)
10293	{
10294	if (!gfc_notify_std (GFC_STD_GNU, "Data transfer element at %L "
10295	"cannot have PRIVATE components", &code->loc))
10296	return;
10297	}
10298	else if (derived_inaccessible (sym: ts->u.derived) && dtio_sub == NULL)
10299	{
10300	gfc_error ("Data transfer element at %L cannot have "
10301	"PRIVATE components unless it is processed by "
10302	"a defined input/output procedure", &code->loc);
10303	return;
10304	}
10305	}
10306
10307	if (exp->expr_type == EXPR_STRUCTURE)
10308	return;
10309
10310	if (exp->expr_type == EXPR_ARRAY)
10311	return;
10312
10313	sym = exp->symtree->n.sym;
10314
10315	if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
10316	&& exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
10317	{
10318	gfc_error ("Data transfer element at %L cannot be a full reference to "
10319	"an assumed-size array", &code->loc);
10320	return;
10321	}
10322	}
10323
10324
10325	/*********** Toplevel code resolution subroutines ***********/
10326
10327	/* Find the set of labels that are reachable from this block. We also
10328	record the last statement in each block. */
10329
10330	static void
10331	find_reachable_labels (gfc_code *block)
10332	{
10333	gfc_code *c;
10334
10335	if (!block)
10336	return;
10337
10338	cs_base->reachable_labels = bitmap_alloc (obstack: &labels_obstack);
10339
10340	/* Collect labels in this block. We don't keep those corresponding
10341	to END {IF|SELECT}, these are checked in resolve_branch by going
10342	up through the code_stack. */
10343	for (c = block; c; c = c->next)
10344	{
10345	if (c->here && c->op != EXEC_END_NESTED_BLOCK)
10346	bitmap_set_bit (cs_base->reachable_labels, c->here->value);
10347	}
10348
10349	/* Merge with labels from parent block. */
10350	if (cs_base->prev)
10351	{
10352	gcc_assert (cs_base->prev->reachable_labels);
10353	bitmap_ior_into (cs_base->reachable_labels,
10354	cs_base->prev->reachable_labels);
10355	}
10356	}
10357
10358
10359	static void
10360	resolve_lock_unlock_event (gfc_code *code)
10361	{
10362	if (code->expr1->expr_type == EXPR_FUNCTION
10363	&& code->expr1->value.function.isym
10364	&& code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
10365	remove_caf_get_intrinsic (e: code->expr1);
10366
10367	if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK)
10368	&& (code->expr1->ts.type != BT_DERIVED
10369	|| code->expr1->expr_type != EXPR_VARIABLE
10370	|| code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
10371	|| code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
10372	|| code->expr1->rank != 0
10373	|| (!gfc_is_coarray (code->expr1) &&
10374	!gfc_is_coindexed (code->expr1))))
10375	gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
10376	&code->expr1->where);
10377	else if ((code->op == EXEC_EVENT_POST || code->op == EXEC_EVENT_WAIT)
10378	&& (code->expr1->ts.type != BT_DERIVED
10379	|| code->expr1->expr_type != EXPR_VARIABLE
10380	|| code->expr1->ts.u.derived->from_intmod
10381	!= INTMOD_ISO_FORTRAN_ENV
10382	|| code->expr1->ts.u.derived->intmod_sym_id
10383	!= ISOFORTRAN_EVENT_TYPE
10384	|| code->expr1->rank != 0))
10385	gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
10386	&code->expr1->where);
10387	else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1)
10388	&& !gfc_is_coindexed (code->expr1))
10389	gfc_error ("Event variable argument at %L must be a coarray or coindexed",
10390	&code->expr1->where);
10391	else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1))
10392	gfc_error ("Event variable argument at %L must be a coarray but not "
10393	"coindexed", &code->expr1->where);
10394
10395	/* Check STAT. */
10396	if (code->expr2
10397	&& (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
10398	|| code->expr2->expr_type != EXPR_VARIABLE))
10399	gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
10400	&code->expr2->where);
10401
10402	if (code->expr2
10403	&& !gfc_check_vardef_context (code->expr2, false, false, false,
10404	_("STAT variable")))
10405	return;
10406
10407	/* Check ERRMSG. */
10408	if (code->expr3
10409	&& (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
10410	|| code->expr3->expr_type != EXPR_VARIABLE))
10411	gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
10412	&code->expr3->where);
10413
10414	if (code->expr3
10415	&& !gfc_check_vardef_context (code->expr3, false, false, false,
10416	_("ERRMSG variable")))
10417	return;
10418
10419	/* Check for LOCK the ACQUIRED_LOCK. */
10420	if (code->op != EXEC_EVENT_WAIT && code->expr4
10421	&& (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
10422	|| code->expr4->expr_type != EXPR_VARIABLE))
10423	gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
10424	"variable", &code->expr4->where);
10425
10426	if (code->op != EXEC_EVENT_WAIT && code->expr4
10427	&& !gfc_check_vardef_context (code->expr4, false, false, false,
10428	_("ACQUIRED_LOCK variable")))
10429	return;
10430
10431	/* Check for EVENT WAIT the UNTIL_COUNT. */
10432	if (code->op == EXEC_EVENT_WAIT && code->expr4)
10433	{
10434	if (!gfc_resolve_expr (e: code->expr4) || code->expr4->ts.type != BT_INTEGER
10435	|| code->expr4->rank != 0)
10436	gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
10437	"expression", &code->expr4->where);
10438	}
10439	}
10440
10441
10442	static void
10443	resolve_critical (gfc_code *code)
10444	{
10445	gfc_symtree *symtree;
10446	gfc_symbol *lock_type;
10447	char name[GFC_MAX_SYMBOL_LEN];
10448	static int serial = 0;
10449
10450	if (flag_coarray != GFC_FCOARRAY_LIB)
10451	return;
10452
10453	symtree = gfc_find_symtree (gfc_current_ns->sym_root,
10454	GFC_PREFIX ("lock_type"));
10455	if (symtree)
10456	lock_type = symtree->n.sym;
10457	else
10458	{
10459	if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree,
10460	false) != 0)
10461	gcc_unreachable ();
10462	lock_type = symtree->n.sym;
10463	lock_type->attr.flavor = FL_DERIVED;
10464	lock_type->attr.zero_comp = 1;
10465	lock_type->from_intmod = INTMOD_ISO_FORTRAN_ENV;
10466	lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE;
10467	}
10468
10469	sprintf(s: name, GFC_PREFIX ("lock_var") "%d",serial++);
10470	if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0)
10471	gcc_unreachable ();
10472
10473	code->resolved_sym = symtree->n.sym;
10474	symtree->n.sym->attr.flavor = FL_VARIABLE;
10475	symtree->n.sym->attr.referenced = 1;
10476	symtree->n.sym->attr.artificial = 1;
10477	symtree->n.sym->attr.codimension = 1;
10478	symtree->n.sym->ts.type = BT_DERIVED;
10479	symtree->n.sym->ts.u.derived = lock_type;
10480	symtree->n.sym->as = gfc_get_array_spec ();
10481	symtree->n.sym->as->corank = 1;
10482	symtree->n.sym->as->type = AS_EXPLICIT;
10483	symtree->n.sym->as->cotype = AS_EXPLICIT;
10484	symtree->n.sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
10485	NULL, 1);
10486	gfc_commit_symbols();
10487	}
10488
10489
10490	static void
10491	resolve_sync (gfc_code *code)
10492	{
10493	/* Check imageset. The * case matches expr1 == NULL. */
10494	if (code->expr1)
10495	{
10496	if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
10497	gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
10498	"INTEGER expression", &code->expr1->where);
10499	if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
10500	&& mpz_cmp_si (code->expr1->value.integer, 1) < 0)
10501	gfc_error ("Imageset argument at %L must between 1 and num_images()",
10502	&code->expr1->where);
10503	else if (code->expr1->expr_type == EXPR_ARRAY
10504	&& gfc_simplify_expr (code->expr1, 0))
10505	{
10506	gfc_constructor *cons;
10507	cons = gfc_constructor_first (base: code->expr1->value.constructor);
10508	for (; cons; cons = gfc_constructor_next (ctor: cons))
10509	if (cons->expr->expr_type == EXPR_CONSTANT
10510	&& mpz_cmp_si (cons->expr->value.integer, 1) < 0)
10511	gfc_error ("Imageset argument at %L must between 1 and "
10512	"num_images()", &cons->expr->where);
10513	}
10514	}
10515
10516	/* Check STAT. */
10517	gfc_resolve_expr (e: code->expr2);
10518	if (code->expr2)
10519	{
10520	if (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0)
10521	gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
10522	&code->expr2->where);
10523	else
10524	gfc_check_vardef_context (code->expr2, false, false, false,
10525	_("STAT variable"));
10526	}
10527
10528	/* Check ERRMSG. */
10529	gfc_resolve_expr (e: code->expr3);
10530	if (code->expr3)
10531	{
10532	if (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0)
10533	gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
10534	&code->expr3->where);
10535	else
10536	gfc_check_vardef_context (code->expr3, false, false, false,
10537	_("ERRMSG variable"));
10538	}
10539	}
10540
10541
10542	/* Given a branch to a label, see if the branch is conforming.
10543	The code node describes where the branch is located. */
10544
10545	static void
10546	resolve_branch (gfc_st_label *label, gfc_code *code)
10547	{
10548	code_stack *stack;
10549
10550	if (label == NULL)
10551	return;
10552
10553	/* Step one: is this a valid branching target? */
10554
10555	if (label->defined == ST_LABEL_UNKNOWN)
10556	{
10557	gfc_error ("Label %d referenced at %L is never defined", label->value,
10558	&code->loc);
10559	return;
10560	}
10561
10562	if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET)
10563	{
10564	gfc_error ("Statement at %L is not a valid branch target statement "
10565	"for the branch statement at %L", &label->where, &code->loc);
10566	return;
10567	}
10568
10569	/* Step two: make sure this branch is not a branch to itself ;-) */
10570
10571	if (code->here == label)
10572	{
10573	gfc_warning (opt: 0,
10574	"Branch at %L may result in an infinite loop", &code->loc);
10575	return;
10576	}
10577
10578	/* Step three: See if the label is in the same block as the
10579	branching statement. The hard work has been done by setting up
10580	the bitmap reachable_labels. */
10581
10582	if (bitmap_bit_p (cs_base->reachable_labels, label->value))
10583	{
10584	/* Check now whether there is a CRITICAL construct; if so, check
10585	whether the label is still visible outside of the CRITICAL block,
10586	which is invalid. */
10587	for (stack = cs_base; stack; stack = stack->prev)
10588	{
10589	if (stack->current->op == EXEC_CRITICAL
10590	&& bitmap_bit_p (stack->reachable_labels, label->value))
10591	gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
10592	"label at %L", &code->loc, &label->where);
10593	else if (stack->current->op == EXEC_DO_CONCURRENT
10594	&& bitmap_bit_p (stack->reachable_labels, label->value))
10595	gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
10596	"for label at %L", &code->loc, &label->where);
10597	}
10598
10599	return;
10600	}
10601
10602	/* Step four: If we haven't found the label in the bitmap, it may
10603	still be the label of the END of the enclosing block, in which
10604	case we find it by going up the code_stack. */
10605
10606	for (stack = cs_base; stack; stack = stack->prev)
10607	{
10608	if (stack->current->next && stack->current->next->here == label)
10609	break;
10610	if (stack->current->op == EXEC_CRITICAL)
10611	{
10612	/* Note: A label at END CRITICAL does not leave the CRITICAL
10613	construct as END CRITICAL is still part of it. */
10614	gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
10615	" at %L", &code->loc, &label->where);
10616	return;
10617	}
10618	else if (stack->current->op == EXEC_DO_CONCURRENT)
10619	{
10620	gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
10621	"label at %L", &code->loc, &label->where);
10622	return;
10623	}
10624	}
10625
10626	if (stack)
10627	{
10628	gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
10629	return;
10630	}
10631
10632	/* The label is not in an enclosing block, so illegal. This was
10633	allowed in Fortran 66, so we allow it as extension. No
10634	further checks are necessary in this case. */
10635	gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
10636	"as the GOTO statement at %L", &label->where,
10637	&code->loc);
10638	return;
10639	}
10640
10641
10642	/* Check whether EXPR1 has the same shape as EXPR2. */
10643
10644	static bool
10645	resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
10646	{
10647	mpz_t shape[GFC_MAX_DIMENSIONS];
10648	mpz_t shape2[GFC_MAX_DIMENSIONS];
10649	bool result = false;
10650	int i;
10651
10652	/* Compare the rank. */
10653	if (expr1->rank != expr2->rank)
10654	return result;
10655
10656	/* Compare the size of each dimension. */
10657	for (i=0; i<expr1->rank; i++)
10658	{
10659	if (!gfc_array_dimen_size (expr1, i, &shape[i]))
10660	goto ignore;
10661
10662	if (!gfc_array_dimen_size (expr2, i, &shape2[i]))
10663	goto ignore;
10664
10665	if (mpz_cmp (shape[i], shape2[i]))
10666	goto over;
10667	}
10668
10669	/* When either of the two expression is an assumed size array, we
10670	ignore the comparison of dimension sizes. */
10671	ignore:
10672	result = true;
10673
10674	over:
10675	gfc_clear_shape (shape, rank: i);
10676	gfc_clear_shape (shape: shape2, rank: i);
10677	return result;
10678	}
10679
10680
10681	/* Check whether a WHERE assignment target or a WHERE mask expression
10682	has the same shape as the outmost WHERE mask expression. */
10683
10684	static void
10685	resolve_where (gfc_code *code, gfc_expr *mask)
10686	{
10687	gfc_code *cblock;
10688	gfc_code *cnext;
10689	gfc_expr *e = NULL;
10690
10691	cblock = code->block;
10692
10693	/* Store the first WHERE mask-expr of the WHERE statement or construct.
10694	In case of nested WHERE, only the outmost one is stored. */
10695	if (mask == NULL) /* outmost WHERE */
10696	e = cblock->expr1;
10697	else /* inner WHERE */
10698	e = mask;
10699
10700	while (cblock)
10701	{
10702	if (cblock->expr1)
10703	{
10704	/* Check if the mask-expr has a consistent shape with the
10705	outmost WHERE mask-expr. */
10706	if (!resolve_where_shape (expr1: cblock->expr1, expr2: e))
10707	gfc_error ("WHERE mask at %L has inconsistent shape",
10708	&cblock->expr1->where);
10709	}
10710
10711	/* the assignment statement of a WHERE statement, or the first
10712	statement in where-body-construct of a WHERE construct */
10713	cnext = cblock->next;
10714	while (cnext)
10715	{
10716	switch (cnext->op)
10717	{
10718	/* WHERE assignment statement */
10719	case EXEC_ASSIGN:
10720
10721	/* Check shape consistent for WHERE assignment target. */
10722	if (e && !resolve_where_shape (expr1: cnext->expr1, expr2: e))
10723	gfc_error ("WHERE assignment target at %L has "
10724	"inconsistent shape", &cnext->expr1->where);
10725
10726	if (cnext->op == EXEC_ASSIGN
10727	&& gfc_may_be_finalized (cnext->expr1->ts))
10728	cnext->expr1->must_finalize = 1;
10729
10730	break;
10731
10732
10733	case EXEC_ASSIGN_CALL:
10734	resolve_call (c: cnext);
10735	if (!cnext->resolved_sym->attr.elemental)
10736	gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10737	&cnext->ext.actual->expr->where);
10738	break;
10739
10740	/* WHERE or WHERE construct is part of a where-body-construct */
10741	case EXEC_WHERE:
10742	resolve_where (code: cnext, mask: e);
10743	break;
10744
10745	default:
10746	gfc_error ("Unsupported statement inside WHERE at %L",
10747	&cnext->loc);
10748	}
10749	/* the next statement within the same where-body-construct */
10750	cnext = cnext->next;
10751	}
10752	/* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10753	cblock = cblock->block;
10754	}
10755	}
10756
10757
10758	/* Resolve assignment in FORALL construct.
10759	NVAR is the number of FORALL index variables, and VAR_EXPR records the
10760	FORALL index variables. */
10761
10762	static void
10763	gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
10764	{
10765	int n;
10766
10767	for (n = 0; n < nvar; n++)
10768	{
10769	gfc_symbol *forall_index;
10770
10771	forall_index = var_expr[n]->symtree->n.sym;
10772
10773	/* Check whether the assignment target is one of the FORALL index
10774	variable. */
10775	if ((code->expr1->expr_type == EXPR_VARIABLE)
10776	&& (code->expr1->symtree->n.sym == forall_index))
10777	gfc_error ("Assignment to a FORALL index variable at %L",
10778	&code->expr1->where);
10779	else
10780	{
10781	/* If one of the FORALL index variables doesn't appear in the
10782	assignment variable, then there could be a many-to-one
10783	assignment. Emit a warning rather than an error because the
10784	mask could be resolving this problem. */
10785	if (!find_forall_index (expr: code->expr1, sym: forall_index, f: 0))
10786	gfc_warning (opt: 0, "The FORALL with index %qs is not used on the "
10787	"left side of the assignment at %L and so might "
10788	"cause multiple assignment to this object",
10789	var_expr[n]->symtree->name, &code->expr1->where);
10790	}
10791	}
10792	}
10793
10794
10795	/* Resolve WHERE statement in FORALL construct. */
10796
10797	static void
10798	gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
10799	gfc_expr **var_expr)
10800	{
10801	gfc_code *cblock;
10802	gfc_code *cnext;
10803
10804	cblock = code->block;
10805	while (cblock)
10806	{
10807	/* the assignment statement of a WHERE statement, or the first
10808	statement in where-body-construct of a WHERE construct */
10809	cnext = cblock->next;
10810	while (cnext)
10811	{
10812	switch (cnext->op)
10813	{
10814	/* WHERE assignment statement */
10815	case EXEC_ASSIGN:
10816	gfc_resolve_assign_in_forall (code: cnext, nvar, var_expr);
10817
10818	if (cnext->op == EXEC_ASSIGN
10819	&& gfc_may_be_finalized (cnext->expr1->ts))
10820	cnext->expr1->must_finalize = 1;
10821
10822	break;
10823
10824	/* WHERE operator assignment statement */
10825	case EXEC_ASSIGN_CALL:
10826	resolve_call (c: cnext);
10827	if (!cnext->resolved_sym->attr.elemental)
10828	gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
10829	&cnext->ext.actual->expr->where);
10830	break;
10831
10832	/* WHERE or WHERE construct is part of a where-body-construct */
10833	case EXEC_WHERE:
10834	gfc_resolve_where_code_in_forall (code: cnext, nvar, var_expr);
10835	break;
10836
10837	default:
10838	gfc_error ("Unsupported statement inside WHERE at %L",
10839	&cnext->loc);
10840	}
10841	/* the next statement within the same where-body-construct */
10842	cnext = cnext->next;
10843	}
10844	/* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10845	cblock = cblock->block;
10846	}
10847	}
10848
10849
10850	/* Traverse the FORALL body to check whether the following errors exist:
10851	1. For assignment, check if a many-to-one assignment happens.
10852	2. For WHERE statement, check the WHERE body to see if there is any
10853	many-to-one assignment. */
10854
10855	static void
10856	gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
10857	{
10858	gfc_code *c;
10859
10860	c = code->block->next;
10861	while (c)
10862	{
10863	switch (c->op)
10864	{
10865	case EXEC_ASSIGN:
10866	case EXEC_POINTER_ASSIGN:
10867	gfc_resolve_assign_in_forall (code: c, nvar, var_expr);
10868
10869	if (c->op == EXEC_ASSIGN
10870	&& gfc_may_be_finalized (c->expr1->ts))
10871	c->expr1->must_finalize = 1;
10872
10873	break;
10874
10875	case EXEC_ASSIGN_CALL:
10876	resolve_call (c);
10877	break;
10878
10879	/* Because the gfc_resolve_blocks() will handle the nested FORALL,
10880	there is no need to handle it here. */
10881	case EXEC_FORALL:
10882	break;
10883	case EXEC_WHERE:
10884	gfc_resolve_where_code_in_forall(code: c, nvar, var_expr);
10885	break;
10886	default:
10887	break;
10888	}
10889	/* The next statement in the FORALL body. */
10890	c = c->next;
10891	}
10892	}
10893
10894
10895	/* Counts the number of iterators needed inside a forall construct, including
10896	nested forall constructs. This is used to allocate the needed memory
10897	in gfc_resolve_forall. */
10898
10899	static int
10900	gfc_count_forall_iterators (gfc_code *code)
10901	{
10902	int max_iters, sub_iters, current_iters;
10903	gfc_forall_iterator *fa;
10904
10905	gcc_assert(code->op == EXEC_FORALL);
10906	max_iters = 0;
10907	current_iters = 0;
10908
10909	for (fa = code->ext.forall_iterator; fa; fa = fa->next)
10910	current_iters ++;
10911
10912	code = code->block->next;
10913
10914	while (code)
10915	{
10916	if (code->op == EXEC_FORALL)
10917	{
10918	sub_iters = gfc_count_forall_iterators (code);
10919	if (sub_iters > max_iters)
10920	max_iters = sub_iters;
10921	}
10922	code = code->next;
10923	}
10924
10925	return current_iters + max_iters;
10926	}
10927
10928
10929	/* Given a FORALL construct, first resolve the FORALL iterator, then call
10930	gfc_resolve_forall_body to resolve the FORALL body. */
10931
10932	static void
10933	gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
10934	{
10935	static gfc_expr **var_expr;
10936	static int total_var = 0;
10937	static int nvar = 0;
10938	int i, old_nvar, tmp;
10939	gfc_forall_iterator *fa;
10940
10941	old_nvar = nvar;
10942
10943	if (!gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc))
10944	return;
10945
10946	/* Start to resolve a FORALL construct */
10947	if (forall_save == 0)
10948	{
10949	/* Count the total number of FORALL indices in the nested FORALL
10950	construct in order to allocate the VAR_EXPR with proper size. */
10951	total_var = gfc_count_forall_iterators (code);
10952
10953	/* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
10954	var_expr = XCNEWVEC (gfc_expr *, total_var);
10955	}
10956
10957	/* The information about FORALL iterator, including FORALL indices start, end
10958	and stride. An outer FORALL indice cannot appear in start, end or stride. */
10959	for (fa = code->ext.forall_iterator; fa; fa = fa->next)
10960	{
10961	/* Fortran 20008: C738 (R753). */
10962	if (fa->var->ref && fa->var->ref->type == REF_ARRAY)
10963	{
10964	gfc_error ("FORALL index-name at %L must be a scalar variable "
10965	"of type integer", &fa->var->where);
10966	continue;
10967	}
10968
10969	/* Check if any outer FORALL index name is the same as the current
10970	one. */
10971	for (i = 0; i < nvar; i++)
10972	{
10973	if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
10974	gfc_error ("An outer FORALL construct already has an index "
10975	"with this name %L", &fa->var->where);
10976	}
10977
10978	/* Record the current FORALL index. */
10979	var_expr[nvar] = gfc_copy_expr (fa->var);
10980
10981	nvar++;
10982
10983	/* No memory leak. */
10984	gcc_assert (nvar <= total_var);
10985	}
10986
10987	/* Resolve the FORALL body. */
10988	gfc_resolve_forall_body (code, nvar, var_expr);
10989
10990	/* May call gfc_resolve_forall to resolve the inner FORALL loop. */
10991	gfc_resolve_blocks (code->block, ns);
10992
10993	tmp = nvar;
10994	nvar = old_nvar;
10995	/* Free only the VAR_EXPRs allocated in this frame. */
10996	for (i = nvar; i < tmp; i++)
10997	gfc_free_expr (var_expr[i]);
10998
10999	if (nvar == 0)
11000	{
11001	/* We are in the outermost FORALL construct. */
11002	gcc_assert (forall_save == 0);
11003
11004	/* VAR_EXPR is not needed any more. */
11005	free (ptr: var_expr);
11006	total_var = 0;
11007	}
11008	}
11009
11010
11011	/* Resolve a BLOCK construct statement. */
11012
11013	static void
11014	resolve_block_construct (gfc_code* code)
11015	{
11016	gfc_namespace *ns = code->ext.block.ns;
11017
11018	/* For an ASSOCIATE block, the associations (and their targets) are already
11019	resolved during resolve_symbol. Resolve the BLOCK's namespace. */
11020	gfc_resolve (ns);
11021	}
11022
11023
11024	/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
11025	DO code nodes. */
11026
11027	void
11028	gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
11029	{
11030	bool t;
11031
11032	for (; b; b = b->block)
11033	{
11034	t = gfc_resolve_expr (e: b->expr1);
11035	if (!gfc_resolve_expr (e: b->expr2))
11036	t = false;
11037
11038	switch (b->op)
11039	{
11040	case EXEC_IF:
11041	if (t && b->expr1 != NULL
11042	&& (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
11043	gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
11044	&b->expr1->where);
11045	break;
11046
11047	case EXEC_WHERE:
11048	if (t
11049	&& b->expr1 != NULL
11050	&& (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
11051	gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
11052	&b->expr1->where);
11053	break;
11054
11055	case EXEC_GOTO:
11056	resolve_branch (label: b->label1, code: b);
11057	break;
11058
11059	case EXEC_BLOCK:
11060	resolve_block_construct (code: b);
11061	break;
11062
11063	case EXEC_SELECT:
11064	case EXEC_SELECT_TYPE:
11065	case EXEC_SELECT_RANK:
11066	case EXEC_FORALL:
11067	case EXEC_DO:
11068	case EXEC_DO_WHILE:
11069	case EXEC_DO_CONCURRENT:
11070	case EXEC_CRITICAL:
11071	case EXEC_READ:
11072	case EXEC_WRITE:
11073	case EXEC_IOLENGTH:
11074	case EXEC_WAIT:
11075	break;
11076
11077	case EXEC_OMP_ATOMIC:
11078	case EXEC_OACC_ATOMIC:
11079	{
11080	/* Verify this before calling gfc_resolve_code, which might
11081	change it. */
11082	gcc_assert (b->op == EXEC_OMP_ATOMIC
11083	|| (b->next && b->next->op == EXEC_ASSIGN));
11084	}
11085	break;
11086
11087	case EXEC_OACC_PARALLEL_LOOP:
11088	case EXEC_OACC_PARALLEL:
11089	case EXEC_OACC_KERNELS_LOOP:
11090	case EXEC_OACC_KERNELS:
11091	case EXEC_OACC_SERIAL_LOOP:
11092	case EXEC_OACC_SERIAL:
11093	case EXEC_OACC_DATA:
11094	case EXEC_OACC_HOST_DATA:
11095	case EXEC_OACC_LOOP:
11096	case EXEC_OACC_UPDATE:
11097	case EXEC_OACC_WAIT:
11098	case EXEC_OACC_CACHE:
11099	case EXEC_OACC_ENTER_DATA:
11100	case EXEC_OACC_EXIT_DATA:
11101	case EXEC_OACC_ROUTINE:
11102	case EXEC_OMP_ALLOCATE:
11103	case EXEC_OMP_ALLOCATORS:
11104	case EXEC_OMP_ASSUME:
11105	case EXEC_OMP_CRITICAL:
11106	case EXEC_OMP_DISTRIBUTE:
11107	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
11108	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
11109	case EXEC_OMP_DISTRIBUTE_SIMD:
11110	case EXEC_OMP_DO:
11111	case EXEC_OMP_DO_SIMD:
11112	case EXEC_OMP_ERROR:
11113	case EXEC_OMP_LOOP:
11114	case EXEC_OMP_MASKED:
11115	case EXEC_OMP_MASKED_TASKLOOP:
11116	case EXEC_OMP_MASKED_TASKLOOP_SIMD:
11117	case EXEC_OMP_MASTER:
11118	case EXEC_OMP_MASTER_TASKLOOP:
11119	case EXEC_OMP_MASTER_TASKLOOP_SIMD:
11120	case EXEC_OMP_ORDERED:
11121	case EXEC_OMP_PARALLEL:
11122	case EXEC_OMP_PARALLEL_DO:
11123	case EXEC_OMP_PARALLEL_DO_SIMD:
11124	case EXEC_OMP_PARALLEL_LOOP:
11125	case EXEC_OMP_PARALLEL_MASKED:
11126	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
11127	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
11128	case EXEC_OMP_PARALLEL_MASTER:
11129	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
11130	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
11131	case EXEC_OMP_PARALLEL_SECTIONS:
11132	case EXEC_OMP_PARALLEL_WORKSHARE:
11133	case EXEC_OMP_SECTIONS:
11134	case EXEC_OMP_SIMD:
11135	case EXEC_OMP_SCOPE:
11136	case EXEC_OMP_SINGLE:
11137	case EXEC_OMP_TARGET:
11138	case EXEC_OMP_TARGET_DATA:
11139	case EXEC_OMP_TARGET_ENTER_DATA:
11140	case EXEC_OMP_TARGET_EXIT_DATA:
11141	case EXEC_OMP_TARGET_PARALLEL:
11142	case EXEC_OMP_TARGET_PARALLEL_DO:
11143	case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
11144	case EXEC_OMP_TARGET_PARALLEL_LOOP:
11145	case EXEC_OMP_TARGET_SIMD:
11146	case EXEC_OMP_TARGET_TEAMS:
11147	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
11148	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11149	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11150	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
11151	case EXEC_OMP_TARGET_TEAMS_LOOP:
11152	case EXEC_OMP_TARGET_UPDATE:
11153	case EXEC_OMP_TASK:
11154	case EXEC_OMP_TASKGROUP:
11155	case EXEC_OMP_TASKLOOP:
11156	case EXEC_OMP_TASKLOOP_SIMD:
11157	case EXEC_OMP_TASKWAIT:
11158	case EXEC_OMP_TASKYIELD:
11159	case EXEC_OMP_TEAMS:
11160	case EXEC_OMP_TEAMS_DISTRIBUTE:
11161	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
11162	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11163	case EXEC_OMP_TEAMS_LOOP:
11164	case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
11165	case EXEC_OMP_WORKSHARE:
11166	break;
11167
11168	default:
11169	gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
11170	}
11171
11172	gfc_resolve_code (b->next, ns);
11173	}
11174	}
11175
11176
11177	/* Does everything to resolve an ordinary assignment. Returns true
11178	if this is an interface assignment. */
11179	static bool
11180	resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
11181	{
11182	bool rval = false;
11183	gfc_expr *lhs;
11184	gfc_expr *rhs;
11185	int n;
11186	gfc_ref *ref;
11187	symbol_attribute attr;
11188
11189	if (gfc_extend_assign (code, ns))
11190	{
11191	gfc_expr** rhsptr;
11192
11193	if (code->op == EXEC_ASSIGN_CALL)
11194	{
11195	lhs = code->ext.actual->expr;
11196	rhsptr = &code->ext.actual->next->expr;
11197	}
11198	else
11199	{
11200	gfc_actual_arglist* args;
11201	gfc_typebound_proc* tbp;
11202
11203	gcc_assert (code->op == EXEC_COMPCALL);
11204
11205	args = code->expr1->value.compcall.actual;
11206	lhs = args->expr;
11207	rhsptr = &args->next->expr;
11208
11209	tbp = code->expr1->value.compcall.tbp;
11210	gcc_assert (!tbp->is_generic);
11211	}
11212
11213	/* Make a temporary rhs when there is a default initializer
11214	and rhs is the same symbol as the lhs. */
11215	if ((*rhsptr)->expr_type == EXPR_VARIABLE
11216	&& (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
11217	&& gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
11218	&& (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
11219	*rhsptr = gfc_get_parentheses (*rhsptr);
11220
11221	return true;
11222	}
11223
11224	lhs = code->expr1;
11225	rhs = code->expr2;
11226
11227	if ((lhs->symtree->n.sym->ts.type == BT_DERIVED
11228	|| lhs->symtree->n.sym->ts.type == BT_CLASS)
11229	&& !lhs->symtree->n.sym->attr.proc_pointer
11230	&& gfc_expr_attr (lhs).proc_pointer)
11231	{
11232	gfc_error ("Variable in the ordinary assignment at %L is a procedure "
11233	"pointer component",
11234	&lhs->where);
11235	return false;
11236	}
11237
11238	if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL)
11239	&& rhs->ts.type == BT_CHARACTER
11240	&& (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions))
11241	{
11242	/* Use of -fdec-char-conversions allows assignment of character data
11243	to non-character variables. This not permitted for nonconstant
11244	strings. */
11245	gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs),
11246	gfc_typename (lhs), &rhs->where);
11247	return false;
11248	}
11249
11250	/* Handle the case of a BOZ literal on the RHS. */
11251	if (rhs->ts.type == BT_BOZ)
11252	{
11253	if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
11254	"statement value nor an actual argument of "
11255	"INT/REAL/DBLE/CMPLX intrinsic subprogram",
11256	&rhs->where))
11257	return false;
11258
11259	switch (lhs->ts.type)
11260	{
11261	case BT_INTEGER:
11262	if (!gfc_boz2int (rhs, lhs->ts.kind))
11263	return false;
11264	break;
11265	case BT_REAL:
11266	if (!gfc_boz2real (rhs, lhs->ts.kind))
11267	return false;
11268	break;
11269	default:
11270	gfc_error ("Invalid use of BOZ literal constant at %L", &rhs->where);
11271	return false;
11272	}
11273	}
11274
11275	if (lhs->ts.type == BT_CHARACTER && warn_character_truncation)
11276	{
11277	HOST_WIDE_INT llen = 0, rlen = 0;
11278	if (lhs->ts.u.cl != NULL
11279	&& lhs->ts.u.cl->length != NULL
11280	&& lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11281	llen = gfc_mpz_get_hwi (lhs->ts.u.cl->length->value.integer);
11282
11283	if (rhs->expr_type == EXPR_CONSTANT)
11284	rlen = rhs->value.character.length;
11285
11286	else if (rhs->ts.u.cl != NULL
11287	&& rhs->ts.u.cl->length != NULL
11288	&& rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11289	rlen = gfc_mpz_get_hwi (rhs->ts.u.cl->length->value.integer);
11290
11291	if (rlen && llen && rlen > llen)
11292	gfc_warning_now (opt: OPT_Wcharacter_truncation,
11293	"CHARACTER expression will be truncated "
11294	"in assignment (%ld/%ld) at %L",
11295	(long) llen, (long) rlen, &code->loc);
11296	}
11297
11298	/* Ensure that a vector index expression for the lvalue is evaluated
11299	to a temporary if the lvalue symbol is referenced in it. */
11300	if (lhs->rank)
11301	{
11302	for (ref = lhs->ref; ref; ref= ref->next)
11303	if (ref->type == REF_ARRAY)
11304	{
11305	for (n = 0; n < ref->u.ar.dimen; n++)
11306	if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
11307	&& gfc_find_sym_in_expr (sym: lhs->symtree->n.sym,
11308	e: ref->u.ar.start[n]))
11309	ref->u.ar.start[n]
11310	= gfc_get_parentheses (ref->u.ar.start[n]);
11311	}
11312	}
11313
11314	if (gfc_pure (NULL))
11315	{
11316	if (lhs->ts.type == BT_DERIVED
11317	&& lhs->expr_type == EXPR_VARIABLE
11318	&& lhs->ts.u.derived->attr.pointer_comp
11319	&& rhs->expr_type == EXPR_VARIABLE
11320	&& (gfc_impure_variable (rhs->symtree->n.sym)
11321	|| gfc_is_coindexed (rhs)))
11322	{
11323	/* F2008, C1283. */
11324	if (gfc_is_coindexed (rhs))
11325	gfc_error ("Coindexed expression at %L is assigned to "
11326	"a derived type variable with a POINTER "
11327	"component in a PURE procedure",
11328	&rhs->where);
11329	else
11330	/* F2008, C1283 (4). */
11331	gfc_error ("In a pure subprogram an INTENT(IN) dummy argument "
11332	"shall not be used as the expr at %L of an intrinsic "
11333	"assignment statement in which the variable is of a "
11334	"derived type if the derived type has a pointer "
11335	"component at any level of component selection.",
11336	&rhs->where);
11337	return rval;
11338	}
11339
11340	/* Fortran 2008, C1283. */
11341	if (gfc_is_coindexed (lhs))
11342	{
11343	gfc_error ("Assignment to coindexed variable at %L in a PURE "
11344	"procedure", &rhs->where);
11345	return rval;
11346	}
11347	}
11348
11349	if (gfc_implicit_pure (NULL))
11350	{
11351	if (lhs->expr_type == EXPR_VARIABLE
11352	&& lhs->symtree->n.sym != gfc_current_ns->proc_name
11353	&& lhs->symtree->n.sym->ns != gfc_current_ns)
11354	gfc_unset_implicit_pure (NULL);
11355
11356	if (lhs->ts.type == BT_DERIVED
11357	&& lhs->expr_type == EXPR_VARIABLE
11358	&& lhs->ts.u.derived->attr.pointer_comp
11359	&& rhs->expr_type == EXPR_VARIABLE
11360	&& (gfc_impure_variable (rhs->symtree->n.sym)
11361	|| gfc_is_coindexed (rhs)))
11362	gfc_unset_implicit_pure (NULL);
11363
11364	/* Fortran 2008, C1283. */
11365	if (gfc_is_coindexed (lhs))
11366	gfc_unset_implicit_pure (NULL);
11367	}
11368
11369	/* F2008, 7.2.1.2. */
11370	attr = gfc_expr_attr (lhs);
11371	if (lhs->ts.type == BT_CLASS && attr.allocatable)
11372	{
11373	if (attr.codimension)
11374	{
11375	gfc_error ("Assignment to polymorphic coarray at %L is not "
11376	"permitted", &lhs->where);
11377	return false;
11378	}
11379	if (!gfc_notify_std (GFC_STD_F2008, "Assignment to an allocatable "
11380	"polymorphic variable at %L", &lhs->where))
11381	return false;
11382	if (!flag_realloc_lhs)
11383	{
11384	gfc_error ("Assignment to an allocatable polymorphic variable at %L "
11385	"requires %<-frealloc-lhs%>", &lhs->where);
11386	return false;
11387	}
11388	}
11389	else if (lhs->ts.type == BT_CLASS)
11390	{
11391	gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
11392	"assignment at %L - check that there is a matching specific "
11393	"subroutine for %<=%> operator", &lhs->where);
11394	return false;
11395	}
11396
11397	bool lhs_coindexed = gfc_is_coindexed (lhs);
11398
11399	/* F2008, Section 7.2.1.2. */
11400	if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs))
11401	{
11402	gfc_error ("Coindexed variable must not have an allocatable ultimate "
11403	"component in assignment at %L", &lhs->where);
11404	return false;
11405	}
11406
11407	/* Assign the 'data' of a class object to a derived type. */
11408	if (lhs->ts.type == BT_DERIVED
11409	&& rhs->ts.type == BT_CLASS
11410	&& rhs->expr_type != EXPR_ARRAY)
11411	gfc_add_data_component (rhs);
11412
11413	/* Make sure there is a vtable and, in particular, a _copy for the
11414	rhs type. */
11415	if (lhs->ts.type == BT_CLASS && rhs->ts.type != BT_CLASS)
11416	gfc_find_vtab (&rhs->ts);
11417
11418	bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB
11419	&& (lhs_coindexed
11420	|| (code->expr2->expr_type == EXPR_FUNCTION
11421	&& code->expr2->value.function.isym
11422	&& code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET
11423	&& (code->expr1->rank == 0 || code->expr2->rank != 0)
11424	&& !gfc_expr_attr (rhs).allocatable
11425	&& !gfc_has_vector_subscript (rhs)));
11426
11427	gfc_check_assign (lhs, rhs, 1, c: !caf_convert_to_send);
11428
11429	/* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
11430	Additionally, insert this code when the RHS is a CAF as we then use the
11431	GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
11432	the LHS is (re)allocatable or has a vector subscript. If the LHS is a
11433	noncoindexed array and the RHS is a coindexed scalar, use the normal code
11434	path. */
11435	if (caf_convert_to_send)
11436	{
11437	if (code->expr2->expr_type == EXPR_FUNCTION
11438	&& code->expr2->value.function.isym
11439	&& code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET)
11440	remove_caf_get_intrinsic (e: code->expr2);
11441	code->op = EXEC_CALL;
11442	gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true);
11443	code->resolved_sym = code->symtree->n.sym;
11444	code->resolved_sym->attr.flavor = FL_PROCEDURE;
11445	code->resolved_sym->attr.intrinsic = 1;
11446	code->resolved_sym->attr.subroutine = 1;
11447	code->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
11448	gfc_commit_symbol (code->resolved_sym);
11449	code->ext.actual = gfc_get_actual_arglist ();
11450	code->ext.actual->expr = lhs;
11451	code->ext.actual->next = gfc_get_actual_arglist ();
11452	code->ext.actual->next->expr = rhs;
11453	code->expr1 = NULL;
11454	code->expr2 = NULL;
11455	}
11456
11457	return false;
11458	}
11459
11460
11461	/* Add a component reference onto an expression. */
11462
11463	static void
11464	add_comp_ref (gfc_expr *e, gfc_component *c)
11465	{
11466	gfc_ref **ref;
11467	ref = &(e->ref);
11468	while (*ref)
11469	ref = &((*ref)->next);
11470	*ref = gfc_get_ref ();
11471	(*ref)->type = REF_COMPONENT;
11472	(*ref)->u.c.sym = e->ts.u.derived;
11473	(*ref)->u.c.component = c;
11474	e->ts = c->ts;
11475
11476	/* Add a full array ref, as necessary. */
11477	if (c->as)
11478	{
11479	gfc_add_full_array_ref (e, c->as);
11480	e->rank = c->as->rank;
11481	}
11482	}
11483
11484
11485	/* Build an assignment. Keep the argument 'op' for future use, so that
11486	pointer assignments can be made. */
11487
11488	static gfc_code *
11489	build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
11490	gfc_component *comp1, gfc_component *comp2, locus loc)
11491	{
11492	gfc_code *this_code;
11493
11494	this_code = gfc_get_code (op);
11495	this_code->next = NULL;
11496	this_code->expr1 = gfc_copy_expr (expr1);
11497	this_code->expr2 = gfc_copy_expr (expr2);
11498	this_code->loc = loc;
11499	if (comp1 && comp2)
11500	{
11501	add_comp_ref (e: this_code->expr1, c: comp1);
11502	add_comp_ref (e: this_code->expr2, c: comp2);
11503	}
11504
11505	return this_code;
11506	}
11507
11508
11509	/* Makes a temporary variable expression based on the characteristics of
11510	a given variable expression. */
11511
11512	static gfc_expr*
11513	get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
11514	{
11515	static int serial = 0;
11516	char name[GFC_MAX_SYMBOL_LEN];
11517	gfc_symtree *tmp;
11518	gfc_array_spec *as;
11519	gfc_array_ref *aref;
11520	gfc_ref *ref;
11521
11522	sprintf (s: name, GFC_PREFIX("DA%d"), serial++);
11523	gfc_get_sym_tree (name, ns, &tmp, false);
11524	gfc_add_type (tmp->n.sym, &e->ts, NULL);
11525
11526	if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER)
11527	tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
11528	NULL,
11529	e->value.character.length);
11530
11531	as = NULL;
11532	ref = NULL;
11533	aref = NULL;
11534
11535	/* Obtain the arrayspec for the temporary. */
11536	if (e->rank && e->expr_type != EXPR_ARRAY
11537	&& e->expr_type != EXPR_FUNCTION
11538	&& e->expr_type != EXPR_OP)
11539	{
11540	aref = gfc_find_array_ref (e);
11541	if (e->expr_type == EXPR_VARIABLE
11542	&& e->symtree->n.sym->as == aref->as)
11543	as = aref->as;
11544	else
11545	{
11546	for (ref = e->ref; ref; ref = ref->next)
11547	if (ref->type == REF_COMPONENT
11548	&& ref->u.c.component->as == aref->as)
11549	{
11550	as = aref->as;
11551	break;
11552	}
11553	}
11554	}
11555
11556	/* Add the attributes and the arrayspec to the temporary. */
11557	tmp->n.sym->attr = gfc_expr_attr (e);
11558	tmp->n.sym->attr.function = 0;
11559	tmp->n.sym->attr.proc_pointer = 0;
11560	tmp->n.sym->attr.result = 0;
11561	tmp->n.sym->attr.flavor = FL_VARIABLE;
11562	tmp->n.sym->attr.dummy = 0;
11563	tmp->n.sym->attr.use_assoc = 0;
11564	tmp->n.sym->attr.intent = INTENT_UNKNOWN;
11565
11566
11567	if (as)
11568	{
11569	tmp->n.sym->as = gfc_copy_array_spec (as);
11570	if (!ref)
11571	ref = e->ref;
11572	if (as->type == AS_DEFERRED)
11573	tmp->n.sym->attr.allocatable = 1;
11574	}
11575	else if (e->rank && (e->expr_type == EXPR_ARRAY
11576	|| e->expr_type == EXPR_FUNCTION
11577	|| e->expr_type == EXPR_OP))
11578	{
11579	tmp->n.sym->as = gfc_get_array_spec ();
11580	tmp->n.sym->as->type = AS_DEFERRED;
11581	tmp->n.sym->as->rank = e->rank;
11582	tmp->n.sym->attr.allocatable = 1;
11583	tmp->n.sym->attr.dimension = 1;
11584	}
11585	else
11586	tmp->n.sym->attr.dimension = 0;
11587
11588	gfc_set_sym_referenced (tmp->n.sym);
11589	gfc_commit_symbol (tmp->n.sym);
11590	e = gfc_lval_expr_from_sym (tmp->n.sym);
11591
11592	/* Should the lhs be a section, use its array ref for the
11593	temporary expression. */
11594	if (aref && aref->type != AR_FULL)
11595	{
11596	gfc_free_ref_list (e->ref);
11597	e->ref = gfc_copy_ref (ref);
11598	}
11599	return e;
11600	}
11601
11602
11603	/* Add one line of code to the code chain, making sure that 'head' and
11604	'tail' are appropriately updated. */
11605
11606	static void
11607	add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
11608	{
11609	gcc_assert (this_code);
11610	if (*head == NULL)
11611	*head = *tail = *this_code;
11612	else
11613	*tail = gfc_append_code (*tail, *this_code);
11614	*this_code = NULL;
11615	}
11616
11617
11618	/* Generate a final call from a variable expression */
11619
11620	static void
11621	generate_final_call (gfc_expr *tmp_expr, gfc_code **head, gfc_code **tail)
11622	{
11623	gfc_code *this_code;
11624	gfc_expr *final_expr = NULL;
11625	gfc_expr *size_expr;
11626	gfc_expr *fini_coarray;
11627
11628	gcc_assert (tmp_expr->expr_type == EXPR_VARIABLE);
11629	if (!gfc_is_finalizable (tmp_expr->ts.u.derived, &final_expr) || !final_expr)
11630	return;
11631
11632	/* Now generate the finalizer call. */
11633	this_code = gfc_get_code (EXEC_CALL);
11634	this_code->symtree = final_expr->symtree;
11635	this_code->resolved_sym = final_expr->symtree->n.sym;
11636
11637	//* Expression to be finalized */
11638	this_code->ext.actual = gfc_get_actual_arglist ();
11639	this_code->ext.actual->expr = gfc_copy_expr (tmp_expr);
11640
11641	/* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
11642	this_code->ext.actual->next = gfc_get_actual_arglist ();
11643	size_expr = gfc_get_expr ();
11644	size_expr->where = gfc_current_locus;
11645	size_expr->expr_type = EXPR_OP;
11646	size_expr->value.op.op = INTRINSIC_DIVIDE;
11647	size_expr->value.op.op1
11648	= gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_STORAGE_SIZE,
11649	"storage_size", gfc_current_locus, 2,
11650	gfc_lval_expr_from_sym (tmp_expr->symtree->n.sym),
11651	gfc_get_int_expr (gfc_index_integer_kind,
11652	NULL, 0));
11653	size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
11654	gfc_character_storage_size);
11655	size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
11656	size_expr->ts = size_expr->value.op.op1->ts;
11657	this_code->ext.actual->next->expr = size_expr;
11658
11659	/* fini_coarray */
11660	this_code->ext.actual->next->next = gfc_get_actual_arglist ();
11661	fini_coarray = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
11662	&tmp_expr->where);
11663	fini_coarray->value.logical = (int)gfc_expr_attr (tmp_expr).codimension;
11664	this_code->ext.actual->next->next->expr = fini_coarray;
11665
11666	add_code_to_chain (this_code: &this_code, head, tail);
11667
11668	}
11669
11670	/* Counts the potential number of part array references that would
11671	result from resolution of typebound defined assignments. */
11672
11673
11674	static int
11675	nonscalar_typebound_assign (gfc_symbol *derived, int depth)
11676	{
11677	gfc_component *c;
11678	int c_depth = 0, t_depth;
11679
11680	for (c= derived->components; c; c = c->next)
11681	{
11682	if ((!gfc_bt_struct (c->ts.type)
11683	|| c->attr.pointer
11684	|| c->attr.allocatable
11685	|| c->attr.proc_pointer_comp
11686	|| c->attr.class_pointer
11687	|| c->attr.proc_pointer)
11688	&& !c->attr.defined_assign_comp)
11689	continue;
11690
11691	if (c->as && c_depth == 0)
11692	c_depth = 1;
11693
11694	if (c->ts.u.derived->attr.defined_assign_comp)
11695	t_depth = nonscalar_typebound_assign (derived: c->ts.u.derived,
11696	depth: c->as ? 1 : 0);
11697	else
11698	t_depth = 0;
11699
11700	c_depth = t_depth > c_depth ? t_depth : c_depth;
11701	}
11702	return depth + c_depth;
11703	}
11704
11705
11706	/* Implement 10.2.1.3 paragraph 13 of the F18 standard:
11707	"An intrinsic assignment where the variable is of derived type is performed
11708	as if each component of the variable were assigned from the corresponding
11709	component of expr using pointer assignment (10.2.2) for each pointer
11710	component, defined assignment for each nonpointer nonallocatable component
11711	of a type that has a type-bound defined assignment consistent with the
11712	component, intrinsic assignment for each other nonpointer nonallocatable
11713	component, and intrinsic assignment for each allocated coarray component.
11714	For unallocated coarray components, the corresponding component of the
11715	variable shall be unallocated. For a noncoarray allocatable component the
11716	following sequence of operations is applied.
11717	(1) If the component of the variable is allocated, it is deallocated.
11718	(2) If the component of the value of expr is allocated, the
11719	corresponding component of the variable is allocated with the same
11720	dynamic type and type parameters as the component of the value of
11721	expr. If it is an array, it is allocated with the same bounds. The
11722	value of the component of the value of expr is then assigned to the
11723	corresponding component of the variable using defined assignment if
11724	the declared type of the component has a type-bound defined
11725	assignment consistent with the component, and intrinsic assignment
11726	for the dynamic type of that component otherwise."
11727
11728	The pointer assignments are taken care of by the intrinsic assignment of the
11729	structure itself. This function recursively adds defined assignments where
11730	required. The recursion is accomplished by calling gfc_resolve_code.
11731
11732	When the lhs in a defined assignment has intent INOUT or is intent OUT
11733	and the component of 'var' is finalizable, we need a temporary for the
11734	lhs. In pseudo-code for an assignment var = expr:
11735
11736	! Confine finalization of temporaries, as far as possible.
11737	Enclose the code for the assignment in a block
11738	! Only call function 'expr' once.
11739	#if ('expr is not a constant or an variable)
11740	temp_expr = expr
11741	expr = temp_x
11742	! Do the intrinsic assignment
11743	#if typeof ('var') has a typebound final subroutine
11744	finalize (var)
11745	var = expr
11746	! Now do the component assignments
11747	#do over derived type components [%cmp]
11748	#if (cmp is a pointer of any kind)
11749	continue
11750	build the assignment
11751	resolve the code
11752	#if the code is a typebound assignment
11753	#if (arg1 is INOUT or finalizable OUT && !t1)
11754	t1 = var
11755	arg1 = t1
11756	deal with allocatation or not of var and this component
11757	#elseif the code is an assignment by itself
11758	#if this component does not need finalization
11759	delete code and continue
11760	#else
11761	remove the leading assignment
11762	#endif
11763	commit the code
11764	#if (t1 and (arg1 is INOUT or finalizable OUT))
11765	var%cmp = t1%cmp
11766	#enddo
11767	put all code chunks involving t1 to the top of the generated code
11768	insert the generated block in place of the original code
11769	*/
11770
11771	static bool
11772	is_finalizable_type (gfc_typespec ts)
11773	{
11774	gfc_component *c;
11775
11776	if (ts.type != BT_DERIVED)
11777	return false;
11778
11779	/* (1) Check for FINAL subroutines. */
11780	if (ts.u.derived->f2k_derived && ts.u.derived->f2k_derived->finalizers)
11781	return true;
11782
11783	/* (2) Check for components of finalizable type. */
11784	for (c = ts.u.derived->components; c; c = c->next)
11785	if (c->ts.type == BT_DERIVED
11786	&& !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
11787	&& c->ts.u.derived->f2k_derived
11788	&& c->ts.u.derived->f2k_derived->finalizers)
11789	return true;
11790
11791	return false;
11792	}
11793
11794	/* The temporary assignments have to be put on top of the additional
11795	code to avoid the result being changed by the intrinsic assignment.
11796	*/
11797	static int component_assignment_level = 0;
11798	static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
11799	static bool finalizable_comp;
11800
11801	static void
11802	generate_component_assignments (gfc_code **code, gfc_namespace *ns)
11803	{
11804	gfc_component *comp1, *comp2;
11805	gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
11806	gfc_code *tmp_code = NULL;
11807	gfc_expr *t1 = NULL;
11808	gfc_expr *tmp_expr = NULL;
11809	int error_count, depth;
11810	bool finalizable_lhs;
11811
11812	gfc_get_errors (NULL, &error_count);
11813
11814	/* Filter out continuing processing after an error. */
11815	if (error_count
11816	|| (*code)->expr1->ts.type != BT_DERIVED
11817	|| (*code)->expr2->ts.type != BT_DERIVED)
11818	return;
11819
11820	/* TODO: Handle more than one part array reference in assignments. */
11821	depth = nonscalar_typebound_assign (derived: (*code)->expr1->ts.u.derived,
11822	depth: (*code)->expr1->rank ? 1 : 0);
11823	if (depth > 1)
11824	{
11825	gfc_warning (opt: 0, "TODO: type-bound defined assignment(s) at %L not "
11826	"done because multiple part array references would "
11827	"occur in intermediate expressions.", &(*code)->loc);
11828	return;
11829	}
11830
11831	if (!component_assignment_level)
11832	finalizable_comp = true;
11833
11834	/* Build a block so that function result temporaries are finalized
11835	locally on exiting the rather than enclosing scope. */
11836	if (!component_assignment_level)
11837	{
11838	ns = gfc_build_block_ns (ns);
11839	tmp_code = gfc_get_code (EXEC_NOP);
11840	*tmp_code = **code;
11841	tmp_code->next = NULL;
11842	(*code)->op = EXEC_BLOCK;
11843	(*code)->ext.block.ns = ns;
11844	(*code)->ext.block.assoc = NULL;
11845	(*code)->expr1 = (*code)->expr2 = NULL;
11846	ns->code = tmp_code;
11847	code = &ns->code;
11848	}
11849
11850	component_assignment_level++;
11851
11852	finalizable_lhs = is_finalizable_type (ts: (*code)->expr1->ts);
11853
11854	/* Create a temporary so that functions get called only once. */
11855	if ((*code)->expr2->expr_type != EXPR_VARIABLE
11856	&& (*code)->expr2->expr_type != EXPR_CONSTANT)
11857	{
11858	/* Assign the rhs to the temporary. */
11859	tmp_expr = get_temp_from_expr (e: (*code)->expr1, ns);
11860	this_code = build_assignment (op: EXEC_ASSIGN,
11861	expr1: tmp_expr, expr2: (*code)->expr2,
11862	NULL, NULL, loc: (*code)->loc);
11863	this_code->expr2->must_finalize = 1;
11864	/* Add the code and substitute the rhs expression. */
11865	add_code_to_chain (this_code: &this_code, head: &tmp_head, tail: &tmp_tail);
11866	gfc_free_expr ((*code)->expr2);
11867	(*code)->expr2 = tmp_expr;
11868	}
11869
11870	/* Do the intrinsic assignment. This is not needed if the lhs is one
11871	of the temporaries generated here, since the intrinsic assignment
11872	to the final result already does this. */
11873	if ((*code)->expr1->symtree->n.sym->name[2] != '.')
11874	{
11875	if (finalizable_lhs)
11876	(*code)->expr1->must_finalize = 1;
11877	this_code = build_assignment (op: EXEC_ASSIGN,
11878	expr1: (*code)->expr1, expr2: (*code)->expr2,
11879	NULL, NULL, loc: (*code)->loc);
11880	add_code_to_chain (this_code: &this_code, head: &head, tail: &tail);
11881	}
11882
11883	comp1 = (*code)->expr1->ts.u.derived->components;
11884	comp2 = (*code)->expr2->ts.u.derived->components;
11885
11886	for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
11887	{
11888	bool inout = false;
11889	bool finalizable_out = false;
11890
11891	/* The intrinsic assignment does the right thing for pointers
11892	of all kinds and allocatable components. */
11893	if (!gfc_bt_struct (comp1->ts.type)
11894	|| comp1->attr.pointer
11895	|| comp1->attr.allocatable
11896	|| comp1->attr.proc_pointer_comp
11897	|| comp1->attr.class_pointer
11898	|| comp1->attr.proc_pointer)
11899	continue;
11900
11901	finalizable_comp = is_finalizable_type (ts: comp1->ts)
11902	&& !finalizable_lhs;
11903
11904	/* Make an assignment for this component. */
11905	this_code = build_assignment (op: EXEC_ASSIGN,
11906	expr1: (*code)->expr1, expr2: (*code)->expr2,
11907	comp1, comp2, loc: (*code)->loc);
11908
11909	/* Convert the assignment if there is a defined assignment for
11910	this type. Otherwise, using the call from gfc_resolve_code,
11911	recurse into its components. */
11912	gfc_resolve_code (this_code, ns);
11913
11914	if (this_code->op == EXEC_ASSIGN_CALL)
11915	{
11916	gfc_formal_arglist *dummy_args;
11917	gfc_symbol *rsym;
11918	/* Check that there is a typebound defined assignment. If not,
11919	then this must be a module defined assignment. We cannot
11920	use the defined_assign_comp attribute here because it must
11921	be this derived type that has the defined assignment and not
11922	a parent type. */
11923	if (!(comp1->ts.u.derived->f2k_derived
11924	&& comp1->ts.u.derived->f2k_derived
11925	->tb_op[INTRINSIC_ASSIGN]))
11926	{
11927	gfc_free_statements (this_code);
11928	this_code = NULL;
11929	continue;
11930	}
11931
11932	/* If the first argument of the subroutine has intent INOUT
11933	a temporary must be generated and used instead. */
11934	rsym = this_code->resolved_sym;
11935	dummy_args = gfc_sym_get_dummy_args (rsym);
11936	finalizable_out = gfc_may_be_finalized (comp1->ts)
11937	&& dummy_args
11938	&& dummy_args->sym->attr.intent == INTENT_OUT;
11939	inout = dummy_args
11940	&& dummy_args->sym->attr.intent == INTENT_INOUT;
11941	if ((inout || finalizable_out)
11942	&& !comp1->attr.allocatable)
11943	{
11944	gfc_code *temp_code;
11945	inout = true;
11946
11947	/* Build the temporary required for the assignment and put
11948	it at the head of the generated code. */
11949	if (!t1)
11950	{
11951	gfc_namespace *tmp_ns = ns;
11952	if (ns->parent && gfc_may_be_finalized (comp1->ts))
11953	tmp_ns = (*code)->expr1->symtree->n.sym->ns;
11954	t1 = get_temp_from_expr (e: (*code)->expr1, ns: tmp_ns);
11955	t1->symtree->n.sym->attr.artificial = 1;
11956	temp_code = build_assignment (op: EXEC_ASSIGN,
11957	expr1: t1, expr2: (*code)->expr1,
11958	NULL, NULL, loc: (*code)->loc);
11959
11960	/* For allocatable LHS, check whether it is allocated. Note
11961	that allocatable components with defined assignment are
11962	not yet support. See PR 57696. */
11963	if ((*code)->expr1->symtree->n.sym->attr.allocatable)
11964	{
11965	gfc_code *block;
11966	gfc_expr *e =
11967	gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
11968	block = gfc_get_code (EXEC_IF);
11969	block->block = gfc_get_code (EXEC_IF);
11970	block->block->expr1
11971	= gfc_build_intrinsic_call (ns,
11972	GFC_ISYM_ALLOCATED, "allocated",
11973	(*code)->loc, 1, e);
11974	block->block->next = temp_code;
11975	temp_code = block;
11976	}
11977	add_code_to_chain (this_code: &temp_code, head: &tmp_head, tail: &tmp_tail);
11978	}
11979
11980	/* Replace the first actual arg with the component of the
11981	temporary. */
11982	gfc_free_expr (this_code->ext.actual->expr);
11983	this_code->ext.actual->expr = gfc_copy_expr (t1);
11984	add_comp_ref (e: this_code->ext.actual->expr, c: comp1);
11985
11986	/* If the LHS variable is allocatable and wasn't allocated and
11987	the temporary is allocatable, pointer assign the address of
11988	the freshly allocated LHS to the temporary. */
11989	if ((*code)->expr1->symtree->n.sym->attr.allocatable
11990	&& gfc_expr_attr ((*code)->expr1).allocatable)
11991	{
11992	gfc_code *block;
11993	gfc_expr *cond;
11994
11995	cond = gfc_get_expr ();
11996	cond->ts.type = BT_LOGICAL;
11997	cond->ts.kind = gfc_default_logical_kind;
11998	cond->expr_type = EXPR_OP;
11999	cond->where = (*code)->loc;
12000	cond->value.op.op = INTRINSIC_NOT;
12001	cond->value.op.op1 = gfc_build_intrinsic_call (ns,
12002	GFC_ISYM_ALLOCATED, "allocated",
12003	(*code)->loc, 1, gfc_copy_expr (t1));
12004	block = gfc_get_code (EXEC_IF);
12005	block->block = gfc_get_code (EXEC_IF);
12006	block->block->expr1 = cond;
12007	block->block->next = build_assignment (op: EXEC_POINTER_ASSIGN,
12008	expr1: t1, expr2: (*code)->expr1,
12009	NULL, NULL, loc: (*code)->loc);
12010	add_code_to_chain (this_code: &block, head: &head, tail: &tail);
12011	}
12012	}
12013	}
12014	else if (this_code->op == EXEC_ASSIGN && !this_code->next)
12015	{
12016	/* Don't add intrinsic assignments since they are already
12017	effected by the intrinsic assignment of the structure, unless
12018	finalization is required. */
12019	if (finalizable_comp)
12020	this_code->expr1->must_finalize = 1;
12021	else
12022	{
12023	gfc_free_statements (this_code);
12024	this_code = NULL;
12025	continue;
12026	}
12027	}
12028	else
12029	{
12030	/* Resolution has expanded an assignment of a derived type with
12031	defined assigned components. Remove the redundant, leading
12032	assignment. */
12033	gcc_assert (this_code->op == EXEC_ASSIGN);
12034	gfc_code *tmp = this_code;
12035	this_code = this_code->next;
12036	tmp->next = NULL;
12037	gfc_free_statements (tmp);
12038	}
12039
12040	add_code_to_chain (this_code: &this_code, head: &head, tail: &tail);
12041
12042	if (t1 && (inout || finalizable_out))
12043	{
12044	/* Transfer the value to the final result. */
12045	this_code = build_assignment (op: EXEC_ASSIGN,
12046	expr1: (*code)->expr1, expr2: t1,
12047	comp1, comp2, loc: (*code)->loc);
12048	this_code->expr1->must_finalize = 0;
12049	add_code_to_chain (this_code: &this_code, head: &head, tail: &tail);
12050	}
12051	}
12052
12053	/* Put the temporary assignments at the top of the generated code. */
12054	if (tmp_head && component_assignment_level == 1)
12055	{
12056	gfc_append_code (tmp_head, head);
12057	head = tmp_head;
12058	tmp_head = tmp_tail = NULL;
12059	}
12060
12061	/* If we did a pointer assignment - thus, we need to ensure that the LHS is
12062	not accidentally deallocated. Hence, nullify t1. */
12063	if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable
12064	&& gfc_expr_attr ((*code)->expr1).allocatable)
12065	{
12066	gfc_code *block;
12067	gfc_expr *cond;
12068	gfc_expr *e;
12069
12070	e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
12071	cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated",
12072	(*code)->loc, 2, gfc_copy_expr (t1), e);
12073	block = gfc_get_code (EXEC_IF);
12074	block->block = gfc_get_code (EXEC_IF);
12075	block->block->expr1 = cond;
12076	block->block->next = build_assignment (op: EXEC_POINTER_ASSIGN,
12077	expr1: t1, expr2: gfc_get_null_expr (&(*code)->loc),
12078	NULL, NULL, loc: (*code)->loc);
12079	gfc_append_code (tail, block);
12080	tail = block;
12081	}
12082
12083	component_assignment_level--;
12084
12085	/* Make an explicit final call for the function result. */
12086	if (tmp_expr)
12087	generate_final_call (tmp_expr, head: &head, tail: &tail);
12088
12089	if (tmp_code)
12090	{
12091	ns->code = head;
12092	return;
12093	}
12094
12095	/* Now attach the remaining code chain to the input code. Step on
12096	to the end of the new code since resolution is complete. */
12097	gcc_assert ((*code)->op == EXEC_ASSIGN);
12098	tail->next = (*code)->next;
12099	/* Overwrite 'code' because this would place the intrinsic assignment
12100	before the temporary for the lhs is created. */
12101	gfc_free_expr ((*code)->expr1);
12102	gfc_free_expr ((*code)->expr2);
12103	**code = *head;
12104	if (head != tail)
12105	free (ptr: head);
12106	*code = tail;
12107	}
12108
12109
12110	/* F2008: Pointer function assignments are of the form:
12111	ptr_fcn (args) = expr
12112	This function breaks these assignments into two statements:
12113	temporary_pointer => ptr_fcn(args)
12114	temporary_pointer = expr */
12115
12116	static bool
12117	resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns)
12118	{
12119	gfc_expr *tmp_ptr_expr;
12120	gfc_code *this_code;
12121	gfc_component *comp;
12122	gfc_symbol *s;
12123
12124	if ((*code)->expr1->expr_type != EXPR_FUNCTION)
12125	return false;
12126
12127	/* Even if standard does not support this feature, continue to build
12128	the two statements to avoid upsetting frontend_passes.c. */
12129	gfc_notify_std (GFC_STD_F2008, "Pointer procedure assignment at "
12130	"%L", &(*code)->loc);
12131
12132	comp = gfc_get_proc_ptr_comp ((*code)->expr1);
12133
12134	if (comp)
12135	s = comp->ts.interface;
12136	else
12137	s = (*code)->expr1->symtree->n.sym;
12138
12139	if (s == NULL || !s->result->attr.pointer)
12140	{
12141	gfc_error ("The function result on the lhs of the assignment at "
12142	"%L must have the pointer attribute.",
12143	&(*code)->expr1->where);
12144	(*code)->op = EXEC_NOP;
12145	return false;
12146	}
12147
12148	tmp_ptr_expr = get_temp_from_expr (e: (*code)->expr1, ns);
12149
12150	/* get_temp_from_expression is set up for ordinary assignments. To that
12151	end, where array bounds are not known, arrays are made allocatable.
12152	Change the temporary to a pointer here. */
12153	tmp_ptr_expr->symtree->n.sym->attr.pointer = 1;
12154	tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0;
12155	tmp_ptr_expr->where = (*code)->loc;
12156
12157	this_code = build_assignment (op: EXEC_ASSIGN,
12158	expr1: tmp_ptr_expr, expr2: (*code)->expr2,
12159	NULL, NULL, loc: (*code)->loc);
12160	this_code->next = (*code)->next;
12161	(*code)->next = this_code;
12162	(*code)->op = EXEC_POINTER_ASSIGN;
12163	(*code)->expr2 = (*code)->expr1;
12164	(*code)->expr1 = tmp_ptr_expr;
12165
12166	return true;
12167	}
12168
12169
12170	/* Deferred character length assignments from an operator expression
12171	require a temporary because the character length of the lhs can
12172	change in the course of the assignment. */
12173
12174	static bool
12175	deferred_op_assign (gfc_code **code, gfc_namespace *ns)
12176	{
12177	gfc_expr *tmp_expr;
12178	gfc_code *this_code;
12179
12180	if (!((*code)->expr1->ts.type == BT_CHARACTER
12181	&& (*code)->expr1->ts.deferred && (*code)->expr1->rank
12182	&& (*code)->expr2->ts.type == BT_CHARACTER
12183	&& (*code)->expr2->expr_type == EXPR_OP))
12184	return false;
12185
12186	if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
12187	return false;
12188
12189	if (gfc_expr_attr ((*code)->expr1).pointer)
12190	return false;
12191
12192	tmp_expr = get_temp_from_expr (e: (*code)->expr1, ns);
12193	tmp_expr->where = (*code)->loc;
12194
12195	/* A new charlen is required to ensure that the variable string
12196	length is different to that of the original lhs. */
12197	tmp_expr->ts.u.cl = gfc_get_charlen();
12198	tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl;
12199	tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next;
12200	(*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl;
12201
12202	tmp_expr->symtree->n.sym->ts.deferred = 1;
12203
12204	this_code = build_assignment (op: EXEC_ASSIGN,
12205	expr1: (*code)->expr1,
12206	expr2: gfc_copy_expr (tmp_expr),
12207	NULL, NULL, loc: (*code)->loc);
12208
12209	(*code)->expr1 = tmp_expr;
12210
12211	this_code->next = (*code)->next;
12212	(*code)->next = this_code;
12213
12214	return true;
12215	}
12216
12217
12218	static bool
12219	check_team (gfc_expr *team, const char *intrinsic)
12220	{
12221	if (team->rank != 0
12222	|| team->ts.type != BT_DERIVED
12223	|| team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
12224	|| team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
12225	{
12226	gfc_error ("TEAM argument to %qs at %L must be a scalar expression "
12227	"of type TEAM_TYPE", intrinsic, &team->where);
12228	return false;
12229	}
12230
12231	return true;
12232	}
12233
12234
12235	/* Given a block of code, recursively resolve everything pointed to by this
12236	code block. */
12237
12238	void
12239	gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
12240	{
12241	int omp_workshare_save;
12242	int forall_save, do_concurrent_save;
12243	code_stack frame;
12244	bool t;
12245
12246	frame.prev = cs_base;
12247	frame.head = code;
12248	cs_base = &frame;
12249
12250	find_reachable_labels (block: code);
12251
12252	for (; code; code = code->next)
12253	{
12254	frame.current = code;
12255	forall_save = forall_flag;
12256	do_concurrent_save = gfc_do_concurrent_flag;
12257
12258	if (code->op == EXEC_FORALL)
12259	{
12260	forall_flag = 1;
12261	gfc_resolve_forall (code, ns, forall_save);
12262	forall_flag = 2;
12263	}
12264	else if (code->block)
12265	{
12266	omp_workshare_save = -1;
12267	switch (code->op)
12268	{
12269	case EXEC_OACC_PARALLEL_LOOP:
12270	case EXEC_OACC_PARALLEL:
12271	case EXEC_OACC_KERNELS_LOOP:
12272	case EXEC_OACC_KERNELS:
12273	case EXEC_OACC_SERIAL_LOOP:
12274	case EXEC_OACC_SERIAL:
12275	case EXEC_OACC_DATA:
12276	case EXEC_OACC_HOST_DATA:
12277	case EXEC_OACC_LOOP:
12278	gfc_resolve_oacc_blocks (code, ns);
12279	break;
12280	case EXEC_OMP_PARALLEL_WORKSHARE:
12281	omp_workshare_save = omp_workshare_flag;
12282	omp_workshare_flag = 1;
12283	gfc_resolve_omp_parallel_blocks (code, ns);
12284	break;
12285	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12286	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12287	case EXEC_OMP_MASKED_TASKLOOP:
12288	case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12289	case EXEC_OMP_MASTER_TASKLOOP:
12290	case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12291	case EXEC_OMP_PARALLEL:
12292	case EXEC_OMP_PARALLEL_DO:
12293	case EXEC_OMP_PARALLEL_DO_SIMD:
12294	case EXEC_OMP_PARALLEL_LOOP:
12295	case EXEC_OMP_PARALLEL_MASKED:
12296	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12297	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12298	case EXEC_OMP_PARALLEL_MASTER:
12299	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12300	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12301	case EXEC_OMP_PARALLEL_SECTIONS:
12302	case EXEC_OMP_TARGET_PARALLEL:
12303	case EXEC_OMP_TARGET_PARALLEL_DO:
12304	case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12305	case EXEC_OMP_TARGET_PARALLEL_LOOP:
12306	case EXEC_OMP_TARGET_TEAMS:
12307	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12308	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12309	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12310	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12311	case EXEC_OMP_TARGET_TEAMS_LOOP:
12312	case EXEC_OMP_TASK:
12313	case EXEC_OMP_TASKLOOP:
12314	case EXEC_OMP_TASKLOOP_SIMD:
12315	case EXEC_OMP_TEAMS:
12316	case EXEC_OMP_TEAMS_DISTRIBUTE:
12317	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12318	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12319	case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12320	case EXEC_OMP_TEAMS_LOOP:
12321	omp_workshare_save = omp_workshare_flag;
12322	omp_workshare_flag = 0;
12323	gfc_resolve_omp_parallel_blocks (code, ns);
12324	break;
12325	case EXEC_OMP_DISTRIBUTE:
12326	case EXEC_OMP_DISTRIBUTE_SIMD:
12327	case EXEC_OMP_DO:
12328	case EXEC_OMP_DO_SIMD:
12329	case EXEC_OMP_LOOP:
12330	case EXEC_OMP_SIMD:
12331	case EXEC_OMP_TARGET_SIMD:
12332	gfc_resolve_omp_do_blocks (code, ns);
12333	break;
12334	case EXEC_SELECT_TYPE:
12335	case EXEC_SELECT_RANK:
12336	/* Blocks are handled in resolve_select_type/rank because we
12337	have to transform the SELECT TYPE into ASSOCIATE first. */
12338	break;
12339	case EXEC_DO_CONCURRENT:
12340	gfc_do_concurrent_flag = 1;
12341	gfc_resolve_blocks (b: code->block, ns);
12342	gfc_do_concurrent_flag = 2;
12343	break;
12344	case EXEC_OMP_WORKSHARE:
12345	omp_workshare_save = omp_workshare_flag;
12346	omp_workshare_flag = 1;
12347	/* FALL THROUGH */
12348	default:
12349	gfc_resolve_blocks (b: code->block, ns);
12350	break;
12351	}
12352
12353	if (omp_workshare_save != -1)
12354	omp_workshare_flag = omp_workshare_save;
12355	}
12356	start:
12357	t = true;
12358	if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
12359	t = gfc_resolve_expr (e: code->expr1);
12360	forall_flag = forall_save;
12361	gfc_do_concurrent_flag = do_concurrent_save;
12362
12363	if (!gfc_resolve_expr (e: code->expr2))
12364	t = false;
12365
12366	if (code->op == EXEC_ALLOCATE
12367	&& !gfc_resolve_expr (e: code->expr3))
12368	t = false;
12369
12370	switch (code->op)
12371	{
12372	case EXEC_NOP:
12373	case EXEC_END_BLOCK:
12374	case EXEC_END_NESTED_BLOCK:
12375	case EXEC_CYCLE:
12376	case EXEC_PAUSE:
12377	break;
12378
12379	case EXEC_STOP:
12380	case EXEC_ERROR_STOP:
12381	if (code->expr2 != NULL
12382	&& (code->expr2->ts.type != BT_LOGICAL
12383	|| code->expr2->rank != 0))
12384	gfc_error ("QUIET specifier at %L must be a scalar LOGICAL",
12385	&code->expr2->where);
12386	break;
12387
12388	case EXEC_EXIT:
12389	case EXEC_CONTINUE:
12390	case EXEC_DT_END:
12391	case EXEC_ASSIGN_CALL:
12392	break;
12393
12394	case EXEC_CRITICAL:
12395	resolve_critical (code);
12396	break;
12397
12398	case EXEC_SYNC_ALL:
12399	case EXEC_SYNC_IMAGES:
12400	case EXEC_SYNC_MEMORY:
12401	resolve_sync (code);
12402	break;
12403
12404	case EXEC_LOCK:
12405	case EXEC_UNLOCK:
12406	case EXEC_EVENT_POST:
12407	case EXEC_EVENT_WAIT:
12408	resolve_lock_unlock_event (code);
12409	break;
12410
12411	case EXEC_FAIL_IMAGE:
12412	break;
12413
12414	case EXEC_FORM_TEAM:
12415	if (code->expr1 != NULL
12416	&& (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
12417	gfc_error ("TEAM NUMBER argument to FORM TEAM at %L must be "
12418	"a scalar INTEGER", &code->expr1->where);
12419	check_team (team: code->expr2, intrinsic: "FORM TEAM");
12420	break;
12421
12422	case EXEC_CHANGE_TEAM:
12423	check_team (team: code->expr1, intrinsic: "CHANGE TEAM");
12424	break;
12425
12426	case EXEC_END_TEAM:
12427	break;
12428
12429	case EXEC_SYNC_TEAM:
12430	check_team (team: code->expr1, intrinsic: "SYNC TEAM");
12431	break;
12432
12433	case EXEC_ENTRY:
12434	/* Keep track of which entry we are up to. */
12435	current_entry_id = code->ext.entry->id;
12436	break;
12437
12438	case EXEC_WHERE:
12439	resolve_where (code, NULL);
12440	break;
12441
12442	case EXEC_GOTO:
12443	if (code->expr1 != NULL)
12444	{
12445	if (code->expr1->expr_type != EXPR_VARIABLE
12446	|| code->expr1->ts.type != BT_INTEGER
12447	|| (code->expr1->ref
12448	&& code->expr1->ref->type == REF_ARRAY)
12449	|| code->expr1->symtree == NULL
12450	|| (code->expr1->symtree->n.sym
12451	&& (code->expr1->symtree->n.sym->attr.flavor
12452	== FL_PARAMETER)))
12453	gfc_error ("ASSIGNED GOTO statement at %L requires a "
12454	"scalar INTEGER variable", &code->expr1->where);
12455	else if (code->expr1->symtree->n.sym
12456	&& code->expr1->symtree->n.sym->attr.assign != 1)
12457	gfc_error ("Variable %qs has not been assigned a target "
12458	"label at %L", code->expr1->symtree->n.sym->name,
12459	&code->expr1->where);
12460	}
12461	else
12462	resolve_branch (label: code->label1, code);
12463	break;
12464
12465	case EXEC_RETURN:
12466	if (code->expr1 != NULL
12467	&& (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
12468	gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
12469	"INTEGER return specifier", &code->expr1->where);
12470	break;
12471
12472	case EXEC_INIT_ASSIGN:
12473	case EXEC_END_PROCEDURE:
12474	break;
12475
12476	case EXEC_ASSIGN:
12477	if (!t)
12478	break;
12479
12480	if (code->expr1->ts.type == BT_CLASS)
12481	gfc_find_vtab (&code->expr2->ts);
12482
12483	/* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
12484	the LHS. */
12485	if (code->expr1->expr_type == EXPR_FUNCTION
12486	&& code->expr1->value.function.isym
12487	&& code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
12488	remove_caf_get_intrinsic (e: code->expr1);
12489
12490	/* If this is a pointer function in an lvalue variable context,
12491	the new code will have to be resolved afresh. This is also the
12492	case with an error, where the code is transformed into NOP to
12493	prevent ICEs downstream. */
12494	if (resolve_ptr_fcn_assign (code: &code, ns)
12495	|| code->op == EXEC_NOP)
12496	goto start;
12497
12498	if (!gfc_check_vardef_context (code->expr1, false, false, false,
12499	_("assignment")))
12500	break;
12501
12502	if (resolve_ordinary_assign (code, ns))
12503	{
12504	if (omp_workshare_flag)
12505	{
12506	gfc_error ("Expected intrinsic assignment in OMP WORKSHARE "
12507	"at %L", &code->loc);
12508	break;
12509	}
12510	if (code->op == EXEC_COMPCALL)
12511	goto compcall;
12512	else
12513	goto call;
12514	}
12515
12516	/* Check for dependencies in deferred character length array
12517	assignments and generate a temporary, if necessary. */
12518	if (code->op == EXEC_ASSIGN && deferred_op_assign (code: &code, ns))
12519	break;
12520
12521	/* F03 7.4.1.3 for non-allocatable, non-pointer components. */
12522	if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
12523	&& code->expr1->ts.u.derived
12524	&& code->expr1->ts.u.derived->attr.defined_assign_comp)
12525	generate_component_assignments (code: &code, ns);
12526	else if (code->op == EXEC_ASSIGN)
12527	{
12528	if (gfc_may_be_finalized (code->expr1->ts))
12529	code->expr1->must_finalize = 1;
12530	if (code->expr2->expr_type == EXPR_ARRAY
12531	&& gfc_may_be_finalized (code->expr2->ts))
12532	code->expr2->must_finalize = 1;
12533	}
12534
12535	break;
12536
12537	case EXEC_LABEL_ASSIGN:
12538	if (code->label1->defined == ST_LABEL_UNKNOWN)
12539	gfc_error ("Label %d referenced at %L is never defined",
12540	code->label1->value, &code->label1->where);
12541	if (t
12542	&& (code->expr1->expr_type != EXPR_VARIABLE
12543	|| code->expr1->symtree->n.sym->ts.type != BT_INTEGER
12544	|| code->expr1->symtree->n.sym->ts.kind
12545	!= gfc_default_integer_kind
12546	|| code->expr1->symtree->n.sym->attr.flavor == FL_PARAMETER
12547	|| code->expr1->symtree->n.sym->as != NULL))
12548	gfc_error ("ASSIGN statement at %L requires a scalar "
12549	"default INTEGER variable", &code->expr1->where);
12550	break;
12551
12552	case EXEC_POINTER_ASSIGN:
12553	{
12554	gfc_expr* e;
12555
12556	if (!t)
12557	break;
12558
12559	/* This is both a variable definition and pointer assignment
12560	context, so check both of them. For rank remapping, a final
12561	array ref may be present on the LHS and fool gfc_expr_attr
12562	used in gfc_check_vardef_context. Remove it. */
12563	e = remove_last_array_ref (e: code->expr1);
12564	t = gfc_check_vardef_context (e, true, false, false,
12565	_("pointer assignment"));
12566	if (t)
12567	t = gfc_check_vardef_context (e, false, false, false,
12568	_("pointer assignment"));
12569	gfc_free_expr (e);
12570
12571	t = gfc_check_pointer_assign (lvalue: code->expr1, rvalue: code->expr2, suppres_type_test: !t) && t;
12572
12573	if (!t)
12574	break;
12575
12576	/* Assigning a class object always is a regular assign. */
12577	if (code->expr2->ts.type == BT_CLASS
12578	&& code->expr1->ts.type == BT_CLASS
12579	&& CLASS_DATA (code->expr2)
12580	&& !CLASS_DATA (code->expr2)->attr.dimension
12581	&& !(gfc_expr_attr (code->expr1).proc_pointer
12582	&& code->expr2->expr_type == EXPR_VARIABLE
12583	&& code->expr2->symtree->n.sym->attr.flavor
12584	== FL_PROCEDURE))
12585	code->op = EXEC_ASSIGN;
12586	break;
12587	}
12588
12589	case EXEC_ARITHMETIC_IF:
12590	{
12591	gfc_expr *e = code->expr1;
12592
12593	gfc_resolve_expr (e);
12594	if (e->expr_type == EXPR_NULL)
12595	gfc_error ("Invalid NULL at %L", &e->where);
12596
12597	if (t && (e->rank > 0
12598	|| !(e->ts.type == BT_REAL || e->ts.type == BT_INTEGER)))
12599	gfc_error ("Arithmetic IF statement at %L requires a scalar "
12600	"REAL or INTEGER expression", &e->where);
12601
12602	resolve_branch (label: code->label1, code);
12603	resolve_branch (label: code->label2, code);
12604	resolve_branch (label: code->label3, code);
12605	}
12606	break;
12607
12608	case EXEC_IF:
12609	if (t && code->expr1 != NULL
12610	&& (code->expr1->ts.type != BT_LOGICAL
12611	|| code->expr1->rank != 0))
12612	gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
12613	&code->expr1->where);
12614	break;
12615
12616	case EXEC_CALL:
12617	call:
12618	resolve_call (c: code);
12619	break;
12620
12621	case EXEC_COMPCALL:
12622	compcall:
12623	resolve_typebound_subroutine (code);
12624	break;
12625
12626	case EXEC_CALL_PPC:
12627	resolve_ppc_call (c: code);
12628	break;
12629
12630	case EXEC_SELECT:
12631	/* Select is complicated. Also, a SELECT construct could be
12632	a transformed computed GOTO. */
12633	resolve_select (code, select_type: false);
12634	break;
12635
12636	case EXEC_SELECT_TYPE:
12637	resolve_select_type (code, old_ns: ns);
12638	break;
12639
12640	case EXEC_SELECT_RANK:
12641	resolve_select_rank (code, old_ns: ns);
12642	break;
12643
12644	case EXEC_BLOCK:
12645	resolve_block_construct (code);
12646	break;
12647
12648	case EXEC_DO:
12649	if (code->ext.iterator != NULL)
12650	{
12651	gfc_iterator *iter = code->ext.iterator;
12652	if (gfc_resolve_iterator (iter, real_ok: true, own_scope: false))
12653	gfc_resolve_do_iterator (code, iter->var->symtree->n.sym,
12654	true);
12655	}
12656	break;
12657
12658	case EXEC_DO_WHILE:
12659	if (code->expr1 == NULL)
12660	gfc_internal_error ("gfc_resolve_code(): No expression on "
12661	"DO WHILE");
12662	if (t
12663	&& (code->expr1->rank != 0
12664	|| code->expr1->ts.type != BT_LOGICAL))
12665	gfc_error ("Exit condition of DO WHILE loop at %L must be "
12666	"a scalar LOGICAL expression", &code->expr1->where);
12667	break;
12668
12669	case EXEC_ALLOCATE:
12670	if (t)
12671	resolve_allocate_deallocate (code, fcn: "ALLOCATE");
12672
12673	break;
12674
12675	case EXEC_DEALLOCATE:
12676	if (t)
12677	resolve_allocate_deallocate (code, fcn: "DEALLOCATE");
12678
12679	break;
12680
12681	case EXEC_OPEN:
12682	if (!gfc_resolve_open (code->ext.open, &code->loc))
12683	break;
12684
12685	resolve_branch (label: code->ext.open->err, code);
12686	break;
12687
12688	case EXEC_CLOSE:
12689	if (!gfc_resolve_close (code->ext.close, &code->loc))
12690	break;
12691
12692	resolve_branch (label: code->ext.close->err, code);
12693	break;
12694
12695	case EXEC_BACKSPACE:
12696	case EXEC_ENDFILE:
12697	case EXEC_REWIND:
12698	case EXEC_FLUSH:
12699	if (!gfc_resolve_filepos (code->ext.filepos, &code->loc))
12700	break;
12701
12702	resolve_branch (label: code->ext.filepos->err, code);
12703	break;
12704
12705	case EXEC_INQUIRE:
12706	if (!gfc_resolve_inquire (code->ext.inquire))
12707	break;
12708
12709	resolve_branch (label: code->ext.inquire->err, code);
12710	break;
12711
12712	case EXEC_IOLENGTH:
12713	gcc_assert (code->ext.inquire != NULL);
12714	if (!gfc_resolve_inquire (code->ext.inquire))
12715	break;
12716
12717	resolve_branch (label: code->ext.inquire->err, code);
12718	break;
12719
12720	case EXEC_WAIT:
12721	if (!gfc_resolve_wait (code->ext.wait))
12722	break;
12723
12724	resolve_branch (label: code->ext.wait->err, code);
12725	resolve_branch (label: code->ext.wait->end, code);
12726	resolve_branch (label: code->ext.wait->eor, code);
12727	break;
12728
12729	case EXEC_READ:
12730	case EXEC_WRITE:
12731	if (!gfc_resolve_dt (code, code->ext.dt, &code->loc))
12732	break;
12733
12734	resolve_branch (label: code->ext.dt->err, code);
12735	resolve_branch (label: code->ext.dt->end, code);
12736	resolve_branch (label: code->ext.dt->eor, code);
12737	break;
12738
12739	case EXEC_TRANSFER:
12740	resolve_transfer (code);
12741	break;
12742
12743	case EXEC_DO_CONCURRENT:
12744	case EXEC_FORALL:
12745	resolve_forall_iterators (it: code->ext.forall_iterator);
12746
12747	if (code->expr1 != NULL
12748	&& (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
12749	gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
12750	"expression", &code->expr1->where);
12751	break;
12752
12753	case EXEC_OACC_PARALLEL_LOOP:
12754	case EXEC_OACC_PARALLEL:
12755	case EXEC_OACC_KERNELS_LOOP:
12756	case EXEC_OACC_KERNELS:
12757	case EXEC_OACC_SERIAL_LOOP:
12758	case EXEC_OACC_SERIAL:
12759	case EXEC_OACC_DATA:
12760	case EXEC_OACC_HOST_DATA:
12761	case EXEC_OACC_LOOP:
12762	case EXEC_OACC_UPDATE:
12763	case EXEC_OACC_WAIT:
12764	case EXEC_OACC_CACHE:
12765	case EXEC_OACC_ENTER_DATA:
12766	case EXEC_OACC_EXIT_DATA:
12767	case EXEC_OACC_ATOMIC:
12768	case EXEC_OACC_DECLARE:
12769	gfc_resolve_oacc_directive (code, ns);
12770	break;
12771
12772	case EXEC_OMP_ALLOCATE:
12773	case EXEC_OMP_ALLOCATORS:
12774	case EXEC_OMP_ASSUME:
12775	case EXEC_OMP_ATOMIC:
12776	case EXEC_OMP_BARRIER:
12777	case EXEC_OMP_CANCEL:
12778	case EXEC_OMP_CANCELLATION_POINT:
12779	case EXEC_OMP_CRITICAL:
12780	case EXEC_OMP_FLUSH:
12781	case EXEC_OMP_DEPOBJ:
12782	case EXEC_OMP_DISTRIBUTE:
12783	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12784	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12785	case EXEC_OMP_DISTRIBUTE_SIMD:
12786	case EXEC_OMP_DO:
12787	case EXEC_OMP_DO_SIMD:
12788	case EXEC_OMP_ERROR:
12789	case EXEC_OMP_LOOP:
12790	case EXEC_OMP_MASTER:
12791	case EXEC_OMP_MASTER_TASKLOOP:
12792	case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12793	case EXEC_OMP_MASKED:
12794	case EXEC_OMP_MASKED_TASKLOOP:
12795	case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12796	case EXEC_OMP_ORDERED:
12797	case EXEC_OMP_SCAN:
12798	case EXEC_OMP_SCOPE:
12799	case EXEC_OMP_SECTIONS:
12800	case EXEC_OMP_SIMD:
12801	case EXEC_OMP_SINGLE:
12802	case EXEC_OMP_TARGET:
12803	case EXEC_OMP_TARGET_DATA:
12804	case EXEC_OMP_TARGET_ENTER_DATA:
12805	case EXEC_OMP_TARGET_EXIT_DATA:
12806	case EXEC_OMP_TARGET_PARALLEL:
12807	case EXEC_OMP_TARGET_PARALLEL_DO:
12808	case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12809	case EXEC_OMP_TARGET_PARALLEL_LOOP:
12810	case EXEC_OMP_TARGET_SIMD:
12811	case EXEC_OMP_TARGET_TEAMS:
12812	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12813	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12814	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12815	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12816	case EXEC_OMP_TARGET_TEAMS_LOOP:
12817	case EXEC_OMP_TARGET_UPDATE:
12818	case EXEC_OMP_TASK:
12819	case EXEC_OMP_TASKGROUP:
12820	case EXEC_OMP_TASKLOOP:
12821	case EXEC_OMP_TASKLOOP_SIMD:
12822	case EXEC_OMP_TASKWAIT:
12823	case EXEC_OMP_TASKYIELD:
12824	case EXEC_OMP_TEAMS:
12825	case EXEC_OMP_TEAMS_DISTRIBUTE:
12826	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12827	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12828	case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12829	case EXEC_OMP_TEAMS_LOOP:
12830	case EXEC_OMP_WORKSHARE:
12831	gfc_resolve_omp_directive (code, ns);
12832	break;
12833
12834	case EXEC_OMP_PARALLEL:
12835	case EXEC_OMP_PARALLEL_DO:
12836	case EXEC_OMP_PARALLEL_DO_SIMD:
12837	case EXEC_OMP_PARALLEL_LOOP:
12838	case EXEC_OMP_PARALLEL_MASKED:
12839	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12840	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12841	case EXEC_OMP_PARALLEL_MASTER:
12842	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12843	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12844	case EXEC_OMP_PARALLEL_SECTIONS:
12845	case EXEC_OMP_PARALLEL_WORKSHARE:
12846	omp_workshare_save = omp_workshare_flag;
12847	omp_workshare_flag = 0;
12848	gfc_resolve_omp_directive (code, ns);
12849	omp_workshare_flag = omp_workshare_save;
12850	break;
12851
12852	default:
12853	gfc_internal_error ("gfc_resolve_code(): Bad statement code");
12854	}
12855	}
12856
12857	cs_base = frame.prev;
12858	}
12859
12860
12861	/* Resolve initial values and make sure they are compatible with
12862	the variable. */
12863
12864	static void
12865	resolve_values (gfc_symbol *sym)
12866	{
12867	bool t;
12868
12869	if (sym->value == NULL)
12870	return;
12871
12872	if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym->attr.referenced)
12873	gfc_warning (opt: OPT_Wdeprecated_declarations,
12874	"Using parameter %qs declared at %L is deprecated",
12875	sym->name, &sym->declared_at);
12876
12877	if (sym->value->expr_type == EXPR_STRUCTURE)
12878	t= resolve_structure_cons (expr: sym->value, init: 1);
12879	else
12880	t = gfc_resolve_expr (e: sym->value);
12881
12882	if (!t)
12883	return;
12884
12885	gfc_check_assign_symbol (sym, NULL, sym->value);
12886	}
12887
12888
12889	/* Verify any BIND(C) derived types in the namespace so we can report errors
12890	for them once, rather than for each variable declared of that type. */
12891
12892	static void
12893	resolve_bind_c_derived_types (gfc_symbol *derived_sym)
12894	{
12895	if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
12896	&& derived_sym->attr.is_bind_c == 1)
12897	verify_bind_c_derived_type (derived_sym);
12898
12899	return;
12900	}
12901
12902
12903	/* Check the interfaces of DTIO procedures associated with derived
12904	type 'sym'. These procedures can either have typebound bindings or
12905	can appear in DTIO generic interfaces. */
12906
12907	static void
12908	gfc_verify_DTIO_procedures (gfc_symbol *sym)
12909	{
12910	if (!sym || sym->attr.flavor != FL_DERIVED)
12911	return;
12912
12913	gfc_check_dtio_interfaces (sym);
12914
12915	return;
12916	}
12917
12918	/* Verify that any binding labels used in a given namespace do not collide
12919	with the names or binding labels of any global symbols. Multiple INTERFACE
12920	for the same procedure are permitted. */
12921
12922	static void
12923	gfc_verify_binding_labels (gfc_symbol *sym)
12924	{
12925	gfc_gsymbol *gsym;
12926	const char *module;
12927
12928	if (!sym || !sym->attr.is_bind_c || sym->attr.is_iso_c
12929	|| sym->attr.flavor == FL_DERIVED || !sym->binding_label)
12930	return;
12931
12932	gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label);
12933
12934	if (sym->module)
12935	module = sym->module;
12936	else if (sym->ns && sym->ns->proc_name
12937	&& sym->ns->proc_name->attr.flavor == FL_MODULE)
12938	module = sym->ns->proc_name->name;
12939	else if (sym->ns && sym->ns->parent
12940	&& sym->ns && sym->ns->parent->proc_name
12941	&& sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
12942	module = sym->ns->parent->proc_name->name;
12943	else
12944	module = NULL;
12945
12946	if (!gsym
12947	|| (!gsym->defined
12948	&& (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
12949	{
12950	if (!gsym)
12951	gsym = gfc_get_gsymbol (sym->binding_label, bind_c: true);
12952	gsym->where = sym->declared_at;
12953	gsym->sym_name = sym->name;
12954	gsym->binding_label = sym->binding_label;
12955	gsym->ns = sym->ns;
12956	gsym->mod_name = module;
12957	if (sym->attr.function)
12958	gsym->type = GSYM_FUNCTION;
12959	else if (sym->attr.subroutine)
12960	gsym->type = GSYM_SUBROUTINE;
12961	/* Mark as variable/procedure as defined, unless its an INTERFACE. */
12962	gsym->defined = sym->attr.if_source != IFSRC_IFBODY;
12963	return;
12964	}
12965
12966	if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN)
12967	{
12968	gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
12969	"identifier as entity at %L", sym->name,
12970	sym->binding_label, &sym->declared_at, &gsym->where);
12971	/* Clear the binding label to prevent checking multiple times. */
12972	sym->binding_label = NULL;
12973	return;
12974	}
12975
12976	if (sym->attr.flavor == FL_VARIABLE && module
12977	&& (strcmp (s1: module, s2: gsym->mod_name) != 0
12978	|| strcmp (s1: sym->name, s2: gsym->sym_name) != 0))
12979	{
12980	/* This can only happen if the variable is defined in a module - if it
12981	isn't the same module, reject it. */
12982	gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
12983	"uses the same global identifier as entity at %L from module %qs",
12984	sym->name, module, sym->binding_label,
12985	&sym->declared_at, &gsym->where, gsym->mod_name);
12986	sym->binding_label = NULL;
12987	return;
12988	}
12989
12990	if ((sym->attr.function || sym->attr.subroutine)
12991	&& ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION)
12992	|| (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
12993	&& (sym != gsym->ns->proc_name && sym->attr.entry == 0)
12994	&& (module != gsym->mod_name
12995	|| strcmp (s1: gsym->sym_name, s2: sym->name) != 0
12996	|| (module && strcmp (s1: module, s2: gsym->mod_name) != 0)))
12997	{
12998	/* Print an error if the procedure is defined multiple times; we have to
12999	exclude references to the same procedure via module association or
13000	multiple checks for the same procedure. */
13001	gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
13002	"global identifier as entity at %L", sym->name,
13003	sym->binding_label, &sym->declared_at, &gsym->where);
13004	sym->binding_label = NULL;
13005	}
13006	}
13007
13008
13009	/* Resolve an index expression. */
13010
13011	static bool
13012	resolve_index_expr (gfc_expr *e)
13013	{
13014	if (!gfc_resolve_expr (e))
13015	return false;
13016
13017	if (!gfc_simplify_expr (e, 0))
13018	return false;
13019
13020	if (!gfc_specification_expr (e))
13021	return false;
13022
13023	return true;
13024	}
13025
13026
13027	/* Resolve a charlen structure. */
13028
13029	static bool
13030	resolve_charlen (gfc_charlen *cl)
13031	{
13032	int k;
13033	bool saved_specification_expr;
13034
13035	if (cl->resolved)
13036	return true;
13037
13038	cl->resolved = 1;
13039	saved_specification_expr = specification_expr;
13040	specification_expr = true;
13041
13042	if (cl->length_from_typespec)
13043	{
13044	if (!gfc_resolve_expr (e: cl->length))
13045	{
13046	specification_expr = saved_specification_expr;
13047	return false;
13048	}
13049
13050	if (!gfc_simplify_expr (cl->length, 0))
13051	{
13052	specification_expr = saved_specification_expr;
13053	return false;
13054	}
13055
13056	/* cl->length has been resolved. It should have an integer type. */
13057	if (cl->length
13058	&& (cl->length->ts.type != BT_INTEGER || cl->length->rank != 0))
13059	{
13060	gfc_error ("Scalar INTEGER expression expected at %L",
13061	&cl->length->where);
13062	return false;
13063	}
13064	}
13065	else
13066	{
13067	if (!resolve_index_expr (e: cl->length))
13068	{
13069	specification_expr = saved_specification_expr;
13070	return false;
13071	}
13072	}
13073
13074	/* F2008, 4.4.3.2: If the character length parameter value evaluates to
13075	a negative value, the length of character entities declared is zero. */
13076	if (cl->length && cl->length->expr_type == EXPR_CONSTANT
13077	&& mpz_sgn (cl->length->value.integer) < 0)
13078	gfc_replace_expr (cl->length,
13079	gfc_get_int_expr (gfc_charlen_int_kind, NULL, 0));
13080
13081	/* Check that the character length is not too large. */
13082	k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
13083	if (cl->length && cl->length->expr_type == EXPR_CONSTANT
13084	&& cl->length->ts.type == BT_INTEGER
13085	&& mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
13086	{
13087	gfc_error ("String length at %L is too large", &cl->length->where);
13088	specification_expr = saved_specification_expr;
13089	return false;
13090	}
13091
13092	specification_expr = saved_specification_expr;
13093	return true;
13094	}
13095
13096
13097	/* Test for non-constant shape arrays. */
13098
13099	static bool
13100	is_non_constant_shape_array (gfc_symbol *sym)
13101	{
13102	gfc_expr *e;
13103	int i;
13104	bool not_constant;
13105
13106	not_constant = false;
13107	if (sym->as != NULL)
13108	{
13109	/* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
13110	has not been simplified; parameter array references. Do the
13111	simplification now. */
13112	for (i = 0; i < sym->as->rank + sym->as->corank; i++)
13113	{
13114	if (i == GFC_MAX_DIMENSIONS)
13115	break;
13116
13117	e = sym->as->lower[i];
13118	if (e && (!resolve_index_expr(e)
13119	|| !gfc_is_constant_expr (e)))
13120	not_constant = true;
13121	e = sym->as->upper[i];
13122	if (e && (!resolve_index_expr(e)
13123	|| !gfc_is_constant_expr (e)))
13124	not_constant = true;
13125	}
13126	}
13127	return not_constant;
13128	}
13129
13130	/* Given a symbol and an initialization expression, add code to initialize
13131	the symbol to the function entry. */
13132	static void
13133	build_init_assign (gfc_symbol *sym, gfc_expr *init)
13134	{
13135	gfc_expr *lval;
13136	gfc_code *init_st;
13137	gfc_namespace *ns = sym->ns;
13138
13139	/* Search for the function namespace if this is a contained
13140	function without an explicit result. */
13141	if (sym->attr.function && sym == sym->result
13142	&& sym->name != sym->ns->proc_name->name)
13143	{
13144	ns = ns->contained;
13145	for (;ns; ns = ns->sibling)
13146	if (strcmp (s1: ns->proc_name->name, s2: sym->name) == 0)
13147	break;
13148	}
13149
13150	if (ns == NULL)
13151	{
13152	gfc_free_expr (init);
13153	return;
13154	}
13155
13156	/* Build an l-value expression for the result. */
13157	lval = gfc_lval_expr_from_sym (sym);
13158
13159	/* Add the code at scope entry. */
13160	init_st = gfc_get_code (EXEC_INIT_ASSIGN);
13161	init_st->next = ns->code;
13162	ns->code = init_st;
13163
13164	/* Assign the default initializer to the l-value. */
13165	init_st->loc = sym->declared_at;
13166	init_st->expr1 = lval;
13167	init_st->expr2 = init;
13168	}
13169
13170
13171	/* Whether or not we can generate a default initializer for a symbol. */
13172
13173	static bool
13174	can_generate_init (gfc_symbol *sym)
13175	{
13176	symbol_attribute *a;
13177	if (!sym)
13178	return false;
13179	a = &sym->attr;
13180
13181	/* These symbols should never have a default initialization. */
13182	return !(
13183	a->allocatable
13184	|| a->external
13185	|| a->pointer
13186	|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
13187	&& (CLASS_DATA (sym)->attr.class_pointer
13188	|| CLASS_DATA (sym)->attr.proc_pointer))
13189	|| a->in_equivalence
13190	|| a->in_common
13191	|| a->data
13192	|| sym->module
13193	|| a->cray_pointee
13194	|| a->cray_pointer
13195	|| sym->assoc
13196	|| (!a->referenced && !a->result)
13197	|| (a->dummy && (a->intent != INTENT_OUT
13198	|| sym->ns->proc_name->attr.if_source == IFSRC_IFBODY))
13199	|| (a->function && sym != sym->result)
13200	);
13201	}
13202
13203
13204	/* Assign the default initializer to a derived type variable or result. */
13205
13206	static void
13207	apply_default_init (gfc_symbol *sym)
13208	{
13209	gfc_expr *init = NULL;
13210
13211	if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
13212	return;
13213
13214	if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
13215	init = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
13216
13217	if (init == NULL && sym->ts.type != BT_CLASS)
13218	return;
13219
13220	build_init_assign (sym, init);
13221	sym->attr.referenced = 1;
13222	}
13223
13224
13225	/* Build an initializer for a local. Returns null if the symbol should not have
13226	a default initialization. */
13227
13228	static gfc_expr *
13229	build_default_init_expr (gfc_symbol *sym)
13230	{
13231	/* These symbols should never have a default initialization. */
13232	if (sym->attr.allocatable
13233	|| sym->attr.external
13234	|| sym->attr.dummy
13235	|| sym->attr.pointer
13236	|| sym->attr.in_equivalence
13237	|| sym->attr.in_common
13238	|| sym->attr.data
13239	|| sym->module
13240	|| sym->attr.cray_pointee
13241	|| sym->attr.cray_pointer
13242	|| sym->assoc)
13243	return NULL;
13244
13245	/* Get the appropriate init expression. */
13246	return gfc_build_default_init_expr (&sym->ts, &sym->declared_at);
13247	}
13248
13249	/* Add an initialization expression to a local variable. */
13250	static void
13251	apply_default_init_local (gfc_symbol *sym)
13252	{
13253	gfc_expr *init = NULL;
13254
13255	/* The symbol should be a variable or a function return value. */
13256	if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
13257	|| (sym->attr.function && sym->result != sym))
13258	return;
13259
13260	/* Try to build the initializer expression. If we can't initialize
13261	this symbol, then init will be NULL. */
13262	init = build_default_init_expr (sym);
13263	if (init == NULL)
13264	return;
13265
13266	/* For saved variables, we don't want to add an initializer at function
13267	entry, so we just add a static initializer. Note that automatic variables
13268	are stack allocated even with -fno-automatic; we have also to exclude
13269	result variable, which are also nonstatic. */
13270	if (!sym->attr.automatic
13271	&& (sym->attr.save || sym->ns->save_all
13272	|| (flag_max_stack_var_size == 0 && !sym->attr.result
13273	&& (sym->ns->proc_name && !sym->ns->proc_name->attr.recursive)
13274	&& (!sym->attr.dimension || !is_non_constant_shape_array (sym)))))
13275	{
13276	/* Don't clobber an existing initializer! */
13277	gcc_assert (sym->value == NULL);
13278	sym->value = init;
13279	return;
13280	}
13281
13282	build_init_assign (sym, init);
13283	}
13284
13285
13286	/* Resolution of common features of flavors variable and procedure. */
13287
13288	static bool
13289	resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
13290	{
13291	gfc_array_spec *as;
13292
13293	if (sym->ts.type == BT_CLASS && sym->attr.class_ok
13294	&& sym->ts.u.derived && CLASS_DATA (sym))
13295	as = CLASS_DATA (sym)->as;
13296	else
13297	as = sym->as;
13298
13299	/* Constraints on deferred shape variable. */
13300	if (as == NULL || as->type != AS_DEFERRED)
13301	{
13302	bool pointer, allocatable, dimension;
13303
13304	if (sym->ts.type == BT_CLASS && sym->attr.class_ok
13305	&& sym->ts.u.derived && CLASS_DATA (sym))
13306	{
13307	pointer = CLASS_DATA (sym)->attr.class_pointer;
13308	allocatable = CLASS_DATA (sym)->attr.allocatable;
13309	dimension = CLASS_DATA (sym)->attr.dimension;
13310	}
13311	else
13312	{
13313	pointer = sym->attr.pointer && !sym->attr.select_type_temporary;
13314	allocatable = sym->attr.allocatable;
13315	dimension = sym->attr.dimension;
13316	}
13317
13318	if (allocatable)
13319	{
13320	if (dimension
13321	&& as
13322	&& as->type != AS_ASSUMED_RANK
13323	&& !sym->attr.select_rank_temporary)
13324	{
13325	gfc_error ("Allocatable array %qs at %L must have a deferred "
13326	"shape or assumed rank", sym->name, &sym->declared_at);
13327	return false;
13328	}
13329	else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object "
13330	"%qs at %L may not be ALLOCATABLE",
13331	sym->name, &sym->declared_at))
13332	return false;
13333	}
13334
13335	if (pointer && dimension && as->type != AS_ASSUMED_RANK)
13336	{
13337	gfc_error ("Array pointer %qs at %L must have a deferred shape or "
13338	"assumed rank", sym->name, &sym->declared_at);
13339	sym->error = 1;
13340	return false;
13341	}
13342	}
13343	else
13344	{
13345	if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
13346	&& sym->ts.type != BT_CLASS && !sym->assoc)
13347	{
13348	gfc_error ("Array %qs at %L cannot have a deferred shape",
13349	sym->name, &sym->declared_at);
13350	return false;
13351	}
13352	}
13353
13354	/* Constraints on polymorphic variables. */
13355	if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
13356	{
13357	/* F03:C502. */
13358	if (sym->attr.class_ok
13359	&& sym->ts.u.derived
13360	&& !sym->attr.select_type_temporary
13361	&& !UNLIMITED_POLY (sym)
13362	&& CLASS_DATA (sym)
13363	&& CLASS_DATA (sym)->ts.u.derived
13364	&& !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
13365	{
13366	gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
13367	CLASS_DATA (sym)->ts.u.derived->name, sym->name,
13368	&sym->declared_at);
13369	return false;
13370	}
13371
13372	/* F03:C509. */
13373	/* Assume that use associated symbols were checked in the module ns.
13374	Class-variables that are associate-names are also something special
13375	and excepted from the test. */
13376	if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
13377	{
13378	gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
13379	"or pointer", sym->name, &sym->declared_at);
13380	return false;
13381	}
13382	}
13383
13384	return true;
13385	}
13386
13387
13388	/* Additional checks for symbols with flavor variable and derived
13389	type. To be called from resolve_fl_variable. */
13390
13391	static bool
13392	resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
13393	{
13394	gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
13395
13396	/* Check to see if a derived type is blocked from being host
13397	associated by the presence of another class I symbol in the same
13398	namespace. 14.6.1.3 of the standard and the discussion on
13399	comp.lang.fortran. */
13400	if (sym->ts.u.derived
13401	&& sym->ns != sym->ts.u.derived->ns
13402	&& !sym->ts.u.derived->attr.use_assoc
13403	&& sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
13404	{
13405	gfc_symbol *s;
13406	gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
13407	if (s && s->attr.generic)
13408	s = gfc_find_dt_in_generic (s);
13409	if (s && !gfc_fl_struct (s->attr.flavor))
13410	{
13411	gfc_error ("The type %qs cannot be host associated at %L "
13412	"because it is blocked by an incompatible object "
13413	"of the same name declared at %L",
13414	sym->ts.u.derived->name, &sym->declared_at,
13415	&s->declared_at);
13416	return false;
13417	}
13418	}
13419
13420	/* 4th constraint in section 11.3: "If an object of a type for which
13421	component-initialization is specified (R429) appears in the
13422	specification-part of a module and does not have the ALLOCATABLE
13423	or POINTER attribute, the object shall have the SAVE attribute."
13424
13425	The check for initializers is performed with
13426	gfc_has_default_initializer because gfc_default_initializer generates
13427	a hidden default for allocatable components. */
13428	if (!(sym->value || no_init_flag) && sym->ns->proc_name
13429	&& sym->ns->proc_name->attr.flavor == FL_MODULE
13430	&& !(sym->ns->save_all && !sym->attr.automatic) && !sym->attr.save
13431	&& !sym->attr.pointer && !sym->attr.allocatable
13432	&& gfc_has_default_initializer (sym->ts.u.derived)
13433	&& !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable "
13434	"%qs at %L, needed due to the default "
13435	"initialization", sym->name, &sym->declared_at))
13436	return false;
13437
13438	/* Assign default initializer. */
13439	if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
13440	&& (!no_init_flag
13441	|| (sym->attr.intent == INTENT_OUT
13442	&& sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)))
13443	sym->value = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
13444
13445	return true;
13446	}
13447
13448
13449	/* F2008, C402 (R401): A colon shall not be used as a type-param-value
13450	except in the declaration of an entity or component that has the POINTER
13451	or ALLOCATABLE attribute. */
13452
13453	static bool
13454	deferred_requirements (gfc_symbol *sym)
13455	{
13456	if (sym->ts.deferred
13457	&& !(sym->attr.pointer
13458	|| sym->attr.allocatable
13459	|| sym->attr.associate_var
13460	|| sym->attr.omp_udr_artificial_var))
13461	{
13462	/* If a function has a result variable, only check the variable. */
13463	if (sym->result && sym->name != sym->result->name)
13464	return true;
13465
13466	gfc_error ("Entity %qs at %L has a deferred type parameter and "
13467	"requires either the POINTER or ALLOCATABLE attribute",
13468	sym->name, &sym->declared_at);
13469	return false;
13470	}
13471	return true;
13472	}
13473
13474
13475	/* Resolve symbols with flavor variable. */
13476
13477	static bool
13478	resolve_fl_variable (gfc_symbol *sym, int mp_flag)
13479	{
13480	const char *auto_save_msg = "Automatic object %qs at %L cannot have the "
13481	"SAVE attribute";
13482
13483	if (!resolve_fl_var_and_proc (sym, mp_flag))
13484	return false;
13485
13486	/* Set this flag to check that variables are parameters of all entries.
13487	This check is effected by the call to gfc_resolve_expr through
13488	is_non_constant_shape_array. */
13489	bool saved_specification_expr = specification_expr;
13490	specification_expr = true;
13491
13492	if (sym->ns->proc_name
13493	&& (sym->ns->proc_name->attr.flavor == FL_MODULE
13494	|| sym->ns->proc_name->attr.is_main_program)
13495	&& !sym->attr.use_assoc
13496	&& !sym->attr.allocatable
13497	&& !sym->attr.pointer
13498	&& is_non_constant_shape_array (sym))
13499	{
13500	/* F08:C541. The shape of an array defined in a main program or module
13501	* needs to be constant. */
13502	gfc_error ("The module or main program array %qs at %L must "
13503	"have constant shape", sym->name, &sym->declared_at);
13504	specification_expr = saved_specification_expr;
13505	return false;
13506	}
13507
13508	/* Constraints on deferred type parameter. */
13509	if (!deferred_requirements (sym))
13510	return false;
13511
13512	if (sym->ts.type == BT_CHARACTER && !sym->attr.associate_var)
13513	{
13514	/* Make sure that character string variables with assumed length are
13515	dummy arguments. */
13516	gfc_expr *e = NULL;
13517
13518	if (sym->ts.u.cl)
13519	e = sym->ts.u.cl->length;
13520	else
13521	return false;
13522
13523	if (e == NULL && !sym->attr.dummy && !sym->attr.result
13524	&& !sym->ts.deferred && !sym->attr.select_type_temporary
13525	&& !sym->attr.omp_udr_artificial_var)
13526	{
13527	gfc_error ("Entity with assumed character length at %L must be a "
13528	"dummy argument or a PARAMETER", &sym->declared_at);
13529	specification_expr = saved_specification_expr;
13530	return false;
13531	}
13532
13533	if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
13534	{
13535	gfc_error (auto_save_msg, sym->name, &sym->declared_at);
13536	specification_expr = saved_specification_expr;
13537	return false;
13538	}
13539
13540	if (!gfc_is_constant_expr (e)
13541	&& !(e->expr_type == EXPR_VARIABLE
13542	&& e->symtree->n.sym->attr.flavor == FL_PARAMETER))
13543	{
13544	if (!sym->attr.use_assoc && sym->ns->proc_name
13545	&& (sym->ns->proc_name->attr.flavor == FL_MODULE
13546	|| sym->ns->proc_name->attr.is_main_program))
13547	{
13548	gfc_error ("%qs at %L must have constant character length "
13549	"in this context", sym->name, &sym->declared_at);
13550	specification_expr = saved_specification_expr;
13551	return false;
13552	}
13553	if (sym->attr.in_common)
13554	{
13555	gfc_error ("COMMON variable %qs at %L must have constant "
13556	"character length", sym->name, &sym->declared_at);
13557	specification_expr = saved_specification_expr;
13558	return false;
13559	}
13560	}
13561	}
13562
13563	if (sym->value == NULL && sym->attr.referenced
13564	&& !(sym->as && sym->as->type == AS_ASSUMED_RANK))
13565	apply_default_init_local (sym); /* Try to apply a default initialization. */
13566
13567	/* Determine if the symbol may not have an initializer. */
13568	int no_init_flag = 0, automatic_flag = 0;
13569	if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
13570	|| sym->attr.intrinsic || sym->attr.result)
13571	no_init_flag = 1;
13572	else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
13573	&& is_non_constant_shape_array (sym))
13574	{
13575	no_init_flag = automatic_flag = 1;
13576
13577	/* Also, they must not have the SAVE attribute.
13578	SAVE_IMPLICIT is checked below. */
13579	if (sym->as && sym->attr.codimension)
13580	{
13581	int corank = sym->as->corank;
13582	sym->as->corank = 0;
13583	no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
13584	sym->as->corank = corank;
13585	}
13586	if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
13587	{
13588	gfc_error (auto_save_msg, sym->name, &sym->declared_at);
13589	specification_expr = saved_specification_expr;
13590	return false;
13591	}
13592	}
13593
13594	/* Ensure that any initializer is simplified. */
13595	if (sym->value)
13596	gfc_simplify_expr (sym->value, 1);
13597
13598	/* Reject illegal initializers. */
13599	if (!sym->mark && sym->value)
13600	{
13601	if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
13602	&& CLASS_DATA (sym)->attr.allocatable))
13603	gfc_error ("Allocatable %qs at %L cannot have an initializer",
13604	sym->name, &sym->declared_at);
13605	else if (sym->attr.external)
13606	gfc_error ("External %qs at %L cannot have an initializer",
13607	sym->name, &sym->declared_at);
13608	else if (sym->attr.dummy)
13609	gfc_error ("Dummy %qs at %L cannot have an initializer",
13610	sym->name, &sym->declared_at);
13611	else if (sym->attr.intrinsic)
13612	gfc_error ("Intrinsic %qs at %L cannot have an initializer",
13613	sym->name, &sym->declared_at);
13614	else if (sym->attr.result)
13615	gfc_error ("Function result %qs at %L cannot have an initializer",
13616	sym->name, &sym->declared_at);
13617	else if (automatic_flag)
13618	gfc_error ("Automatic array %qs at %L cannot have an initializer",
13619	sym->name, &sym->declared_at);
13620	else
13621	goto no_init_error;
13622	specification_expr = saved_specification_expr;
13623	return false;
13624	}
13625
13626	no_init_error:
13627	if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
13628	{
13629	bool res = resolve_fl_variable_derived (sym, no_init_flag);
13630	specification_expr = saved_specification_expr;
13631	return res;
13632	}
13633
13634	specification_expr = saved_specification_expr;
13635	return true;
13636	}
13637
13638
13639	/* Compare the dummy characteristics of a module procedure interface
13640	declaration with the corresponding declaration in a submodule. */
13641	static gfc_formal_arglist *new_formal;
13642	static char errmsg[200];
13643
13644	static void
13645	compare_fsyms (gfc_symbol *sym)
13646	{
13647	gfc_symbol *fsym;
13648
13649	if (sym == NULL || new_formal == NULL)
13650	return;
13651
13652	fsym = new_formal->sym;
13653
13654	if (sym == fsym)
13655	return;
13656
13657	if (strcmp (s1: sym->name, s2: fsym->name) == 0)
13658	{
13659	if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200))
13660	gfc_error ("%s at %L", errmsg, &fsym->declared_at);
13661	}
13662	}
13663
13664
13665	/* Resolve a procedure. */
13666
13667	static bool
13668	resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
13669	{
13670	gfc_formal_arglist *arg;
13671	bool allocatable_or_pointer = false;
13672
13673	if (sym->attr.function
13674	&& !resolve_fl_var_and_proc (sym, mp_flag))
13675	return false;
13676
13677	/* Constraints on deferred type parameter. */
13678	if (!deferred_requirements (sym))
13679	return false;
13680
13681	if (sym->ts.type == BT_CHARACTER)
13682	{
13683	gfc_charlen *cl = sym->ts.u.cl;
13684
13685	if (cl && cl->length && gfc_is_constant_expr (cl->length)
13686	&& !resolve_charlen (cl))
13687	return false;
13688
13689	if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
13690	&& sym->attr.proc == PROC_ST_FUNCTION)
13691	{
13692	gfc_error ("Character-valued statement function %qs at %L must "
13693	"have constant length", sym->name, &sym->declared_at);
13694	return false;
13695	}
13696	}
13697
13698	/* Ensure that derived type for are not of a private type. Internal
13699	module procedures are excluded by 2.2.3.3 - i.e., they are not
13700	externally accessible and can access all the objects accessible in
13701	the host. */
13702	if (!(sym->ns->parent && sym->ns->parent->proc_name
13703	&& sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
13704	&& gfc_check_symbol_access (sym))
13705	{
13706	gfc_interface *iface;
13707
13708	for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next)
13709	{
13710	if (arg->sym
13711	&& arg->sym->ts.type == BT_DERIVED
13712	&& arg->sym->ts.u.derived
13713	&& !arg->sym->ts.u.derived->attr.use_assoc
13714	&& !gfc_check_symbol_access (arg->sym->ts.u.derived)
13715	&& !gfc_notify_std (GFC_STD_F2003, "%qs is of a PRIVATE type "
13716	"and cannot be a dummy argument"
13717	" of %qs, which is PUBLIC at %L",
13718	arg->sym->name, sym->name,
13719	&sym->declared_at))
13720	{
13721	/* Stop this message from recurring. */
13722	arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
13723	return false;
13724	}
13725	}
13726
13727	/* PUBLIC interfaces may expose PRIVATE procedures that take types
13728	PRIVATE to the containing module. */
13729	for (iface = sym->generic; iface; iface = iface->next)
13730	{
13731	for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
13732	{
13733	if (arg->sym
13734	&& arg->sym->ts.type == BT_DERIVED
13735	&& !arg->sym->ts.u.derived->attr.use_assoc
13736	&& !gfc_check_symbol_access (arg->sym->ts.u.derived)
13737	&& !gfc_notify_std (GFC_STD_F2003, "Procedure %qs in "
13738	"PUBLIC interface %qs at %L "
13739	"takes dummy arguments of %qs which "
13740	"is PRIVATE", iface->sym->name,
13741	sym->name, &iface->sym->declared_at,
13742	gfc_typename(&arg->sym->ts)))
13743	{
13744	/* Stop this message from recurring. */
13745	arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
13746	return false;
13747	}
13748	}
13749	}
13750	}
13751
13752	if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
13753	&& !sym->attr.proc_pointer)
13754	{
13755	gfc_error ("Function %qs at %L cannot have an initializer",
13756	sym->name, &sym->declared_at);
13757
13758	/* Make sure no second error is issued for this. */
13759	sym->value->error = 1;
13760	return false;
13761	}
13762
13763	/* An external symbol may not have an initializer because it is taken to be
13764	a procedure. Exception: Procedure Pointers. */
13765	if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
13766	{
13767	gfc_error ("External object %qs at %L may not have an initializer",
13768	sym->name, &sym->declared_at);
13769	return false;
13770	}
13771
13772	/* An elemental function is required to return a scalar 12.7.1 */
13773	if (sym->attr.elemental && sym->attr.function
13774	&& (sym->as || (sym->ts.type == BT_CLASS && sym->attr.class_ok
13775	&& CLASS_DATA (sym)->as)))
13776	{
13777	gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
13778	"result", sym->name, &sym->declared_at);
13779	/* Reset so that the error only occurs once. */
13780	sym->attr.elemental = 0;
13781	return false;
13782	}
13783
13784	if (sym->attr.proc == PROC_ST_FUNCTION
13785	&& (sym->attr.allocatable || sym->attr.pointer))
13786	{
13787	gfc_error ("Statement function %qs at %L may not have pointer or "
13788	"allocatable attribute", sym->name, &sym->declared_at);
13789	return false;
13790	}
13791
13792	/* 5.1.1.5 of the Standard: A function name declared with an asterisk
13793	char-len-param shall not be array-valued, pointer-valued, recursive
13794	or pure. ....snip... A character value of * may only be used in the
13795	following ways: (i) Dummy arg of procedure - dummy associates with
13796	actual length; (ii) To declare a named constant; or (iii) External
13797	function - but length must be declared in calling scoping unit. */
13798	if (sym->attr.function
13799	&& sym->ts.type == BT_CHARACTER && !sym->ts.deferred
13800	&& sym->ts.u.cl && sym->ts.u.cl->length == NULL)
13801	{
13802	if ((sym->as && sym->as->rank) || (sym->attr.pointer)
13803	|| (sym->attr.recursive) || (sym->attr.pure))
13804	{
13805	if (sym->as && sym->as->rank)
13806	gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13807	"array-valued", sym->name, &sym->declared_at);
13808
13809	if (sym->attr.pointer)
13810	gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13811	"pointer-valued", sym->name, &sym->declared_at);
13812
13813	if (sym->attr.pure)
13814	gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13815	"pure", sym->name, &sym->declared_at);
13816
13817	if (sym->attr.recursive)
13818	gfc_error ("CHARACTER(*) function %qs at %L cannot be "
13819	"recursive", sym->name, &sym->declared_at);
13820
13821	return false;
13822	}
13823
13824	/* Appendix B.2 of the standard. Contained functions give an
13825	error anyway. Deferred character length is an F2003 feature.
13826	Don't warn on intrinsic conversion functions, which start
13827	with two underscores. */
13828	if (!sym->attr.contained && !sym->ts.deferred
13829	&& (sym->name[0] != '_' || sym->name[1] != '_'))
13830	gfc_notify_std (GFC_STD_F95_OBS,
13831	"CHARACTER(*) function %qs at %L",
13832	sym->name, &sym->declared_at);
13833	}
13834
13835	/* F2008, C1218. */
13836	if (sym->attr.elemental)
13837	{
13838	if (sym->attr.proc_pointer)
13839	{
13840	const char* name = (sym->attr.result ? sym->ns->proc_name->name
13841	: sym->name);
13842	gfc_error ("Procedure pointer %qs at %L shall not be elemental",
13843	name, &sym->declared_at);
13844	return false;
13845	}
13846	if (sym->attr.dummy)
13847	{
13848	gfc_error ("Dummy procedure %qs at %L shall not be elemental",
13849	sym->name, &sym->declared_at);
13850	return false;
13851	}
13852	}
13853
13854	/* F2018, C15100: "The result of an elemental function shall be scalar,
13855	and shall not have the POINTER or ALLOCATABLE attribute." The scalar
13856	pointer is tested and caught elsewhere. */
13857	if (sym->result)
13858	allocatable_or_pointer = sym->result->ts.type == BT_CLASS
13859	&& CLASS_DATA (sym->result) ?
13860	(CLASS_DATA (sym->result)->attr.allocatable
13861	|| CLASS_DATA (sym->result)->attr.pointer) :
13862	(sym->result->attr.allocatable
13863	|| sym->result->attr.pointer);
13864
13865	if (sym->attr.elemental && sym->result
13866	&& allocatable_or_pointer)
13867	{
13868	gfc_error ("Function result variable %qs at %L of elemental "
13869	"function %qs shall not have an ALLOCATABLE or POINTER "
13870	"attribute", sym->result->name,
13871	&sym->result->declared_at, sym->name);
13872	return false;
13873	}
13874
13875	if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
13876	{
13877	gfc_formal_arglist *curr_arg;
13878	int has_non_interop_arg = 0;
13879
13880	if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
13881	sym->common_block))
13882	{
13883	/* Clear these to prevent looking at them again if there was an
13884	error. */
13885	sym->attr.is_bind_c = 0;
13886	sym->attr.is_c_interop = 0;
13887	sym->ts.is_c_interop = 0;
13888	}
13889	else
13890	{
13891	/* So far, no errors have been found. */
13892	sym->attr.is_c_interop = 1;
13893	sym->ts.is_c_interop = 1;
13894	}
13895
13896	curr_arg = gfc_sym_get_dummy_args (sym);
13897	while (curr_arg != NULL)
13898	{
13899	/* Skip implicitly typed dummy args here. */
13900	if (curr_arg->sym && curr_arg->sym->attr.implicit_type == 0)
13901	if (!gfc_verify_c_interop_param (curr_arg->sym))
13902	/* If something is found to fail, record the fact so we
13903	can mark the symbol for the procedure as not being
13904	BIND(C) to try and prevent multiple errors being
13905	reported. */
13906	has_non_interop_arg = 1;
13907
13908	curr_arg = curr_arg->next;
13909	}
13910
13911	/* See if any of the arguments were not interoperable and if so, clear
13912	the procedure symbol to prevent duplicate error messages. */
13913	if (has_non_interop_arg != 0)
13914	{
13915	sym->attr.is_c_interop = 0;
13916	sym->ts.is_c_interop = 0;
13917	sym->attr.is_bind_c = 0;
13918	}
13919	}
13920
13921	if (!sym->attr.proc_pointer)
13922	{
13923	if (sym->attr.save == SAVE_EXPLICIT)
13924	{
13925	gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
13926	"in %qs at %L", sym->name, &sym->declared_at);
13927	return false;
13928	}
13929	if (sym->attr.intent)
13930	{
13931	gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
13932	"in %qs at %L", sym->name, &sym->declared_at);
13933	return false;
13934	}
13935	if (sym->attr.subroutine && sym->attr.result)
13936	{
13937	gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
13938	"in %qs at %L", sym->ns->proc_name->name, &sym->declared_at);
13939	return false;
13940	}
13941	if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure
13942	&& ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
13943	|| sym->attr.contained))
13944	{
13945	gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
13946	"in %qs at %L", sym->name, &sym->declared_at);
13947	return false;
13948	}
13949	if (strcmp (s1: "ppr@", s2: sym->name) == 0)
13950	{
13951	gfc_error ("Procedure pointer result %qs at %L "
13952	"is missing the pointer attribute",
13953	sym->ns->proc_name->name, &sym->declared_at);
13954	return false;
13955	}
13956	}
13957
13958	/* Assume that a procedure whose body is not known has references
13959	to external arrays. */
13960	if (sym->attr.if_source != IFSRC_DECL)
13961	sym->attr.array_outer_dependency = 1;
13962
13963	/* Compare the characteristics of a module procedure with the
13964	interface declaration. Ideally this would be done with
13965	gfc_compare_interfaces but, at present, the formal interface
13966	cannot be copied to the ts.interface. */
13967	if (sym->attr.module_procedure
13968	&& sym->attr.if_source == IFSRC_DECL)
13969	{
13970	gfc_symbol *iface;
13971	char name[2*GFC_MAX_SYMBOL_LEN + 1];
13972	char *module_name;
13973	char *submodule_name;
13974	strcpy (dest: name, src: sym->ns->proc_name->name);
13975	module_name = strtok (s: name, delim: ".");
13976	submodule_name = strtok (NULL, delim: ".");
13977
13978	iface = sym->tlink;
13979	sym->tlink = NULL;
13980
13981	/* Make sure that the result uses the correct charlen for deferred
13982	length results. */
13983	if (iface && sym->result
13984	&& iface->ts.type == BT_CHARACTER
13985	&& iface->ts.deferred)
13986	sym->result->ts.u.cl = iface->ts.u.cl;
13987
13988	if (iface == NULL)
13989	goto check_formal;
13990
13991	/* Check the procedure characteristics. */
13992	if (sym->attr.elemental != iface->attr.elemental)
13993	{
13994	gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
13995	"PROCEDURE at %L and its interface in %s",
13996	&sym->declared_at, module_name);
13997	return false;
13998	}
13999
14000	if (sym->attr.pure != iface->attr.pure)
14001	{
14002	gfc_error ("Mismatch in PURE attribute between MODULE "
14003	"PROCEDURE at %L and its interface in %s",
14004	&sym->declared_at, module_name);
14005	return false;
14006	}
14007
14008	if (sym->attr.recursive != iface->attr.recursive)
14009	{
14010	gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
14011	"PROCEDURE at %L and its interface in %s",
14012	&sym->declared_at, module_name);
14013	return false;
14014	}
14015
14016	/* Check the result characteristics. */
14017	if (!gfc_check_result_characteristics (sym, iface, errmsg, 200))
14018	{
14019	gfc_error ("%s between the MODULE PROCEDURE declaration "
14020	"in MODULE %qs and the declaration at %L in "
14021	"(SUB)MODULE %qs",
14022	errmsg, module_name, &sym->declared_at,
14023	submodule_name ? submodule_name : module_name);
14024	return false;
14025	}
14026
14027	check_formal:
14028	/* Check the characteristics of the formal arguments. */
14029	if (sym->formal && sym->formal_ns)
14030	{
14031	for (arg = sym->formal; arg && arg->sym; arg = arg->next)
14032	{
14033	new_formal = arg;
14034	gfc_traverse_ns (sym->formal_ns, compare_fsyms);
14035	}
14036	}
14037	}
14038
14039	/* F2018:15.4.2.2 requires an explicit interface for procedures with the
14040	BIND(C) attribute. */
14041	if (sym->attr.is_bind_c && sym->attr.if_source == IFSRC_UNKNOWN)
14042	{
14043	gfc_error ("Interface of %qs at %L must be explicit",
14044	sym->name, &sym->declared_at);
14045	return false;
14046	}
14047
14048	return true;
14049	}
14050
14051
14052	/* Resolve a list of finalizer procedures. That is, after they have hopefully
14053	been defined and we now know their defined arguments, check that they fulfill
14054	the requirements of the standard for procedures used as finalizers. */
14055
14056	static bool
14057	gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable)
14058	{
14059	gfc_finalizer* list;
14060	gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
14061	bool result = true;
14062	bool seen_scalar = false;
14063	gfc_symbol *vtab;
14064	gfc_component *c;
14065	gfc_symbol *parent = gfc_get_derived_super_type (derived);
14066
14067	if (parent)
14068	gfc_resolve_finalizers (derived: parent, finalizable);
14069
14070	/* Ensure that derived-type components have a their finalizers resolved. */
14071	bool has_final = derived->f2k_derived && derived->f2k_derived->finalizers;
14072	for (c = derived->components; c; c = c->next)
14073	if (c->ts.type == BT_DERIVED
14074	&& !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable)
14075	{
14076	bool has_final2 = false;
14077	if (!gfc_resolve_finalizers (derived: c->ts.u.derived, finalizable: &has_final2))
14078	return false; /* Error. */
14079	has_final = has_final || has_final2;
14080	}
14081	/* Return early if not finalizable. */
14082	if (!has_final)
14083	{
14084	if (finalizable)
14085	*finalizable = false;
14086	return true;
14087	}
14088
14089	/* Walk over the list of finalizer-procedures, check them, and if any one
14090	does not fit in with the standard's definition, print an error and remove
14091	it from the list. */
14092	prev_link = &derived->f2k_derived->finalizers;
14093	for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
14094	{
14095	gfc_formal_arglist *dummy_args;
14096	gfc_symbol* arg;
14097	gfc_finalizer* i;
14098	int my_rank;
14099
14100	/* Skip this finalizer if we already resolved it. */
14101	if (list->proc_tree)
14102	{
14103	if (list->proc_tree->n.sym->formal->sym->as == NULL
14104	|| list->proc_tree->n.sym->formal->sym->as->rank == 0)
14105	seen_scalar = true;
14106	prev_link = &(list->next);
14107	continue;
14108	}
14109
14110	/* Check this exists and is a SUBROUTINE. */
14111	if (!list->proc_sym->attr.subroutine)
14112	{
14113	gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
14114	list->proc_sym->name, &list->where);
14115	goto error;
14116	}
14117
14118	/* We should have exactly one argument. */
14119	dummy_args = gfc_sym_get_dummy_args (list->proc_sym);
14120	if (!dummy_args || dummy_args->next)
14121	{
14122	gfc_error ("FINAL procedure at %L must have exactly one argument",
14123	&list->where);
14124	goto error;
14125	}
14126	arg = dummy_args->sym;
14127
14128	if (!arg)
14129	{
14130	gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
14131	&list->proc_sym->declared_at, derived->name);
14132	goto error;
14133	}
14134
14135	if (arg->as && arg->as->type == AS_ASSUMED_RANK
14136	&& ((list != derived->f2k_derived->finalizers) || list->next))
14137	{
14138	gfc_error ("FINAL procedure at %L with assumed rank argument must "
14139	"be the only finalizer with the same kind/type "
14140	"(F2018: C790)", &list->where);
14141	goto error;
14142	}
14143
14144	/* This argument must be of our type. */
14145	if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
14146	{
14147	gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
14148	&arg->declared_at, derived->name);
14149	goto error;
14150	}
14151
14152	/* It must neither be a pointer nor allocatable nor optional. */
14153	if (arg->attr.pointer)
14154	{
14155	gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
14156	&arg->declared_at);
14157	goto error;
14158	}
14159	if (arg->attr.allocatable)
14160	{
14161	gfc_error ("Argument of FINAL procedure at %L must not be"
14162	" ALLOCATABLE", &arg->declared_at);
14163	goto error;
14164	}
14165	if (arg->attr.optional)
14166	{
14167	gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
14168	&arg->declared_at);
14169	goto error;
14170	}
14171
14172	/* It must not be INTENT(OUT). */
14173	if (arg->attr.intent == INTENT_OUT)
14174	{
14175	gfc_error ("Argument of FINAL procedure at %L must not be"
14176	" INTENT(OUT)", &arg->declared_at);
14177	goto error;
14178	}
14179
14180	/* Warn if the procedure is non-scalar and not assumed shape. */
14181	if (warn_surprising && arg->as && arg->as->rank != 0
14182	&& arg->as->type != AS_ASSUMED_SHAPE)
14183	gfc_warning (opt: OPT_Wsurprising,
14184	"Non-scalar FINAL procedure at %L should have assumed"
14185	" shape argument", &arg->declared_at);
14186
14187	/* Check that it does not match in kind and rank with a FINAL procedure
14188	defined earlier. To really loop over the *earlier* declarations,
14189	we need to walk the tail of the list as new ones were pushed at the
14190	front. */
14191	/* TODO: Handle kind parameters once they are implemented. */
14192	my_rank = (arg->as ? arg->as->rank : 0);
14193	for (i = list->next; i; i = i->next)
14194	{
14195	gfc_formal_arglist *dummy_args;
14196
14197	/* Argument list might be empty; that is an error signalled earlier,
14198	but we nevertheless continued resolving. */
14199	dummy_args = gfc_sym_get_dummy_args (i->proc_sym);
14200	if (dummy_args)
14201	{
14202	gfc_symbol* i_arg = dummy_args->sym;
14203	const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
14204	if (i_rank == my_rank)
14205	{
14206	gfc_error ("FINAL procedure %qs declared at %L has the same"
14207	" rank (%d) as %qs",
14208	list->proc_sym->name, &list->where, my_rank,
14209	i->proc_sym->name);
14210	goto error;
14211	}
14212	}
14213	}
14214
14215	/* Is this the/a scalar finalizer procedure? */
14216	if (my_rank == 0)
14217	seen_scalar = true;
14218
14219	/* Find the symtree for this procedure. */
14220	gcc_assert (!list->proc_tree);
14221	list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
14222
14223	prev_link = &list->next;
14224	continue;
14225
14226	/* Remove wrong nodes immediately from the list so we don't risk any
14227	troubles in the future when they might fail later expectations. */
14228	error:
14229	i = list;
14230	*prev_link = list->next;
14231	gfc_free_finalizer (el: i);
14232	result = false;
14233	}
14234
14235	if (result == false)
14236	return false;
14237
14238	/* Warn if we haven't seen a scalar finalizer procedure (but we know there
14239	were nodes in the list, must have been for arrays. It is surely a good
14240	idea to have a scalar version there if there's something to finalize. */
14241	if (warn_surprising && derived->f2k_derived->finalizers && !seen_scalar)
14242	gfc_warning (opt: OPT_Wsurprising,
14243	"Only array FINAL procedures declared for derived type %qs"
14244	" defined at %L, suggest also scalar one unless an assumed"
14245	" rank finalizer has been declared",
14246	derived->name, &derived->declared_at);
14247
14248	vtab = gfc_find_derived_vtab (derived);
14249	c = vtab->ts.u.derived->components->next->next->next->next->next;
14250	gfc_set_sym_referenced (c->initializer->symtree->n.sym);
14251
14252	if (finalizable)
14253	*finalizable = true;
14254
14255	return true;
14256	}
14257
14258
14259	/* Check if two GENERIC targets are ambiguous and emit an error is they are. */
14260
14261	static bool
14262	check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
14263	const char* generic_name, locus where)
14264	{
14265	gfc_symbol *sym1, *sym2;
14266	const char *pass1, *pass2;
14267	gfc_formal_arglist *dummy_args;
14268
14269	gcc_assert (t1->specific && t2->specific);
14270	gcc_assert (!t1->specific->is_generic);
14271	gcc_assert (!t2->specific->is_generic);
14272	gcc_assert (t1->is_operator == t2->is_operator);
14273
14274	sym1 = t1->specific->u.specific->n.sym;
14275	sym2 = t2->specific->u.specific->n.sym;
14276
14277	if (sym1 == sym2)
14278	return true;
14279
14280	/* Both must be SUBROUTINEs or both must be FUNCTIONs. */
14281	if (sym1->attr.subroutine != sym2->attr.subroutine
14282	|| sym1->attr.function != sym2->attr.function)
14283	{
14284	gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
14285	" GENERIC %qs at %L",
14286	sym1->name, sym2->name, generic_name, &where);
14287	return false;
14288	}
14289
14290	/* Determine PASS arguments. */
14291	if (t1->specific->nopass)
14292	pass1 = NULL;
14293	else if (t1->specific->pass_arg)
14294	pass1 = t1->specific->pass_arg;
14295	else
14296	{
14297	dummy_args = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym);
14298	if (dummy_args)
14299	pass1 = dummy_args->sym->name;
14300	else
14301	pass1 = NULL;
14302	}
14303	if (t2->specific->nopass)
14304	pass2 = NULL;
14305	else if (t2->specific->pass_arg)
14306	pass2 = t2->specific->pass_arg;
14307	else
14308	{
14309	dummy_args = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym);
14310	if (dummy_args)
14311	pass2 = dummy_args->sym->name;
14312	else
14313	pass2 = NULL;
14314	}
14315
14316	/* Compare the interfaces. */
14317	if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
14318	NULL, 0, pass1, pass2))
14319	{
14320	gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
14321	sym1->name, sym2->name, generic_name, &where);
14322	return false;
14323	}
14324
14325	return true;
14326	}
14327
14328
14329	/* Worker function for resolving a generic procedure binding; this is used to
14330	resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
14331
14332	The difference between those cases is finding possible inherited bindings
14333	that are overridden, as one has to look for them in tb_sym_root,
14334	tb_uop_root or tb_op, respectively. Thus the caller must already find
14335	the super-type and set p->overridden correctly. */
14336
14337	static bool
14338	resolve_tb_generic_targets (gfc_symbol* super_type,
14339	gfc_typebound_proc* p, const char* name)
14340	{
14341	gfc_tbp_generic* target;
14342	gfc_symtree* first_target;
14343	gfc_symtree* inherited;
14344
14345	gcc_assert (p && p->is_generic);
14346
14347	/* Try to find the specific bindings for the symtrees in our target-list. */
14348	gcc_assert (p->u.generic);
14349	for (target = p->u.generic; target; target = target->next)
14350	if (!target->specific)
14351	{
14352	gfc_typebound_proc* overridden_tbp;
14353	gfc_tbp_generic* g;
14354	const char* target_name;
14355
14356	target_name = target->specific_st->name;
14357
14358	/* Defined for this type directly. */
14359	if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
14360	{
14361	target->specific = target->specific_st->n.tb;
14362	goto specific_found;
14363	}
14364
14365	/* Look for an inherited specific binding. */
14366	if (super_type)
14367	{
14368	inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
14369	true, NULL);
14370
14371	if (inherited)
14372	{
14373	gcc_assert (inherited->n.tb);
14374	target->specific = inherited->n.tb;
14375	goto specific_found;
14376	}
14377	}
14378
14379	gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
14380	" at %L", target_name, name, &p->where);
14381	return false;
14382
14383	/* Once we've found the specific binding, check it is not ambiguous with
14384	other specifics already found or inherited for the same GENERIC. */
14385	specific_found:
14386	gcc_assert (target->specific);
14387
14388	/* This must really be a specific binding! */
14389	if (target->specific->is_generic)
14390	{
14391	gfc_error ("GENERIC %qs at %L must target a specific binding,"
14392	" %qs is GENERIC, too", name, &p->where, target_name);
14393	return false;
14394	}
14395
14396	/* Check those already resolved on this type directly. */
14397	for (g = p->u.generic; g; g = g->next)
14398	if (g != target && g->specific
14399	&& !check_generic_tbp_ambiguity (t1: target, t2: g, generic_name: name, where: p->where))
14400	return false;
14401
14402	/* Check for ambiguity with inherited specific targets. */
14403	for (overridden_tbp = p->overridden; overridden_tbp;
14404	overridden_tbp = overridden_tbp->overridden)
14405	if (overridden_tbp->is_generic)
14406	{
14407	for (g = overridden_tbp->u.generic; g; g = g->next)
14408	{
14409	gcc_assert (g->specific);
14410	if (!check_generic_tbp_ambiguity (t1: target, t2: g, generic_name: name, where: p->where))
14411	return false;
14412	}
14413	}
14414	}
14415
14416	/* If we attempt to "overwrite" a specific binding, this is an error. */
14417	if (p->overridden && !p->overridden->is_generic)
14418	{
14419	gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
14420	" the same name", name, &p->where);
14421	return false;
14422	}
14423
14424	/* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
14425	all must have the same attributes here. */
14426	first_target = p->u.generic->specific->u.specific;
14427	gcc_assert (first_target);
14428	p->subroutine = first_target->n.sym->attr.subroutine;
14429	p->function = first_target->n.sym->attr.function;
14430
14431	return true;
14432	}
14433
14434
14435	/* Resolve a GENERIC procedure binding for a derived type. */
14436
14437	static bool
14438	resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
14439	{
14440	gfc_symbol* super_type;
14441
14442	/* Find the overridden binding if any. */
14443	st->n.tb->overridden = NULL;
14444	super_type = gfc_get_derived_super_type (derived);
14445	if (super_type)
14446	{
14447	gfc_symtree* overridden;
14448	overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
14449	true, NULL);
14450
14451	if (overridden && overridden->n.tb)
14452	st->n.tb->overridden = overridden->n.tb;
14453	}
14454
14455	/* Resolve using worker function. */
14456	return resolve_tb_generic_targets (super_type, p: st->n.tb, name: st->name);
14457	}
14458
14459
14460	/* Retrieve the target-procedure of an operator binding and do some checks in
14461	common for intrinsic and user-defined type-bound operators. */
14462
14463	static gfc_symbol*
14464	get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
14465	{
14466	gfc_symbol* target_proc;
14467
14468	gcc_assert (target->specific && !target->specific->is_generic);
14469	target_proc = target->specific->u.specific->n.sym;
14470	gcc_assert (target_proc);
14471
14472	/* F08:C468. All operator bindings must have a passed-object dummy argument. */
14473	if (target->specific->nopass)
14474	{
14475	gfc_error ("Type-bound operator at %L cannot be NOPASS", &where);
14476	return NULL;
14477	}
14478
14479	return target_proc;
14480	}
14481
14482
14483	/* Resolve a type-bound intrinsic operator. */
14484
14485	static bool
14486	resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
14487	gfc_typebound_proc* p)
14488	{
14489	gfc_symbol* super_type;
14490	gfc_tbp_generic* target;
14491
14492	/* If there's already an error here, do nothing (but don't fail again). */
14493	if (p->error)
14494	return true;
14495
14496	/* Operators should always be GENERIC bindings. */
14497	gcc_assert (p->is_generic);
14498
14499	/* Look for an overridden binding. */
14500	super_type = gfc_get_derived_super_type (derived);
14501	if (super_type && super_type->f2k_derived)
14502	p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
14503	op, true, NULL);
14504	else
14505	p->overridden = NULL;
14506
14507	/* Resolve general GENERIC properties using worker function. */
14508	if (!resolve_tb_generic_targets (super_type, p, name: gfc_op2string(op)))
14509	goto error;
14510
14511	/* Check the targets to be procedures of correct interface. */
14512	for (target = p->u.generic; target; target = target->next)
14513	{
14514	gfc_symbol* target_proc;
14515
14516	target_proc = get_checked_tb_operator_target (target, where: p->where);
14517	if (!target_proc)
14518	goto error;
14519
14520	if (!gfc_check_operator_interface (target_proc, op, p->where))
14521	goto error;
14522
14523	/* Add target to non-typebound operator list. */
14524	if (!target->specific->deferred && !derived->attr.use_assoc
14525	&& p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns)
14526	{
14527	gfc_interface *head, *intr;
14528
14529	/* Preempt 'gfc_check_new_interface' for submodules, where the
14530	mechanism for handling module procedures winds up resolving
14531	operator interfaces twice and would otherwise cause an error. */
14532	for (intr = derived->ns->op[op]; intr; intr = intr->next)
14533	if (intr->sym == target_proc
14534	&& target_proc->attr.used_in_submodule)
14535	return true;
14536
14537	if (!gfc_check_new_interface (derived->ns->op[op],
14538	target_proc, p->where))
14539	return false;
14540	head = derived->ns->op[op];
14541	intr = gfc_get_interface ();
14542	intr->sym = target_proc;
14543	intr->where = p->where;
14544	intr->next = head;
14545	derived->ns->op[op] = intr;
14546	}
14547	}
14548
14549	return true;
14550
14551	error:
14552	p->error = 1;
14553	return false;
14554	}
14555
14556
14557	/* Resolve a type-bound user operator (tree-walker callback). */
14558
14559	static gfc_symbol* resolve_bindings_derived;
14560	static bool resolve_bindings_result;
14561
14562	static bool check_uop_procedure (gfc_symbol* sym, locus where);
14563
14564	static void
14565	resolve_typebound_user_op (gfc_symtree* stree)
14566	{
14567	gfc_symbol* super_type;
14568	gfc_tbp_generic* target;
14569
14570	gcc_assert (stree && stree->n.tb);
14571
14572	if (stree->n.tb->error)
14573	return;
14574
14575	/* Operators should always be GENERIC bindings. */
14576	gcc_assert (stree->n.tb->is_generic);
14577
14578	/* Find overridden procedure, if any. */
14579	super_type = gfc_get_derived_super_type (resolve_bindings_derived);
14580	if (super_type && super_type->f2k_derived)
14581	{
14582	gfc_symtree* overridden;
14583	overridden = gfc_find_typebound_user_op (super_type, NULL,
14584	stree->name, true, NULL);
14585
14586	if (overridden && overridden->n.tb)
14587	stree->n.tb->overridden = overridden->n.tb;
14588	}
14589	else
14590	stree->n.tb->overridden = NULL;
14591
14592	/* Resolve basically using worker function. */
14593	if (!resolve_tb_generic_targets (super_type, p: stree->n.tb, name: stree->name))
14594	goto error;
14595
14596	/* Check the targets to be functions of correct interface. */
14597	for (target = stree->n.tb->u.generic; target; target = target->next)
14598	{
14599	gfc_symbol* target_proc;
14600
14601	target_proc = get_checked_tb_operator_target (target, where: stree->n.tb->where);
14602	if (!target_proc)
14603	goto error;
14604
14605	if (!check_uop_procedure (sym: target_proc, where: stree->n.tb->where))
14606	goto error;
14607	}
14608
14609	return;
14610
14611	error:
14612	resolve_bindings_result = false;
14613	stree->n.tb->error = 1;
14614	}
14615
14616
14617	/* Resolve the type-bound procedures for a derived type. */
14618
14619	static void
14620	resolve_typebound_procedure (gfc_symtree* stree)
14621	{
14622	gfc_symbol* proc;
14623	locus where;
14624	gfc_symbol* me_arg;
14625	gfc_symbol* super_type;
14626	gfc_component* comp;
14627
14628	gcc_assert (stree);
14629
14630	/* Undefined specific symbol from GENERIC target definition. */
14631	if (!stree->n.tb)
14632	return;
14633
14634	if (stree->n.tb->error)
14635	return;
14636
14637	/* If this is a GENERIC binding, use that routine. */
14638	if (stree->n.tb->is_generic)
14639	{
14640	if (!resolve_typebound_generic (derived: resolve_bindings_derived, st: stree))
14641	goto error;
14642	return;
14643	}
14644
14645	/* Get the target-procedure to check it. */
14646	gcc_assert (!stree->n.tb->is_generic);
14647	gcc_assert (stree->n.tb->u.specific);
14648	proc = stree->n.tb->u.specific->n.sym;
14649	where = stree->n.tb->where;
14650
14651	/* Default access should already be resolved from the parser. */
14652	gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
14653
14654	if (stree->n.tb->deferred)
14655	{
14656	if (!check_proc_interface (ifc: proc, where: &where))
14657	goto error;
14658	}
14659	else
14660	{
14661	/* If proc has not been resolved at this point, proc->name may
14662	actually be a USE associated entity. See PR fortran/89647. */
14663	if (!proc->resolve_symbol_called
14664	&& proc->attr.function == 0 && proc->attr.subroutine == 0)
14665	{
14666	gfc_symbol *tmp;
14667	gfc_find_symbol (proc->name, gfc_current_ns->parent, 1, &tmp);
14668	if (tmp && tmp->attr.use_assoc)
14669	{
14670	proc->module = tmp->module;
14671	proc->attr.proc = tmp->attr.proc;
14672	proc->attr.function = tmp->attr.function;
14673	proc->attr.subroutine = tmp->attr.subroutine;
14674	proc->attr.use_assoc = tmp->attr.use_assoc;
14675	proc->ts = tmp->ts;
14676	proc->result = tmp->result;
14677	}
14678	}
14679
14680	/* Check for F08:C465. */
14681	if ((!proc->attr.subroutine && !proc->attr.function)
14682	|| (proc->attr.proc != PROC_MODULE
14683	&& proc->attr.if_source != IFSRC_IFBODY
14684	&& !proc->attr.module_procedure)
14685	|| proc->attr.abstract)
14686	{
14687	gfc_error ("%qs must be a module procedure or an external "
14688	"procedure with an explicit interface at %L",
14689	proc->name, &where);
14690	goto error;
14691	}
14692	}
14693
14694	stree->n.tb->subroutine = proc->attr.subroutine;
14695	stree->n.tb->function = proc->attr.function;
14696
14697	/* Find the super-type of the current derived type. We could do this once and
14698	store in a global if speed is needed, but as long as not I believe this is
14699	more readable and clearer. */
14700	super_type = gfc_get_derived_super_type (resolve_bindings_derived);
14701
14702	/* If PASS, resolve and check arguments if not already resolved / loaded
14703	from a .mod file. */
14704	if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
14705	{
14706	gfc_formal_arglist *dummy_args;
14707
14708	dummy_args = gfc_sym_get_dummy_args (proc);
14709	if (stree->n.tb->pass_arg)
14710	{
14711	gfc_formal_arglist *i;
14712
14713	/* If an explicit passing argument name is given, walk the arg-list
14714	and look for it. */
14715
14716	me_arg = NULL;
14717	stree->n.tb->pass_arg_num = 1;
14718	for (i = dummy_args; i; i = i->next)
14719	{
14720	if (!strcmp (s1: i->sym->name, s2: stree->n.tb->pass_arg))
14721	{
14722	me_arg = i->sym;
14723	break;
14724	}
14725	++stree->n.tb->pass_arg_num;
14726	}
14727
14728	if (!me_arg)
14729	{
14730	gfc_error ("Procedure %qs with PASS(%s) at %L has no"
14731	" argument %qs",
14732	proc->name, stree->n.tb->pass_arg, &where,
14733	stree->n.tb->pass_arg);
14734	goto error;
14735	}
14736	}
14737	else
14738	{
14739	/* Otherwise, take the first one; there should in fact be at least
14740	one. */
14741	stree->n.tb->pass_arg_num = 1;
14742	if (!dummy_args)
14743	{
14744	gfc_error ("Procedure %qs with PASS at %L must have at"
14745	" least one argument", proc->name, &where);
14746	goto error;
14747	}
14748	me_arg = dummy_args->sym;
14749	}
14750
14751	/* Now check that the argument-type matches and the passed-object
14752	dummy argument is generally fine. */
14753
14754	gcc_assert (me_arg);
14755
14756	if (me_arg->ts.type != BT_CLASS)
14757	{
14758	gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
14759	" at %L", proc->name, &where);
14760	goto error;
14761	}
14762
14763	if (CLASS_DATA (me_arg)->ts.u.derived
14764	!= resolve_bindings_derived)
14765	{
14766	gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
14767	" the derived-type %qs", me_arg->name, proc->name,
14768	me_arg->name, &where, resolve_bindings_derived->name);
14769	goto error;
14770	}
14771
14772	gcc_assert (me_arg->ts.type == BT_CLASS);
14773	if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
14774	{
14775	gfc_error ("Passed-object dummy argument of %qs at %L must be"
14776	" scalar", proc->name, &where);
14777	goto error;
14778	}
14779	if (CLASS_DATA (me_arg)->attr.allocatable)
14780	{
14781	gfc_error ("Passed-object dummy argument of %qs at %L must not"
14782	" be ALLOCATABLE", proc->name, &where);
14783	goto error;
14784	}
14785	if (CLASS_DATA (me_arg)->attr.class_pointer)
14786	{
14787	gfc_error ("Passed-object dummy argument of %qs at %L must not"
14788	" be POINTER", proc->name, &where);
14789	goto error;
14790	}
14791	}
14792
14793	/* If we are extending some type, check that we don't override a procedure
14794	flagged NON_OVERRIDABLE. */
14795	stree->n.tb->overridden = NULL;
14796	if (super_type)
14797	{
14798	gfc_symtree* overridden;
14799	overridden = gfc_find_typebound_proc (super_type, NULL,
14800	stree->name, true, NULL);
14801
14802	if (overridden)
14803	{
14804	if (overridden->n.tb)
14805	stree->n.tb->overridden = overridden->n.tb;
14806
14807	if (!gfc_check_typebound_override (stree, overridden))
14808	goto error;
14809	}
14810	}
14811
14812	/* See if there's a name collision with a component directly in this type. */
14813	for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
14814	if (!strcmp (s1: comp->name, s2: stree->name))
14815	{
14816	gfc_error ("Procedure %qs at %L has the same name as a component of"
14817	" %qs",
14818	stree->name, &where, resolve_bindings_derived->name);
14819	goto error;
14820	}
14821
14822	/* Try to find a name collision with an inherited component. */
14823	if (super_type && gfc_find_component (super_type, stree->name, true, true,
14824	NULL))
14825	{
14826	gfc_error ("Procedure %qs at %L has the same name as an inherited"
14827	" component of %qs",
14828	stree->name, &where, resolve_bindings_derived->name);
14829	goto error;
14830	}
14831
14832	stree->n.tb->error = 0;
14833	return;
14834
14835	error:
14836	resolve_bindings_result = false;
14837	stree->n.tb->error = 1;
14838	}
14839
14840
14841	static bool
14842	resolve_typebound_procedures (gfc_symbol* derived)
14843	{
14844	int op;
14845	gfc_symbol* super_type;
14846
14847	if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
14848	return true;
14849
14850	super_type = gfc_get_derived_super_type (derived);
14851	if (super_type)
14852	resolve_symbol (sym: super_type);
14853
14854	resolve_bindings_derived = derived;
14855	resolve_bindings_result = true;
14856
14857	if (derived->f2k_derived->tb_sym_root)
14858	gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
14859	&resolve_typebound_procedure);
14860
14861	if (derived->f2k_derived->tb_uop_root)
14862	gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
14863	&resolve_typebound_user_op);
14864
14865	for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
14866	{
14867	gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
14868	if (p && !resolve_typebound_intrinsic_op (derived,
14869	op: (gfc_intrinsic_op)op, p))
14870	resolve_bindings_result = false;
14871	}
14872
14873	return resolve_bindings_result;
14874	}
14875
14876
14877	/* Add a derived type to the dt_list. The dt_list is used in trans-types.cc
14878	to give all identical derived types the same backend_decl. */
14879	static void
14880	add_dt_to_dt_list (gfc_symbol *derived)
14881	{
14882	if (!derived->dt_next)
14883	{
14884	if (gfc_derived_types)
14885	{
14886	derived->dt_next = gfc_derived_types->dt_next;
14887	gfc_derived_types->dt_next = derived;
14888	}
14889	else
14890	{
14891	derived->dt_next = derived;
14892	}
14893	gfc_derived_types = derived;
14894	}
14895	}
14896
14897
14898	/* Ensure that a derived-type is really not abstract, meaning that every
14899	inherited DEFERRED binding is overridden by a non-DEFERRED one. */
14900
14901	static bool
14902	ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
14903	{
14904	if (!st)
14905	return true;
14906
14907	if (!ensure_not_abstract_walker (sub, st: st->left))
14908	return false;
14909	if (!ensure_not_abstract_walker (sub, st: st->right))
14910	return false;
14911
14912	if (st->n.tb && st->n.tb->deferred)
14913	{
14914	gfc_symtree* overriding;
14915	overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
14916	if (!overriding)
14917	return false;
14918	gcc_assert (overriding->n.tb);
14919	if (overriding->n.tb->deferred)
14920	{
14921	gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
14922	" %qs is DEFERRED and not overridden",
14923	sub->name, &sub->declared_at, st->name);
14924	return false;
14925	}
14926	}
14927
14928	return true;
14929	}
14930
14931	static bool
14932	ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
14933	{
14934	/* The algorithm used here is to recursively travel up the ancestry of sub
14935	and for each ancestor-type, check all bindings. If any of them is
14936	DEFERRED, look it up starting from sub and see if the found (overriding)
14937	binding is not DEFERRED.
14938	This is not the most efficient way to do this, but it should be ok and is
14939	clearer than something sophisticated. */
14940
14941	gcc_assert (ancestor && !sub->attr.abstract);
14942
14943	if (!ancestor->attr.abstract)
14944	return true;
14945
14946	/* Walk bindings of this ancestor. */
14947	if (ancestor->f2k_derived)
14948	{
14949	bool t;
14950	t = ensure_not_abstract_walker (sub, st: ancestor->f2k_derived->tb_sym_root);
14951	if (!t)
14952	return false;
14953	}
14954
14955	/* Find next ancestor type and recurse on it. */
14956	ancestor = gfc_get_derived_super_type (ancestor);
14957	if (ancestor)
14958	return ensure_not_abstract (sub, ancestor);
14959
14960	return true;
14961	}
14962
14963
14964	/* This check for typebound defined assignments is done recursively
14965	since the order in which derived types are resolved is not always in
14966	order of the declarations. */
14967
14968	static void
14969	check_defined_assignments (gfc_symbol *derived)
14970	{
14971	gfc_component *c;
14972
14973	for (c = derived->components; c; c = c->next)
14974	{
14975	if (!gfc_bt_struct (c->ts.type)
14976	|| c->attr.pointer
14977	|| c->attr.proc_pointer_comp
14978	|| c->attr.class_pointer
14979	|| c->attr.proc_pointer)
14980	continue;
14981
14982	if (c->ts.u.derived->attr.defined_assign_comp
14983	|| (c->ts.u.derived->f2k_derived
14984	&& c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]))
14985	{
14986	derived->attr.defined_assign_comp = 1;
14987	return;
14988	}
14989
14990	if (c->attr.allocatable)
14991	continue;
14992
14993	check_defined_assignments (derived: c->ts.u.derived);
14994	if (c->ts.u.derived->attr.defined_assign_comp)
14995	{
14996	derived->attr.defined_assign_comp = 1;
14997	return;
14998	}
14999	}
15000	}
15001
15002
15003	/* Resolve a single component of a derived type or structure. */
15004
15005	static bool
15006	resolve_component (gfc_component *c, gfc_symbol *sym)
15007	{
15008	gfc_symbol *super_type;
15009	symbol_attribute *attr;
15010
15011	if (c->attr.artificial)
15012	return true;
15013
15014	/* Do not allow vtype components to be resolved in nameless namespaces
15015	such as block data because the procedure pointers will cause ICEs
15016	and vtables are not needed in these contexts. */
15017	if (sym->attr.vtype && sym->attr.use_assoc
15018	&& sym->ns->proc_name == NULL)
15019	return true;
15020
15021	/* F2008, C442. */
15022	if ((!sym->attr.is_class || c != sym->components)
15023	&& c->attr.codimension
15024	&& (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
15025	{
15026	gfc_error ("Coarray component %qs at %L must be allocatable with "
15027	"deferred shape", c->name, &c->loc);
15028	return false;
15029	}
15030
15031	/* F2008, C443. */
15032	if (c->attr.codimension && c->ts.type == BT_DERIVED
15033	&& c->ts.u.derived->ts.is_iso_c)
15034	{
15035	gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
15036	"shall not be a coarray", c->name, &c->loc);
15037	return false;
15038	}
15039
15040	/* F2008, C444. */
15041	if (gfc_bt_struct (c->ts.type) && c->ts.u.derived->attr.coarray_comp
15042	&& (c->attr.codimension || c->attr.pointer || c->attr.dimension
15043	|| c->attr.allocatable))
15044	{
15045	gfc_error ("Component %qs at %L with coarray component "
15046	"shall be a nonpointer, nonallocatable scalar",
15047	c->name, &c->loc);
15048	return false;
15049	}
15050
15051	/* F2008, C448. */
15052	if (c->ts.type == BT_CLASS)
15053	{
15054	if (c->attr.class_ok && CLASS_DATA (c))
15055	{
15056	attr = &(CLASS_DATA (c)->attr);
15057
15058	/* Fix up contiguous attribute. */
15059	if (c->attr.contiguous)
15060	attr->contiguous = 1;
15061	}
15062	else
15063	attr = NULL;
15064	}
15065	else
15066	attr = &c->attr;
15067
15068	if (attr && attr->contiguous && (!attr->dimension || !attr->pointer))
15069	{
15070	gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
15071	"is not an array pointer", c->name, &c->loc);
15072	return false;
15073	}
15074
15075	/* F2003, 15.2.1 - length has to be one. */
15076	if (sym->attr.is_bind_c && c->ts.type == BT_CHARACTER
15077	&& (c->ts.u.cl == NULL || c->ts.u.cl->length == NULL
15078	|| !gfc_is_constant_expr (c->ts.u.cl->length)
15079	|| mpz_cmp_si (c->ts.u.cl->length->value.integer, 1) != 0))
15080	{
15081	gfc_error ("Component %qs of BIND(C) type at %L must have length one",
15082	c->name, &c->loc);
15083	return false;
15084	}
15085
15086	if (c->attr.proc_pointer && c->ts.interface)
15087	{
15088	gfc_symbol *ifc = c->ts.interface;
15089
15090	if (!sym->attr.vtype && !check_proc_interface (ifc, where: &c->loc))
15091	{
15092	c->tb->error = 1;
15093	return false;
15094	}
15095
15096	if (ifc->attr.if_source || ifc->attr.intrinsic)
15097	{
15098	/* Resolve interface and copy attributes. */
15099	if (ifc->formal && !ifc->formal_ns)
15100	resolve_symbol (sym: ifc);
15101	if (ifc->attr.intrinsic)
15102	gfc_resolve_intrinsic (sym: ifc, loc: &ifc->declared_at);
15103
15104	if (ifc->result)
15105	{
15106	c->ts = ifc->result->ts;
15107	c->attr.allocatable = ifc->result->attr.allocatable;
15108	c->attr.pointer = ifc->result->attr.pointer;
15109	c->attr.dimension = ifc->result->attr.dimension;
15110	c->as = gfc_copy_array_spec (ifc->result->as);
15111	c->attr.class_ok = ifc->result->attr.class_ok;
15112	}
15113	else
15114	{
15115	c->ts = ifc->ts;
15116	c->attr.allocatable = ifc->attr.allocatable;
15117	c->attr.pointer = ifc->attr.pointer;
15118	c->attr.dimension = ifc->attr.dimension;
15119	c->as = gfc_copy_array_spec (ifc->as);
15120	c->attr.class_ok = ifc->attr.class_ok;
15121	}
15122	c->ts.interface = ifc;
15123	c->attr.function = ifc->attr.function;
15124	c->attr.subroutine = ifc->attr.subroutine;
15125
15126	c->attr.pure = ifc->attr.pure;
15127	c->attr.elemental = ifc->attr.elemental;
15128	c->attr.recursive = ifc->attr.recursive;
15129	c->attr.always_explicit = ifc->attr.always_explicit;
15130	c->attr.ext_attr |= ifc->attr.ext_attr;
15131	/* Copy char length. */
15132	if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
15133	{
15134	gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
15135	if (cl->length && !cl->resolved
15136	&& !gfc_resolve_expr (e: cl->length))
15137	{
15138	c->tb->error = 1;
15139	return false;
15140	}
15141	c->ts.u.cl = cl;
15142	}
15143	}
15144	}
15145	else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
15146	{
15147	/* Since PPCs are not implicitly typed, a PPC without an explicit
15148	interface must be a subroutine. */
15149	gfc_add_subroutine (&c->attr, c->name, &c->loc);
15150	}
15151
15152	/* Procedure pointer components: Check PASS arg. */
15153	if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
15154	&& !sym->attr.vtype)
15155	{
15156	gfc_symbol* me_arg;
15157
15158	if (c->tb->pass_arg)
15159	{
15160	gfc_formal_arglist* i;
15161
15162	/* If an explicit passing argument name is given, walk the arg-list
15163	and look for it. */
15164
15165	me_arg = NULL;
15166	c->tb->pass_arg_num = 1;
15167	for (i = c->ts.interface->formal; i; i = i->next)
15168	{
15169	if (!strcmp (s1: i->sym->name, s2: c->tb->pass_arg))
15170	{
15171	me_arg = i->sym;
15172	break;
15173	}
15174	c->tb->pass_arg_num++;
15175	}
15176
15177	if (!me_arg)
15178	{
15179	gfc_error ("Procedure pointer component %qs with PASS(%s) "
15180	"at %L has no argument %qs", c->name,
15181	c->tb->pass_arg, &c->loc, c->tb->pass_arg);
15182	c->tb->error = 1;
15183	return false;
15184	}
15185	}
15186	else
15187	{
15188	/* Otherwise, take the first one; there should in fact be at least
15189	one. */
15190	c->tb->pass_arg_num = 1;
15191	if (!c->ts.interface->formal)
15192	{
15193	gfc_error ("Procedure pointer component %qs with PASS at %L "
15194	"must have at least one argument",
15195	c->name, &c->loc);
15196	c->tb->error = 1;
15197	return false;
15198	}
15199	me_arg = c->ts.interface->formal->sym;
15200	}
15201
15202	/* Now check that the argument-type matches. */
15203	gcc_assert (me_arg);
15204	if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
15205	|| (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
15206	|| (me_arg->ts.type == BT_CLASS
15207	&& CLASS_DATA (me_arg)->ts.u.derived != sym))
15208	{
15209	gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
15210	" the derived type %qs", me_arg->name, c->name,
15211	me_arg->name, &c->loc, sym->name);
15212	c->tb->error = 1;
15213	return false;
15214	}
15215
15216	/* Check for F03:C453. */
15217	if (CLASS_DATA (me_arg)->attr.dimension)
15218	{
15219	gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
15220	"must be scalar", me_arg->name, c->name, me_arg->name,
15221	&c->loc);
15222	c->tb->error = 1;
15223	return false;
15224	}
15225
15226	if (CLASS_DATA (me_arg)->attr.class_pointer)
15227	{
15228	gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
15229	"may not have the POINTER attribute", me_arg->name,
15230	c->name, me_arg->name, &c->loc);
15231	c->tb->error = 1;
15232	return false;
15233	}
15234
15235	if (CLASS_DATA (me_arg)->attr.allocatable)
15236	{
15237	gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
15238	"may not be ALLOCATABLE", me_arg->name, c->name,
15239	me_arg->name, &c->loc);
15240	c->tb->error = 1;
15241	return false;
15242	}
15243
15244	if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
15245	{
15246	gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
15247	" at %L", c->name, &c->loc);
15248	return false;
15249	}
15250
15251	}
15252
15253	/* Check type-spec if this is not the parent-type component. */
15254	if (((sym->attr.is_class
15255	&& (!sym->components->ts.u.derived->attr.extension
15256	|| c != CLASS_DATA (sym->components)))
15257	|| (!sym->attr.is_class
15258	&& (!sym->attr.extension || c != sym->components)))
15259	&& !sym->attr.vtype
15260	&& !resolve_typespec_used (ts: &c->ts, where: &c->loc, name: c->name))
15261	return false;
15262
15263	super_type = gfc_get_derived_super_type (sym);
15264
15265	/* If this type is an extension, set the accessibility of the parent
15266	component. */
15267	if (super_type
15268	&& ((sym->attr.is_class
15269	&& c == CLASS_DATA (sym->components))
15270	|| (!sym->attr.is_class && c == sym->components))
15271	&& strcmp (s1: super_type->name, s2: c->name) == 0)
15272	c->attr.access = super_type->attr.access;
15273
15274	/* If this type is an extension, see if this component has the same name
15275	as an inherited type-bound procedure. */
15276	if (super_type && !sym->attr.is_class
15277	&& gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
15278	{
15279	gfc_error ("Component %qs of %qs at %L has the same name as an"
15280	" inherited type-bound procedure",
15281	c->name, sym->name, &c->loc);
15282	return false;
15283	}
15284
15285	if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
15286	&& !c->ts.deferred)
15287	{
15288	if (c->ts.u.cl->length == NULL
15289	|| (!resolve_charlen(cl: c->ts.u.cl))
15290	|| !gfc_is_constant_expr (c->ts.u.cl->length))
15291	{
15292	gfc_error ("Character length of component %qs needs to "
15293	"be a constant specification expression at %L",
15294	c->name,
15295	c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
15296	return false;
15297	}
15298
15299	if (c->ts.u.cl->length && c->ts.u.cl->length->ts.type != BT_INTEGER)
15300	{
15301	if (!c->ts.u.cl->length->error)
15302	{
15303	gfc_error ("Character length expression of component %qs at %L "
15304	"must be of INTEGER type, found %s",
15305	c->name, &c->ts.u.cl->length->where,
15306	gfc_basic_typename (c->ts.u.cl->length->ts.type));
15307	c->ts.u.cl->length->error = 1;
15308	}
15309	return false;
15310	}
15311	}
15312
15313	if (c->ts.type == BT_CHARACTER && c->ts.deferred
15314	&& !c->attr.pointer && !c->attr.allocatable)
15315	{
15316	gfc_error ("Character component %qs of %qs at %L with deferred "
15317	"length must be a POINTER or ALLOCATABLE",
15318	c->name, sym->name, &c->loc);
15319	return false;
15320	}
15321
15322	/* Add the hidden deferred length field. */
15323	if (c->ts.type == BT_CHARACTER
15324	&& (c->ts.deferred || c->attr.pdt_string)
15325	&& !c->attr.function
15326	&& !sym->attr.is_class)
15327	{
15328	char name[GFC_MAX_SYMBOL_LEN+9];
15329	gfc_component *strlen;
15330	sprintf (s: name, format: "_%s_length", c->name);
15331	strlen = gfc_find_component (sym, name, true, true, NULL);
15332	if (strlen == NULL)
15333	{
15334	if (!gfc_add_component (sym, name, &strlen))
15335	return false;
15336	strlen->ts.type = BT_INTEGER;
15337	strlen->ts.kind = gfc_charlen_int_kind;
15338	strlen->attr.access = ACCESS_PRIVATE;
15339	strlen->attr.artificial = 1;
15340	}
15341	}
15342
15343	if (c->ts.type == BT_DERIVED
15344	&& sym->component_access != ACCESS_PRIVATE
15345	&& gfc_check_symbol_access (sym)
15346	&& !is_sym_host_assoc (sym: c->ts.u.derived, ns: sym->ns)
15347	&& !c->ts.u.derived->attr.use_assoc
15348	&& !gfc_check_symbol_access (c->ts.u.derived)
15349	&& !gfc_notify_std (GFC_STD_F2003, "the component %qs is a "
15350	"PRIVATE type and cannot be a component of "
15351	"%qs, which is PUBLIC at %L", c->name,
15352	sym->name, &sym->declared_at))
15353	return false;
15354
15355	if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
15356	{
15357	gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
15358	"type %s", c->name, &c->loc, sym->name);
15359	return false;
15360	}
15361
15362	if (sym->attr.sequence)
15363	{
15364	if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
15365	{
15366	gfc_error ("Component %s of SEQUENCE type declared at %L does "
15367	"not have the SEQUENCE attribute",
15368	c->ts.u.derived->name, &sym->declared_at);
15369	return false;
15370	}
15371	}
15372
15373	if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
15374	c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
15375	else if (c->ts.type == BT_CLASS && c->attr.class_ok
15376	&& CLASS_DATA (c)->ts.u.derived->attr.generic)
15377	CLASS_DATA (c)->ts.u.derived
15378	= gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
15379
15380	/* If an allocatable component derived type is of the same type as
15381	the enclosing derived type, we need a vtable generating so that
15382	the __deallocate procedure is created. */
15383	if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
15384	&& c->ts.u.derived == sym && c->attr.allocatable == 1)
15385	gfc_find_vtab (&c->ts);
15386
15387	/* Ensure that all the derived type components are put on the
15388	derived type list; even in formal namespaces, where derived type
15389	pointer components might not have been declared. */
15390	if (c->ts.type == BT_DERIVED
15391	&& c->ts.u.derived
15392	&& c->ts.u.derived->components
15393	&& c->attr.pointer
15394	&& sym != c->ts.u.derived)
15395	add_dt_to_dt_list (derived: c->ts.u.derived);
15396
15397	if (c->as && c->as->type != AS_DEFERRED
15398	&& (c->attr.pointer || c->attr.allocatable))
15399	return false;
15400
15401	if (!gfc_resolve_array_spec (c->as,
15402	!(c->attr.pointer || c->attr.proc_pointer
15403	|| c->attr.allocatable)))
15404	return false;
15405
15406	if (c->initializer && !sym->attr.vtype
15407	&& !c->attr.pdt_kind && !c->attr.pdt_len
15408	&& !gfc_check_assign_symbol (sym, c, c->initializer))
15409	return false;
15410
15411	return true;
15412	}
15413
15414
15415	/* Be nice about the locus for a structure expression - show the locus of the
15416	first non-null sub-expression if we can. */
15417
15418	static locus *
15419	cons_where (gfc_expr *struct_expr)
15420	{
15421	gfc_constructor *cons;
15422
15423	gcc_assert (struct_expr && struct_expr->expr_type == EXPR_STRUCTURE);
15424
15425	cons = gfc_constructor_first (base: struct_expr->value.constructor);
15426	for (; cons; cons = gfc_constructor_next (ctor: cons))
15427	{
15428	if (cons->expr && cons->expr->expr_type != EXPR_NULL)
15429	return &cons->expr->where;
15430	}
15431
15432	return &struct_expr->where;
15433	}
15434
15435	/* Resolve the components of a structure type. Much less work than derived
15436	types. */
15437
15438	static bool
15439	resolve_fl_struct (gfc_symbol *sym)
15440	{
15441	gfc_component *c;
15442	gfc_expr *init = NULL;
15443	bool success;
15444
15445	/* Make sure UNIONs do not have overlapping initializers. */
15446	if (sym->attr.flavor == FL_UNION)
15447	{
15448	for (c = sym->components; c; c = c->next)
15449	{
15450	if (init && c->initializer)
15451	{
15452	gfc_error ("Conflicting initializers in union at %L and %L",
15453	cons_where (struct_expr: init), cons_where (struct_expr: c->initializer));
15454	gfc_free_expr (c->initializer);
15455	c->initializer = NULL;
15456	}
15457	if (init == NULL)
15458	init = c->initializer;
15459	}
15460	}
15461
15462	success = true;
15463	for (c = sym->components; c; c = c->next)
15464	if (!resolve_component (c, sym))
15465	success = false;
15466
15467	if (!success)
15468	return false;
15469
15470	if (sym->components)
15471	add_dt_to_dt_list (derived: sym);
15472
15473	return true;
15474	}
15475
15476
15477	/* Resolve the components of a derived type. This does not have to wait until
15478	resolution stage, but can be done as soon as the dt declaration has been
15479	parsed. */
15480
15481	static bool
15482	resolve_fl_derived0 (gfc_symbol *sym)
15483	{
15484	gfc_symbol* super_type;
15485	gfc_component *c;
15486	gfc_formal_arglist *f;
15487	bool success;
15488
15489	if (sym->attr.unlimited_polymorphic)
15490	return true;
15491
15492	super_type = gfc_get_derived_super_type (sym);
15493
15494	/* F2008, C432. */
15495	if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
15496	{
15497	gfc_error ("As extending type %qs at %L has a coarray component, "
15498	"parent type %qs shall also have one", sym->name,
15499	&sym->declared_at, super_type->name);
15500	return false;
15501	}
15502
15503	/* Ensure the extended type gets resolved before we do. */
15504	if (super_type && !resolve_fl_derived0 (sym: super_type))
15505	return false;
15506
15507	/* An ABSTRACT type must be extensible. */
15508	if (sym->attr.abstract && !gfc_type_is_extensible (sym))
15509	{
15510	gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
15511	sym->name, &sym->declared_at);
15512	return false;
15513	}
15514
15515	c = (sym->attr.is_class) ? CLASS_DATA (sym->components)
15516	: sym->components;
15517
15518	success = true;
15519	for ( ; c != NULL; c = c->next)
15520	if (!resolve_component (c, sym))
15521	success = false;
15522
15523	if (!success)
15524	return false;
15525
15526	/* Now add the caf token field, where needed. */
15527	if (flag_coarray != GFC_FCOARRAY_NONE
15528	&& !sym->attr.is_class && !sym->attr.vtype)
15529	{
15530	for (c = sym->components; c; c = c->next)
15531	if (!c->attr.dimension && !c->attr.codimension
15532	&& (c->attr.allocatable || c->attr.pointer))
15533	{
15534	char name[GFC_MAX_SYMBOL_LEN+9];
15535	gfc_component *token;
15536	sprintf (s: name, format: "_caf_%s", c->name);
15537	token = gfc_find_component (sym, name, true, true, NULL);
15538	if (token == NULL)
15539	{
15540	if (!gfc_add_component (sym, name, &token))
15541	return false;
15542	token->ts.type = BT_VOID;
15543	token->ts.kind = gfc_default_integer_kind;
15544	token->attr.access = ACCESS_PRIVATE;
15545	token->attr.artificial = 1;
15546	token->attr.caf_token = 1;
15547	}
15548	}
15549	}
15550
15551	check_defined_assignments (derived: sym);
15552
15553	if (!sym->attr.defined_assign_comp && super_type)
15554	sym->attr.defined_assign_comp
15555	= super_type->attr.defined_assign_comp;
15556
15557	/* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
15558	all DEFERRED bindings are overridden. */
15559	if (super_type && super_type->attr.abstract && !sym->attr.abstract
15560	&& !sym->attr.is_class
15561	&& !ensure_not_abstract (sub: sym, ancestor: super_type))
15562	return false;
15563
15564	/* Check that there is a component for every PDT parameter. */
15565	if (sym->attr.pdt_template)
15566	{
15567	for (f = sym->formal; f; f = f->next)
15568	{
15569	if (!f->sym)
15570	continue;
15571	c = gfc_find_component (sym, f->sym->name, true, true, NULL);
15572	if (c == NULL)
15573	{
15574	gfc_error ("Parameterized type %qs does not have a component "
15575	"corresponding to parameter %qs at %L", sym->name,
15576	f->sym->name, &sym->declared_at);
15577	break;
15578	}
15579	}
15580	}
15581
15582	/* Add derived type to the derived type list. */
15583	add_dt_to_dt_list (derived: sym);
15584
15585	return true;
15586	}
15587
15588
15589	/* The following procedure does the full resolution of a derived type,
15590	including resolution of all type-bound procedures (if present). In contrast
15591	to 'resolve_fl_derived0' this can only be done after the module has been
15592	parsed completely. */
15593
15594	static bool
15595	resolve_fl_derived (gfc_symbol *sym)
15596	{
15597	gfc_symbol *gen_dt = NULL;
15598
15599	if (sym->attr.unlimited_polymorphic)
15600	return true;
15601
15602	if (!sym->attr.is_class)
15603	gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
15604	if (gen_dt && gen_dt->generic && gen_dt->generic->next
15605	&& (!gen_dt->generic->sym->attr.use_assoc
15606	|| gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
15607	&& !gfc_notify_std (GFC_STD_F2003, "Generic name %qs of function "
15608	"%qs at %L being the same name as derived "
15609	"type at %L", sym->name,
15610	gen_dt->generic->sym == sym
15611	? gen_dt->generic->next->sym->name
15612	: gen_dt->generic->sym->name,
15613	gen_dt->generic->sym == sym
15614	? &gen_dt->generic->next->sym->declared_at
15615	: &gen_dt->generic->sym->declared_at,
15616	&sym->declared_at))
15617	return false;
15618
15619	if (sym->components == NULL && !sym->attr.zero_comp && !sym->attr.use_assoc)
15620	{
15621	gfc_error ("Derived type %qs at %L has not been declared",
15622	sym->name, &sym->declared_at);
15623	return false;
15624	}
15625
15626	/* Resolve the finalizer procedures. */
15627	if (!gfc_resolve_finalizers (derived: sym, NULL))
15628	return false;
15629
15630	if (sym->attr.is_class && sym->ts.u.derived == NULL)
15631	{
15632	/* Fix up incomplete CLASS symbols. */
15633	gfc_component *data = gfc_find_component (sym, "_data", true, true, NULL);
15634	gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true, NULL);
15635
15636	/* Nothing more to do for unlimited polymorphic entities. */
15637	if (data->ts.u.derived->attr.unlimited_polymorphic)
15638	{
15639	add_dt_to_dt_list (derived: sym);
15640	return true;
15641	}
15642	else if (vptr->ts.u.derived == NULL)
15643	{
15644	gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
15645	gcc_assert (vtab);
15646	vptr->ts.u.derived = vtab->ts.u.derived;
15647	if (!resolve_fl_derived0 (sym: vptr->ts.u.derived))
15648	return false;
15649	}
15650	}
15651
15652	if (!resolve_fl_derived0 (sym))
15653	return false;
15654
15655	/* Resolve the type-bound procedures. */
15656	if (!resolve_typebound_procedures (derived: sym))
15657	return false;
15658
15659	/* Generate module vtables subject to their accessibility and their not
15660	being vtables or pdt templates. If this is not done class declarations
15661	in external procedures wind up with their own version and so SELECT TYPE
15662	fails because the vptrs do not have the same address. */
15663	if (gfc_option.allow_std & GFC_STD_F2003
15664	&& sym->ns->proc_name
15665	&& sym->ns->proc_name->attr.flavor == FL_MODULE
15666	&& sym->attr.access != ACCESS_PRIVATE
15667	&& !(sym->attr.vtype || sym->attr.pdt_template))
15668	{
15669	gfc_symbol *vtab = gfc_find_derived_vtab (sym);
15670	gfc_set_sym_referenced (vtab);
15671	}
15672
15673	return true;
15674	}
15675
15676
15677	static bool
15678	resolve_fl_namelist (gfc_symbol *sym)
15679	{
15680	gfc_namelist *nl;
15681	gfc_symbol *nlsym;
15682
15683	for (nl = sym->namelist; nl; nl = nl->next)
15684	{
15685	/* Check again, the check in match only works if NAMELIST comes
15686	after the decl. */
15687	if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
15688	{
15689	gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
15690	"allowed", nl->sym->name, sym->name, &sym->declared_at);
15691	return false;
15692	}
15693
15694	if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
15695	&& !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
15696	"with assumed shape in namelist %qs at %L",
15697	nl->sym->name, sym->name, &sym->declared_at))
15698	return false;
15699
15700	if (is_non_constant_shape_array (sym: nl->sym)
15701	&& !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
15702	"with nonconstant shape in namelist %qs at %L",
15703	nl->sym->name, sym->name, &sym->declared_at))
15704	return false;
15705
15706	if (nl->sym->ts.type == BT_CHARACTER
15707	&& (nl->sym->ts.u.cl->length == NULL
15708	|| !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
15709	&& !gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs with "
15710	"nonconstant character length in "
15711	"namelist %qs at %L", nl->sym->name,
15712	sym->name, &sym->declared_at))
15713	return false;
15714
15715	}
15716
15717	/* Reject PRIVATE objects in a PUBLIC namelist. */
15718	if (gfc_check_symbol_access (sym))
15719	{
15720	for (nl = sym->namelist; nl; nl = nl->next)
15721	{
15722	if (!nl->sym->attr.use_assoc
15723	&& !is_sym_host_assoc (sym: nl->sym, ns: sym->ns)
15724	&& !gfc_check_symbol_access (nl->sym))
15725	{
15726	gfc_error ("NAMELIST object %qs was declared PRIVATE and "
15727	"cannot be member of PUBLIC namelist %qs at %L",
15728	nl->sym->name, sym->name, &sym->declared_at);
15729	return false;
15730	}
15731
15732	if (nl->sym->ts.type == BT_DERIVED
15733	&& (nl->sym->ts.u.derived->attr.alloc_comp
15734	|| nl->sym->ts.u.derived->attr.pointer_comp))
15735	{
15736	if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
15737	"namelist %qs at %L with ALLOCATABLE "
15738	"or POINTER components", nl->sym->name,
15739	sym->name, &sym->declared_at))
15740	return false;
15741	return true;
15742	}
15743
15744	/* Types with private components that came here by USE-association. */
15745	if (nl->sym->ts.type == BT_DERIVED
15746	&& derived_inaccessible (sym: nl->sym->ts.u.derived))
15747	{
15748	gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
15749	"components and cannot be member of namelist %qs at %L",
15750	nl->sym->name, sym->name, &sym->declared_at);
15751	return false;
15752	}
15753
15754	/* Types with private components that are defined in the same module. */
15755	if (nl->sym->ts.type == BT_DERIVED
15756	&& !is_sym_host_assoc (sym: nl->sym->ts.u.derived, ns: sym->ns)
15757	&& nl->sym->ts.u.derived->attr.private_comp)
15758	{
15759	gfc_error ("NAMELIST object %qs has PRIVATE components and "
15760	"cannot be a member of PUBLIC namelist %qs at %L",
15761	nl->sym->name, sym->name, &sym->declared_at);
15762	return false;
15763	}
15764	}
15765	}
15766
15767
15768	/* 14.1.2 A module or internal procedure represent local entities
15769	of the same type as a namelist member and so are not allowed. */
15770	for (nl = sym->namelist; nl; nl = nl->next)
15771	{
15772	if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
15773	continue;
15774
15775	if (nl->sym->attr.function && nl->sym == nl->sym->result)
15776	if ((nl->sym == sym->ns->proc_name)
15777	||
15778	(sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
15779	continue;
15780
15781	nlsym = NULL;
15782	if (nl->sym->name)
15783	gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
15784	if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
15785	{
15786	gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
15787	"attribute in %qs at %L", nlsym->name,
15788	&sym->declared_at);
15789	return false;
15790	}
15791	}
15792
15793	return true;
15794	}
15795
15796
15797	static bool
15798	resolve_fl_parameter (gfc_symbol *sym)
15799	{
15800	/* A parameter array's shape needs to be constant. */
15801	if (sym->as != NULL
15802	&& (sym->as->type == AS_DEFERRED
15803	|| is_non_constant_shape_array (sym)))
15804	{
15805	gfc_error ("Parameter array %qs at %L cannot be automatic "
15806	"or of deferred shape", sym->name, &sym->declared_at);
15807	return false;
15808	}
15809
15810	/* Constraints on deferred type parameter. */
15811	if (!deferred_requirements (sym))
15812	return false;
15813
15814	/* Make sure a parameter that has been implicitly typed still
15815	matches the implicit type, since PARAMETER statements can precede
15816	IMPLICIT statements. */
15817	if (sym->attr.implicit_type
15818	&& !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
15819	sym->ns)))
15820	{
15821	gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
15822	"later IMPLICIT type", sym->name, &sym->declared_at);
15823	return false;
15824	}
15825
15826	/* Make sure the types of derived parameters are consistent. This
15827	type checking is deferred until resolution because the type may
15828	refer to a derived type from the host. */
15829	if (sym->ts.type == BT_DERIVED
15830	&& !gfc_compare_types (&sym->ts, &sym->value->ts))
15831	{
15832	gfc_error ("Incompatible derived type in PARAMETER at %L",
15833	&sym->value->where);
15834	return false;
15835	}
15836
15837	/* F03:C509,C514. */
15838	if (sym->ts.type == BT_CLASS)
15839	{
15840	gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
15841	sym->name, &sym->declared_at);
15842	return false;
15843	}
15844
15845	return true;
15846	}
15847
15848
15849	/* Called by resolve_symbol to check PDTs. */
15850
15851	static void
15852	resolve_pdt (gfc_symbol* sym)
15853	{
15854	gfc_symbol *derived = NULL;
15855	gfc_actual_arglist *param;
15856	gfc_component *c;
15857	bool const_len_exprs = true;
15858	bool assumed_len_exprs = false;
15859	symbol_attribute *attr;
15860
15861	if (sym->ts.type == BT_DERIVED)
15862	{
15863	derived = sym->ts.u.derived;
15864	attr = &(sym->attr);
15865	}
15866	else if (sym->ts.type == BT_CLASS)
15867	{
15868	derived = CLASS_DATA (sym)->ts.u.derived;
15869	attr = &(CLASS_DATA (sym)->attr);
15870	}
15871	else
15872	gcc_unreachable ();
15873
15874	gcc_assert (derived->attr.pdt_type);
15875
15876	for (param = sym->param_list; param; param = param->next)
15877	{
15878	c = gfc_find_component (derived, param->name, false, true, NULL);
15879	gcc_assert (c);
15880	if (c->attr.pdt_kind)
15881	continue;
15882
15883	if (param->expr && !gfc_is_constant_expr (param->expr)
15884	&& c->attr.pdt_len)
15885	const_len_exprs = false;
15886	else if (param->spec_type == SPEC_ASSUMED)
15887	assumed_len_exprs = true;
15888
15889	if (param->spec_type == SPEC_DEFERRED
15890	&& !attr->allocatable && !attr->pointer)
15891	gfc_error ("The object %qs at %L has a deferred LEN "
15892	"parameter %qs and is neither allocatable "
15893	"nor a pointer", sym->name, &sym->declared_at,
15894	param->name);
15895
15896	}
15897
15898	if (!const_len_exprs
15899	&& (sym->ns->proc_name->attr.is_main_program
15900	|| sym->ns->proc_name->attr.flavor == FL_MODULE
15901	|| sym->attr.save != SAVE_NONE))
15902	gfc_error ("The AUTOMATIC object %qs at %L must not have the "
15903	"SAVE attribute or be a variable declared in the "
15904	"main program, a module or a submodule(F08/C513)",
15905	sym->name, &sym->declared_at);
15906
15907	if (assumed_len_exprs && !(sym->attr.dummy
15908	|| sym->attr.select_type_temporary || sym->attr.associate_var))
15909	gfc_error ("The object %qs at %L with ASSUMED type parameters "
15910	"must be a dummy or a SELECT TYPE selector(F08/4.2)",
15911	sym->name, &sym->declared_at);
15912	}
15913
15914
15915	/* Do anything necessary to resolve a symbol. Right now, we just
15916	assume that an otherwise unknown symbol is a variable. This sort
15917	of thing commonly happens for symbols in module. */
15918
15919	static void
15920	resolve_symbol (gfc_symbol *sym)
15921	{
15922	int check_constant, mp_flag;
15923	gfc_symtree *symtree;
15924	gfc_symtree *this_symtree;
15925	gfc_namespace *ns;
15926	gfc_component *c;
15927	symbol_attribute class_attr;
15928	gfc_array_spec *as;
15929	bool saved_specification_expr;
15930
15931	if (sym->resolve_symbol_called >= 1)
15932	return;
15933	sym->resolve_symbol_called = 1;
15934
15935	/* No symbol will ever have union type; only components can be unions.
15936	Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
15937	(just like derived type declaration symbols have flavor FL_DERIVED). */
15938	gcc_assert (sym->ts.type != BT_UNION);
15939
15940	/* Coarrayed polymorphic objects with allocatable or pointer components are
15941	yet unsupported for -fcoarray=lib. */
15942	if (flag_coarray == GFC_FCOARRAY_LIB && sym->ts.type == BT_CLASS
15943	&& sym->ts.u.derived && CLASS_DATA (sym)
15944	&& CLASS_DATA (sym)->attr.codimension
15945	&& CLASS_DATA (sym)->ts.u.derived
15946	&& (CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp
15947	|| CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp))
15948	{
15949	gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
15950	"type coarrays at %L are unsupported", &sym->declared_at);
15951	return;
15952	}
15953
15954	if (sym->attr.artificial)
15955	return;
15956
15957	if (sym->attr.unlimited_polymorphic)
15958	return;
15959
15960	if (UNLIKELY (flag_openmp && strcmp (sym->name, "omp_all_memory") == 0))
15961	{
15962	gfc_error ("%<omp_all_memory%>, declared at %L, may only be used in "
15963	"the OpenMP DEPEND clause", &sym->declared_at);
15964	return;
15965	}
15966
15967	if (sym->attr.flavor == FL_UNKNOWN
15968	|| (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
15969	&& !sym->attr.generic && !sym->attr.external
15970	&& sym->attr.if_source == IFSRC_UNKNOWN
15971	&& sym->ts.type == BT_UNKNOWN))
15972	{
15973
15974	/* If we find that a flavorless symbol is an interface in one of the
15975	parent namespaces, find its symtree in this namespace, free the
15976	symbol and set the symtree to point to the interface symbol. */
15977	for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
15978	{
15979	symtree = gfc_find_symtree (ns->sym_root, sym->name);
15980	if (symtree && (symtree->n.sym->generic ||
15981	(symtree->n.sym->attr.flavor == FL_PROCEDURE
15982	&& sym->ns->construct_entities)))
15983	{
15984	this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
15985	sym->name);
15986	if (this_symtree->n.sym == sym)
15987	{
15988	symtree->n.sym->refs++;
15989	gfc_release_symbol (sym);
15990	this_symtree->n.sym = symtree->n.sym;
15991	return;
15992	}
15993	}
15994	}
15995
15996	/* Otherwise give it a flavor according to such attributes as
15997	it has. */
15998	if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0
15999	&& sym->attr.intrinsic == 0)
16000	sym->attr.flavor = FL_VARIABLE;
16001	else if (sym->attr.flavor == FL_UNKNOWN)
16002	{
16003	sym->attr.flavor = FL_PROCEDURE;
16004	if (sym->attr.dimension)
16005	sym->attr.function = 1;
16006	}
16007	}
16008
16009	if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
16010	gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
16011
16012	if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
16013	&& !resolve_procedure_interface (sym))
16014	return;
16015
16016	if (sym->attr.is_protected && !sym->attr.proc_pointer
16017	&& (sym->attr.procedure || sym->attr.external))
16018	{
16019	if (sym->attr.external)
16020	gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
16021	"at %L", &sym->declared_at);
16022	else
16023	gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
16024	"at %L", &sym->declared_at);
16025
16026	return;
16027	}
16028
16029	if (sym->attr.flavor == FL_DERIVED && !resolve_fl_derived (sym))
16030	return;
16031
16032	else if ((sym->attr.flavor == FL_STRUCT || sym->attr.flavor == FL_UNION)
16033	&& !resolve_fl_struct (sym))
16034	return;
16035
16036	/* Symbols that are module procedures with results (functions) have
16037	the types and array specification copied for type checking in
16038	procedures that call them, as well as for saving to a module
16039	file. These symbols can't stand the scrutiny that their results
16040	can. */
16041	mp_flag = (sym->result != NULL && sym->result != sym);
16042
16043	/* Make sure that the intrinsic is consistent with its internal
16044	representation. This needs to be done before assigning a default
16045	type to avoid spurious warnings. */
16046	if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
16047	&& !gfc_resolve_intrinsic (sym, loc: &sym->declared_at))
16048	return;
16049
16050	/* Resolve associate names. */
16051	if (sym->assoc)
16052	resolve_assoc_var (sym, resolve_target: true);
16053
16054	/* Assign default type to symbols that need one and don't have one. */
16055	if (sym->ts.type == BT_UNKNOWN)
16056	{
16057	if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
16058	{
16059	gfc_set_default_type (sym, 1, NULL);
16060	}
16061
16062	if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
16063	&& !sym->attr.function && !sym->attr.subroutine
16064	&& gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
16065	gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
16066
16067	if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
16068	{
16069	/* The specific case of an external procedure should emit an error
16070	in the case that there is no implicit type. */
16071	if (!mp_flag)
16072	{
16073	if (!sym->attr.mixed_entry_master)
16074	gfc_set_default_type (sym, sym->attr.external, NULL);
16075	}
16076	else
16077	{
16078	/* Result may be in another namespace. */
16079	resolve_symbol (sym: sym->result);
16080
16081	if (!sym->result->attr.proc_pointer)
16082	{
16083	sym->ts = sym->result->ts;
16084	sym->as = gfc_copy_array_spec (sym->result->as);
16085	sym->attr.dimension = sym->result->attr.dimension;
16086	sym->attr.pointer = sym->result->attr.pointer;
16087	sym->attr.allocatable = sym->result->attr.allocatable;
16088	sym->attr.contiguous = sym->result->attr.contiguous;
16089	}
16090	}
16091	}
16092	}
16093	else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
16094	{
16095	bool saved_specification_expr = specification_expr;
16096	bool saved_formal_arg_flag = formal_arg_flag;
16097
16098	specification_expr = true;
16099	formal_arg_flag = true;
16100	gfc_resolve_array_spec (sym->result->as, false);
16101	formal_arg_flag = saved_formal_arg_flag;
16102	specification_expr = saved_specification_expr;
16103	}
16104
16105	if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived
16106	&& CLASS_DATA (sym))
16107	{
16108	as = CLASS_DATA (sym)->as;
16109	class_attr = CLASS_DATA (sym)->attr;
16110	class_attr.pointer = class_attr.class_pointer;
16111	}
16112	else
16113	{
16114	class_attr = sym->attr;
16115	as = sym->as;
16116	}
16117
16118	/* F2008, C530. */
16119	if (sym->attr.contiguous
16120	&& (!class_attr.dimension
16121	|| (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK
16122	&& !class_attr.pointer)))
16123	{
16124	gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
16125	"array pointer or an assumed-shape or assumed-rank array",
16126	sym->name, &sym->declared_at);
16127	return;
16128	}
16129
16130	/* Assumed size arrays and assumed shape arrays must be dummy
16131	arguments. Array-spec's of implied-shape should have been resolved to
16132	AS_EXPLICIT already. */
16133
16134	if (as)
16135	{
16136	/* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
16137	specification expression. */
16138	if (as->type == AS_IMPLIED_SHAPE)
16139	{
16140	int i;
16141	for (i=0; i<as->rank; i++)
16142	{
16143	if (as->lower[i] != NULL && as->upper[i] == NULL)
16144	{
16145	gfc_error ("Bad specification for assumed size array at %L",
16146	&as->lower[i]->where);
16147	return;
16148	}
16149	}
16150	gcc_unreachable();
16151	}
16152
16153	if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
16154	|| as->type == AS_ASSUMED_SHAPE)
16155	&& !sym->attr.dummy && !sym->attr.select_type_temporary
16156	&& !sym->attr.associate_var)
16157	{
16158	if (as->type == AS_ASSUMED_SIZE)
16159	gfc_error ("Assumed size array at %L must be a dummy argument",
16160	&sym->declared_at);
16161	else
16162	gfc_error ("Assumed shape array at %L must be a dummy argument",
16163	&sym->declared_at);
16164	return;
16165	}
16166	/* TS 29113, C535a. */
16167	if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
16168	&& !sym->attr.select_type_temporary
16169	&& !(cs_base && cs_base->current
16170	&& cs_base->current->op == EXEC_SELECT_RANK))
16171	{
16172	gfc_error ("Assumed-rank array at %L must be a dummy argument",
16173	&sym->declared_at);
16174	return;
16175	}
16176	if (as->type == AS_ASSUMED_RANK
16177	&& (sym->attr.codimension || sym->attr.value))
16178	{
16179	gfc_error ("Assumed-rank array at %L may not have the VALUE or "
16180	"CODIMENSION attribute", &sym->declared_at);
16181	return;
16182	}
16183	}
16184
16185	/* Make sure symbols with known intent or optional are really dummy
16186	variable. Because of ENTRY statement, this has to be deferred
16187	until resolution time. */
16188
16189	if (!sym->attr.dummy
16190	&& (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
16191	{
16192	gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
16193	return;
16194	}
16195
16196	if (sym->attr.value && !sym->attr.dummy)
16197	{
16198	gfc_error ("%qs at %L cannot have the VALUE attribute because "
16199	"it is not a dummy argument", sym->name, &sym->declared_at);
16200	return;
16201	}
16202
16203	if (sym->attr.value && sym->ts.type == BT_CHARACTER)
16204	{
16205	gfc_charlen *cl = sym->ts.u.cl;
16206	if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
16207	{
16208	gfc_error ("Character dummy variable %qs at %L with VALUE "
16209	"attribute must have constant length",
16210	sym->name, &sym->declared_at);
16211	return;
16212	}
16213
16214	if (sym->ts.is_c_interop
16215	&& mpz_cmp_si (cl->length->value.integer, 1) != 0)
16216	{
16217	gfc_error ("C interoperable character dummy variable %qs at %L "
16218	"with VALUE attribute must have length one",
16219	sym->name, &sym->declared_at);
16220	return;
16221	}
16222	}
16223
16224	if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
16225	&& sym->ts.u.derived->attr.generic)
16226	{
16227	sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
16228	if (!sym->ts.u.derived)
16229	{
16230	gfc_error ("The derived type %qs at %L is of type %qs, "
16231	"which has not been defined", sym->name,
16232	&sym->declared_at, sym->ts.u.derived->name);
16233	sym->ts.type = BT_UNKNOWN;
16234	return;
16235	}
16236	}
16237
16238	/* Use the same constraints as TYPE(*), except for the type check
16239	and that only scalars and assumed-size arrays are permitted. */
16240	if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
16241	{
16242	if (!sym->attr.dummy)
16243	{
16244	gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
16245	"a dummy argument", sym->name, &sym->declared_at);
16246	return;
16247	}
16248
16249	if (sym->ts.type != BT_ASSUMED && sym->ts.type != BT_INTEGER
16250	&& sym->ts.type != BT_REAL && sym->ts.type != BT_LOGICAL
16251	&& sym->ts.type != BT_COMPLEX)
16252	{
16253	gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
16254	"of type TYPE(*) or of an numeric intrinsic type",
16255	sym->name, &sym->declared_at);
16256	return;
16257	}
16258
16259	if (sym->attr.allocatable || sym->attr.codimension
16260	|| sym->attr.pointer || sym->attr.value)
16261	{
16262	gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
16263	"have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
16264	"attribute", sym->name, &sym->declared_at);
16265	return;
16266	}
16267
16268	if (sym->attr.intent == INTENT_OUT)
16269	{
16270	gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
16271	"have the INTENT(OUT) attribute",
16272	sym->name, &sym->declared_at);
16273	return;
16274	}
16275	if (sym->attr.dimension && sym->as->type != AS_ASSUMED_SIZE)
16276	{
16277	gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
16278	"either be a scalar or an assumed-size array",
16279	sym->name, &sym->declared_at);
16280	return;
16281	}
16282
16283	/* Set the type to TYPE(*) and add a dimension(*) to ensure
16284	NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
16285	packing. */
16286	sym->ts.type = BT_ASSUMED;
16287	sym->as = gfc_get_array_spec ();
16288	sym->as->type = AS_ASSUMED_SIZE;
16289	sym->as->rank = 1;
16290	sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
16291	}
16292	else if (sym->ts.type == BT_ASSUMED)
16293	{
16294	/* TS 29113, C407a. */
16295	if (!sym->attr.dummy)
16296	{
16297	gfc_error ("Assumed type of variable %s at %L is only permitted "
16298	"for dummy variables", sym->name, &sym->declared_at);
16299	return;
16300	}
16301	if (sym->attr.allocatable || sym->attr.codimension
16302	|| sym->attr.pointer || sym->attr.value)
16303	{
16304	gfc_error ("Assumed-type variable %s at %L may not have the "
16305	"ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
16306	sym->name, &sym->declared_at);
16307	return;
16308	}
16309	if (sym->attr.intent == INTENT_OUT)
16310	{
16311	gfc_error ("Assumed-type variable %s at %L may not have the "
16312	"INTENT(OUT) attribute",
16313	sym->name, &sym->declared_at);
16314	return;
16315	}
16316	if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
16317	{
16318	gfc_error ("Assumed-type variable %s at %L shall not be an "
16319	"explicit-shape array", sym->name, &sym->declared_at);
16320	return;
16321	}
16322	}
16323
16324	/* If the symbol is marked as bind(c), that it is declared at module level
16325	scope and verify its type and kind. Do not do the latter for symbols
16326	that are implicitly typed because that is handled in
16327	gfc_set_default_type. Handle dummy arguments and procedure definitions
16328	separately. Also, anything that is use associated is not handled here
16329	but instead is handled in the module it is declared in. Finally, derived
16330	type definitions are allowed to be BIND(C) since that only implies that
16331	they're interoperable, and they are checked fully for interoperability
16332	when a variable is declared of that type. */
16333	if (sym->attr.is_bind_c && sym->attr.use_assoc == 0
16334	&& sym->attr.dummy == 0 && sym->attr.flavor != FL_PROCEDURE
16335	&& sym->attr.flavor != FL_DERIVED)
16336	{
16337	bool t = true;
16338
16339	/* First, make sure the variable is declared at the
16340	module-level scope (J3/04-007, Section 15.3). */
16341	if (!(sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE)
16342	&& !sym->attr.in_common)
16343	{
16344	gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
16345	"is neither a COMMON block nor declared at the "
16346	"module level scope", sym->name, &(sym->declared_at));
16347	t = false;
16348	}
16349	else if (sym->ts.type == BT_CHARACTER
16350	&& (sym->ts.u.cl == NULL || sym->ts.u.cl->length == NULL
16351	|| !gfc_is_constant_expr (sym->ts.u.cl->length)
16352	|| mpz_cmp_si (sym->ts.u.cl->length->value.integer, 1) != 0))
16353	{
16354	gfc_error ("BIND(C) Variable %qs at %L must have length one",
16355	sym->name, &sym->declared_at);
16356	t = false;
16357	}
16358	else if (sym->common_head != NULL && sym->attr.implicit_type == 0)
16359	{
16360	t = verify_com_block_vars_c_interop (sym->common_head);
16361	}
16362	else if (sym->attr.implicit_type == 0)
16363	{
16364	/* If type() declaration, we need to verify that the components
16365	of the given type are all C interoperable, etc. */
16366	if (sym->ts.type == BT_DERIVED &&
16367	sym->ts.u.derived->attr.is_c_interop != 1)
16368	{
16369	/* Make sure the user marked the derived type as BIND(C). If
16370	not, call the verify routine. This could print an error
16371	for the derived type more than once if multiple variables
16372	of that type are declared. */
16373	if (sym->ts.u.derived->attr.is_bind_c != 1)
16374	verify_bind_c_derived_type (sym->ts.u.derived);
16375	t = false;
16376	}
16377
16378	/* Verify the variable itself as C interoperable if it
16379	is BIND(C). It is not possible for this to succeed if
16380	the verify_bind_c_derived_type failed, so don't have to handle
16381	any error returned by verify_bind_c_derived_type. */
16382	t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
16383	sym->common_block);
16384	}
16385
16386	if (!t)
16387	{
16388	/* clear the is_bind_c flag to prevent reporting errors more than
16389	once if something failed. */
16390	sym->attr.is_bind_c = 0;
16391	return;
16392	}
16393	}
16394
16395	/* If a derived type symbol has reached this point, without its
16396	type being declared, we have an error. Notice that most
16397	conditions that produce undefined derived types have already
16398	been dealt with. However, the likes of:
16399	implicit type(t) (t) ..... call foo (t) will get us here if
16400	the type is not declared in the scope of the implicit
16401	statement. Change the type to BT_UNKNOWN, both because it is so
16402	and to prevent an ICE. */
16403	if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
16404	&& sym->ts.u.derived->components == NULL
16405	&& !sym->ts.u.derived->attr.zero_comp)
16406	{
16407	gfc_error ("The derived type %qs at %L is of type %qs, "
16408	"which has not been defined", sym->name,
16409	&sym->declared_at, sym->ts.u.derived->name);
16410	sym->ts.type = BT_UNKNOWN;
16411	return;
16412	}
16413
16414	/* Make sure that the derived type has been resolved and that the
16415	derived type is visible in the symbol's namespace, if it is a
16416	module function and is not PRIVATE. */
16417	if (sym->ts.type == BT_DERIVED
16418	&& sym->ts.u.derived->attr.use_assoc
16419	&& sym->ns->proc_name
16420	&& sym->ns->proc_name->attr.flavor == FL_MODULE
16421	&& !resolve_fl_derived (sym: sym->ts.u.derived))
16422	return;
16423
16424	/* Unless the derived-type declaration is use associated, Fortran 95
16425	does not allow public entries of private derived types.
16426	See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
16427	161 in 95-006r3. */
16428	if (sym->ts.type == BT_DERIVED
16429	&& sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
16430	&& !sym->ts.u.derived->attr.use_assoc
16431	&& gfc_check_symbol_access (sym)
16432	&& !gfc_check_symbol_access (sym->ts.u.derived)
16433	&& !gfc_notify_std (GFC_STD_F2003, "PUBLIC %s %qs at %L of PRIVATE "
16434	"derived type %qs",
16435	(sym->attr.flavor == FL_PARAMETER)
16436	? "parameter" : "variable",
16437	sym->name, &sym->declared_at,
16438	sym->ts.u.derived->name))
16439	return;
16440
16441	/* F2008, C1302. */
16442	if (sym->ts.type == BT_DERIVED
16443	&& ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
16444	&& sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
16445	|| sym->ts.u.derived->attr.lock_comp)
16446	&& !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
16447	{
16448	gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
16449	"type LOCK_TYPE must be a coarray", sym->name,
16450	&sym->declared_at);
16451	return;
16452	}
16453
16454	/* TS18508, C702/C703. */
16455	if (sym->ts.type == BT_DERIVED
16456	&& ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
16457	&& sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
16458	|| sym->ts.u.derived->attr.event_comp)
16459	&& !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
16460	{
16461	gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
16462	"type EVENT_TYPE must be a coarray", sym->name,
16463	&sym->declared_at);
16464	return;
16465	}
16466
16467	/* An assumed-size array with INTENT(OUT) shall not be of a type for which
16468	default initialization is defined (5.1.2.4.4). */
16469	if (sym->ts.type == BT_DERIVED
16470	&& sym->attr.dummy
16471	&& sym->attr.intent == INTENT_OUT
16472	&& sym->as
16473	&& sym->as->type == AS_ASSUMED_SIZE)
16474	{
16475	for (c = sym->ts.u.derived->components; c; c = c->next)
16476	{
16477	if (c->initializer)
16478	{
16479	gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
16480	"ASSUMED SIZE and so cannot have a default initializer",
16481	sym->name, &sym->declared_at);
16482	return;
16483	}
16484	}
16485	}
16486
16487	/* F2008, C542. */
16488	if (sym->ts.type == BT_DERIVED && sym->attr.dummy
16489	&& sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
16490	{
16491	gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
16492	"INTENT(OUT)", sym->name, &sym->declared_at);
16493	return;
16494	}
16495
16496	/* TS18508. */
16497	if (sym->ts.type == BT_DERIVED && sym->attr.dummy
16498	&& sym->attr.intent == INTENT_OUT && sym->attr.event_comp)
16499	{
16500	gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
16501	"INTENT(OUT)", sym->name, &sym->declared_at);
16502	return;
16503	}
16504
16505	/* F2008, C525. */
16506	if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
16507	|| (sym->ts.type == BT_CLASS && sym->attr.class_ok
16508	&& sym->ts.u.derived && CLASS_DATA (sym)
16509	&& CLASS_DATA (sym)->attr.coarray_comp))
16510	|| class_attr.codimension)
16511	&& (sym->attr.result || sym->result == sym))
16512	{
16513	gfc_error ("Function result %qs at %L shall not be a coarray or have "
16514	"a coarray component", sym->name, &sym->declared_at);
16515	return;
16516	}
16517
16518	/* F2008, C524. */
16519	if (sym->attr.codimension && sym->ts.type == BT_DERIVED
16520	&& sym->ts.u.derived->ts.is_iso_c)
16521	{
16522	gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
16523	"shall not be a coarray", sym->name, &sym->declared_at);
16524	return;
16525	}
16526
16527	/* F2008, C525. */
16528	if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
16529	|| (sym->ts.type == BT_CLASS && sym->attr.class_ok
16530	&& sym->ts.u.derived && CLASS_DATA (sym)
16531	&& CLASS_DATA (sym)->attr.coarray_comp))
16532	&& (class_attr.codimension || class_attr.pointer || class_attr.dimension
16533	|| class_attr.allocatable))
16534	{
16535	gfc_error ("Variable %qs at %L with coarray component shall be a "
16536	"nonpointer, nonallocatable scalar, which is not a coarray",
16537	sym->name, &sym->declared_at);
16538	return;
16539	}
16540
16541	/* F2008, C526. The function-result case was handled above. */
16542	if (class_attr.codimension
16543	&& !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
16544	|| sym->attr.select_type_temporary
16545	|| sym->attr.associate_var
16546	|| (sym->ns->save_all && !sym->attr.automatic)
16547	|| sym->ns->proc_name->attr.flavor == FL_MODULE
16548	|| sym->ns->proc_name->attr.is_main_program
16549	|| sym->attr.function || sym->attr.result || sym->attr.use_assoc))
16550	{
16551	gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
16552	"nor a dummy argument", sym->name, &sym->declared_at);
16553	return;
16554	}
16555	/* F2008, C528. */
16556	else if (class_attr.codimension && !sym->attr.select_type_temporary
16557	&& !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
16558	{
16559	gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
16560	"deferred shape", sym->name, &sym->declared_at);
16561	return;
16562	}
16563	else if (class_attr.codimension && class_attr.allocatable && as
16564	&& (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
16565	{
16566	gfc_error ("Allocatable coarray variable %qs at %L must have "
16567	"deferred shape", sym->name, &sym->declared_at);
16568	return;
16569	}
16570
16571	/* F2008, C541. */
16572	if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
16573	|| (sym->ts.type == BT_CLASS && sym->attr.class_ok
16574	&& sym->ts.u.derived && CLASS_DATA (sym)
16575	&& CLASS_DATA (sym)->attr.coarray_comp))
16576	|| (class_attr.codimension && class_attr.allocatable))
16577	&& sym->attr.dummy && sym->attr.intent == INTENT_OUT)
16578	{
16579	gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
16580	"allocatable coarray or have coarray components",
16581	sym->name, &sym->declared_at);
16582	return;
16583	}
16584
16585	if (class_attr.codimension && sym->attr.dummy
16586	&& sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
16587	{
16588	gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
16589	"procedure %qs", sym->name, &sym->declared_at,
16590	sym->ns->proc_name->name);
16591	return;
16592	}
16593
16594	if (sym->ts.type == BT_LOGICAL
16595	&& ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym)
16596	|| ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name
16597	&& sym->ns->proc_name->attr.is_bind_c)))
16598	{
16599	int i;
16600	for (i = 0; gfc_logical_kinds[i].kind; i++)
16601	if (gfc_logical_kinds[i].kind == sym->ts.kind)
16602	break;
16603	if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy
16604	&& !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument %qs at "
16605	"%L with non-C_Bool kind in BIND(C) procedure "
16606	"%qs", sym->name, &sym->declared_at,
16607	sym->ns->proc_name->name))
16608	return;
16609	else if (!gfc_logical_kinds[i].c_bool
16610	&& !gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable "
16611	"%qs at %L with non-C_Bool kind in "
16612	"BIND(C) procedure %qs", sym->name,
16613	&sym->declared_at,
16614	sym->attr.function ? sym->name
16615	: sym->ns->proc_name->name))
16616	return;
16617	}
16618
16619	switch (sym->attr.flavor)
16620	{
16621	case FL_VARIABLE:
16622	if (!resolve_fl_variable (sym, mp_flag))
16623	return;
16624	break;
16625
16626	case FL_PROCEDURE:
16627	if (sym->formal && !sym->formal_ns)
16628	{
16629	/* Check that none of the arguments are a namelist. */
16630	gfc_formal_arglist *formal = sym->formal;
16631
16632	for (; formal; formal = formal->next)
16633	if (formal->sym && formal->sym->attr.flavor == FL_NAMELIST)
16634	{
16635	gfc_error ("Namelist %qs cannot be an argument to "
16636	"subroutine or function at %L",
16637	formal->sym->name, &sym->declared_at);
16638	return;
16639	}
16640	}
16641
16642	if (!resolve_fl_procedure (sym, mp_flag))
16643	return;
16644	break;
16645
16646	case FL_NAMELIST:
16647	if (!resolve_fl_namelist (sym))
16648	return;
16649	break;
16650
16651	case FL_PARAMETER:
16652	if (!resolve_fl_parameter (sym))
16653	return;
16654	break;
16655
16656	default:
16657	break;
16658	}
16659
16660	/* Resolve array specifier. Check as well some constraints
16661	on COMMON blocks. */
16662
16663	check_constant = sym->attr.in_common && !sym->attr.pointer && !sym->error;
16664
16665	/* Set the formal_arg_flag so that check_conflict will not throw
16666	an error for host associated variables in the specification
16667	expression for an array_valued function. */
16668	if ((sym->attr.function || sym->attr.result) && sym->as)
16669	formal_arg_flag = true;
16670
16671	saved_specification_expr = specification_expr;
16672	specification_expr = true;
16673	gfc_resolve_array_spec (sym->as, check_constant);
16674	specification_expr = saved_specification_expr;
16675
16676	formal_arg_flag = false;
16677
16678	/* Resolve formal namespaces. */
16679	if (sym->formal_ns && sym->formal_ns != gfc_current_ns
16680	&& !sym->attr.contained && !sym->attr.intrinsic)
16681	gfc_resolve (sym->formal_ns);
16682
16683	/* Make sure the formal namespace is present. */
16684	if (sym->formal && !sym->formal_ns)
16685	{
16686	gfc_formal_arglist *formal = sym->formal;
16687	while (formal && !formal->sym)
16688	formal = formal->next;
16689
16690	if (formal)
16691	{
16692	sym->formal_ns = formal->sym->ns;
16693	if (sym->formal_ns && sym->ns != formal->sym->ns)
16694	sym->formal_ns->refs++;
16695	}
16696	}
16697
16698	/* Check threadprivate restrictions. */
16699	if (sym->attr.threadprivate
16700	&& !(sym->attr.save || sym->attr.data || sym->attr.in_common)
16701	&& !(sym->ns->save_all && !sym->attr.automatic)
16702	&& sym->module == NULL
16703	&& (sym->ns->proc_name == NULL
16704	|| (sym->ns->proc_name->attr.flavor != FL_MODULE
16705	&& !sym->ns->proc_name->attr.is_main_program)))
16706	gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
16707
16708	/* Check omp declare target restrictions. */
16709	if (sym->attr.omp_declare_target
16710	&& sym->attr.flavor == FL_VARIABLE
16711	&& !sym->attr.save
16712	&& !(sym->ns->save_all && !sym->attr.automatic)
16713	&& (!sym->attr.in_common
16714	&& sym->module == NULL
16715	&& (sym->ns->proc_name == NULL
16716	|| (sym->ns->proc_name->attr.flavor != FL_MODULE
16717	&& !sym->ns->proc_name->attr.is_main_program))))
16718	gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
16719	sym->name, &sym->declared_at);
16720
16721	/* If we have come this far we can apply default-initializers, as
16722	described in 14.7.5, to those variables that have not already
16723	been assigned one. */
16724	if (sym->ts.type == BT_DERIVED
16725	&& !sym->value
16726	&& !sym->attr.allocatable
16727	&& !sym->attr.alloc_comp)
16728	{
16729	symbol_attribute *a = &sym->attr;
16730
16731	if ((!a->save && !a->dummy && !a->pointer
16732	&& !a->in_common && !a->use_assoc
16733	&& a->referenced
16734	&& !((a->function || a->result)
16735	&& (!a->dimension
16736	|| sym->ts.u.derived->attr.alloc_comp
16737	|| sym->ts.u.derived->attr.pointer_comp))
16738	&& !(a->function && sym != sym->result))
16739	|| (a->dummy && !a->pointer && a->intent == INTENT_OUT
16740	&& sym->ns->proc_name->attr.if_source != IFSRC_IFBODY))
16741	apply_default_init (sym);
16742	else if (a->function && sym->result && a->access != ACCESS_PRIVATE
16743	&& (sym->ts.u.derived->attr.alloc_comp
16744	|| sym->ts.u.derived->attr.pointer_comp))
16745	/* Mark the result symbol to be referenced, when it has allocatable
16746	components. */
16747	sym->result->attr.referenced = 1;
16748	}
16749
16750	if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
16751	&& sym->attr.dummy && sym->attr.intent == INTENT_OUT
16752	&& sym->ns->proc_name->attr.if_source != IFSRC_IFBODY
16753	&& !CLASS_DATA (sym)->attr.class_pointer
16754	&& !CLASS_DATA (sym)->attr.allocatable)
16755	apply_default_init (sym);
16756
16757	/* If this symbol has a type-spec, check it. */
16758	if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
16759	|| (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
16760	if (!resolve_typespec_used (ts: &sym->ts, where: &sym->declared_at, name: sym->name))
16761	return;
16762
16763	if (sym->param_list)
16764	resolve_pdt (sym);
16765
16766	if (!sym->attr.referenced
16767	&& (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
16768	{
16769	gfc_expr *final_expr = gfc_lval_expr_from_sym (sym);
16770	if (gfc_is_finalizable (final_expr->ts.u.derived, NULL))
16771	gfc_set_sym_referenced (sym);
16772	gfc_free_expr (final_expr);
16773	}
16774	}
16775
16776
16777	/************* Resolve DATA statements *************/
16778
16779	static struct
16780	{
16781	gfc_data_value *vnode;
16782	mpz_t left;
16783	}
16784	values;
16785
16786
16787	/* Advance the values structure to point to the next value in the data list. */
16788
16789	static bool
16790	next_data_value (void)
16791	{
16792	while (mpz_cmp_ui (values.left, 0) == 0)
16793	{
16794
16795	if (values.vnode->next == NULL)
16796	return false;
16797
16798	values.vnode = values.vnode->next;
16799	mpz_set (values.left, values.vnode->repeat);
16800	}
16801
16802	return true;
16803	}
16804
16805
16806	static bool
16807	check_data_variable (gfc_data_variable *var, locus *where)
16808	{
16809	gfc_expr *e;
16810	mpz_t size;
16811	mpz_t offset;
16812	bool t;
16813	ar_type mark = AR_UNKNOWN;
16814	int i;
16815	mpz_t section_index[GFC_MAX_DIMENSIONS];
16816	int vector_offset[GFC_MAX_DIMENSIONS];
16817	gfc_ref *ref;
16818	gfc_array_ref *ar;
16819	gfc_symbol *sym;
16820	int has_pointer;
16821
16822	if (!gfc_resolve_expr (e: var->expr))
16823	return false;
16824
16825	ar = NULL;
16826	e = var->expr;
16827
16828	if (e->expr_type == EXPR_FUNCTION && e->value.function.isym
16829	&& e->value.function.isym->id == GFC_ISYM_CAF_GET)
16830	e = e->value.function.actual->expr;
16831
16832	if (e->expr_type != EXPR_VARIABLE)
16833	{
16834	gfc_error ("Expecting definable entity near %L", where);
16835	return false;
16836	}
16837
16838	sym = e->symtree->n.sym;
16839
16840	if (sym->ns->is_block_data && !sym->attr.in_common)
16841	{
16842	gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
16843	sym->name, &sym->declared_at);
16844	return false;
16845	}
16846
16847	if (e->ref == NULL && sym->as)
16848	{
16849	gfc_error ("DATA array %qs at %L must be specified in a previous"
16850	" declaration", sym->name, where);
16851	return false;
16852	}
16853
16854	if (gfc_is_coindexed (e))
16855	{
16856	gfc_error ("DATA element %qs at %L cannot have a coindex", sym->name,
16857	where);
16858	return false;
16859	}
16860
16861	has_pointer = sym->attr.pointer;
16862
16863	for (ref = e->ref; ref; ref = ref->next)
16864	{
16865	if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
16866	has_pointer = 1;
16867
16868	if (has_pointer)
16869	{
16870	if (ref->type == REF_ARRAY && ref->u.ar.type != AR_FULL)
16871	{
16872	gfc_error ("DATA element %qs at %L is a pointer and so must "
16873	"be a full array", sym->name, where);
16874	return false;
16875	}
16876
16877	if (values.vnode->expr->expr_type == EXPR_CONSTANT)
16878	{
16879	gfc_error ("DATA object near %L has the pointer attribute "
16880	"and the corresponding DATA value is not a valid "
16881	"initial-data-target", where);
16882	return false;
16883	}
16884	}
16885
16886	if (ref->type == REF_COMPONENT && ref->u.c.component->attr.allocatable)
16887	{
16888	gfc_error ("DATA element %qs at %L cannot have the ALLOCATABLE "
16889	"attribute", ref->u.c.component->name, &e->where);
16890	return false;
16891	}
16892
16893	/* Reject substrings of strings of non-constant length. */
16894	if (ref->type == REF_SUBSTRING
16895	&& ref->u.ss.length
16896	&& ref->u.ss.length->length
16897	&& !gfc_is_constant_expr (ref->u.ss.length->length))
16898	goto bad_charlen;
16899	}
16900
16901	/* Reject strings with deferred length or non-constant length. */
16902	if (e->ts.type == BT_CHARACTER
16903	&& (e->ts.deferred
16904	|| (e->ts.u.cl->length
16905	&& !gfc_is_constant_expr (e->ts.u.cl->length))))
16906	goto bad_charlen;
16907
16908	mpz_init_set_si (offset, 0);
16909
16910	if (e->rank == 0 || has_pointer)
16911	{
16912	mpz_init_set_ui (size, 1);
16913	ref = NULL;
16914	}
16915	else
16916	{
16917	ref = e->ref;
16918
16919	/* Find the array section reference. */
16920	for (ref = e->ref; ref; ref = ref->next)
16921	{
16922	if (ref->type != REF_ARRAY)
16923	continue;
16924	if (ref->u.ar.type == AR_ELEMENT)
16925	continue;
16926	break;
16927	}
16928	gcc_assert (ref);
16929
16930	/* Set marks according to the reference pattern. */
16931	switch (ref->u.ar.type)
16932	{
16933	case AR_FULL:
16934	mark = AR_FULL;
16935	break;
16936
16937	case AR_SECTION:
16938	ar = &ref->u.ar;
16939	/* Get the start position of array section. */
16940	gfc_get_section_index (ar, section_index, &offset, vector_offset);
16941	mark = AR_SECTION;
16942	break;
16943
16944	default:
16945	gcc_unreachable ();
16946	}
16947
16948	if (!gfc_array_size (e, &size))
16949	{
16950	gfc_error ("Nonconstant array section at %L in DATA statement",
16951	where);
16952	mpz_clear (offset);
16953	return false;
16954	}
16955	}
16956
16957	t = true;
16958
16959	while (mpz_cmp_ui (size, 0) > 0)
16960	{
16961	if (!next_data_value ())
16962	{
16963	gfc_error ("DATA statement at %L has more variables than values",
16964	where);
16965	t = false;
16966	break;
16967	}
16968
16969	t = gfc_check_assign (var->expr, values.vnode->expr, 0);
16970	if (!t)
16971	break;
16972
16973	/* If we have more than one element left in the repeat count,
16974	and we have more than one element left in the target variable,
16975	then create a range assignment. */
16976	/* FIXME: Only done for full arrays for now, since array sections
16977	seem tricky. */
16978	if (mark == AR_FULL && ref && ref->next == NULL
16979	&& mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
16980	{
16981	mpz_t range;
16982
16983	if (mpz_cmp (size, values.left) >= 0)
16984	{
16985	mpz_init_set (range, values.left);
16986	mpz_sub (size, size, values.left);
16987	mpz_set_ui (values.left, 0);
16988	}
16989	else
16990	{
16991	mpz_init_set (range, size);
16992	mpz_sub (values.left, values.left, size);
16993	mpz_set_ui (size, 0);
16994	}
16995
16996	t = gfc_assign_data_value (var->expr, values.vnode->expr,
16997	offset, &range);
16998
16999	mpz_add (offset, offset, range);
17000	mpz_clear (range);
17001
17002	if (!t)
17003	break;
17004	}
17005
17006	/* Assign initial value to symbol. */
17007	else
17008	{
17009	mpz_sub_ui (values.left, values.left, 1);
17010	mpz_sub_ui (size, size, 1);
17011
17012	t = gfc_assign_data_value (var->expr, values.vnode->expr,
17013	offset, NULL);
17014	if (!t)
17015	break;
17016
17017	if (mark == AR_FULL)
17018	mpz_add_ui (offset, offset, 1);
17019
17020	/* Modify the array section indexes and recalculate the offset
17021	for next element. */
17022	else if (mark == AR_SECTION)
17023	gfc_advance_section (section_index, ar, &offset, vector_offset);
17024	}
17025	}
17026
17027	if (mark == AR_SECTION)
17028	{
17029	for (i = 0; i < ar->dimen; i++)
17030	mpz_clear (section_index[i]);
17031	}
17032
17033	mpz_clear (size);
17034	mpz_clear (offset);
17035
17036	return t;
17037
17038	bad_charlen:
17039	gfc_error ("Non-constant character length at %L in DATA statement",
17040	&e->where);
17041	return false;
17042	}
17043
17044
17045	static bool traverse_data_var (gfc_data_variable *, locus *);
17046
17047	/* Iterate over a list of elements in a DATA statement. */
17048
17049	static bool
17050	traverse_data_list (gfc_data_variable *var, locus *where)
17051	{
17052	mpz_t trip;
17053	iterator_stack frame;
17054	gfc_expr *e, *start, *end, *step;
17055	bool retval = true;
17056
17057	mpz_init (frame.value);
17058	mpz_init (trip);
17059
17060	start = gfc_copy_expr (var->iter.start);
17061	end = gfc_copy_expr (var->iter.end);
17062	step = gfc_copy_expr (var->iter.step);
17063
17064	if (!gfc_simplify_expr (start, 1)
17065	|| start->expr_type != EXPR_CONSTANT)
17066	{
17067	gfc_error ("start of implied-do loop at %L could not be "
17068	"simplified to a constant value", &start->where);
17069	retval = false;
17070	goto cleanup;
17071	}
17072	if (!gfc_simplify_expr (end, 1)
17073	|| end->expr_type != EXPR_CONSTANT)
17074	{
17075	gfc_error ("end of implied-do loop at %L could not be "
17076	"simplified to a constant value", &end->where);
17077	retval = false;
17078	goto cleanup;
17079	}
17080	if (!gfc_simplify_expr (step, 1)
17081	|| step->expr_type != EXPR_CONSTANT)
17082	{
17083	gfc_error ("step of implied-do loop at %L could not be "
17084	"simplified to a constant value", &step->where);
17085	retval = false;
17086	goto cleanup;
17087	}
17088	if (mpz_cmp_si (step->value.integer, 0) == 0)
17089	{
17090	gfc_error ("step of implied-do loop at %L shall not be zero",
17091	&step->where);
17092	retval = false;
17093	goto cleanup;
17094	}
17095
17096	mpz_set (trip, end->value.integer);
17097	mpz_sub (trip, trip, start->value.integer);
17098	mpz_add (trip, trip, step->value.integer);
17099
17100	mpz_div (trip, trip, step->value.integer);
17101
17102	mpz_set (frame.value, start->value.integer);
17103
17104	frame.prev = iter_stack;
17105	frame.variable = var->iter.var->symtree;
17106	iter_stack = &frame;
17107
17108	while (mpz_cmp_ui (trip, 0) > 0)
17109	{
17110	if (!traverse_data_var (var->list, where))
17111	{
17112	retval = false;
17113	goto cleanup;
17114	}
17115
17116	e = gfc_copy_expr (var->expr);
17117	if (!gfc_simplify_expr (e, 1))
17118	{
17119	gfc_free_expr (e);
17120	retval = false;
17121	goto cleanup;
17122	}
17123
17124	mpz_add (frame.value, frame.value, step->value.integer);
17125
17126	mpz_sub_ui (trip, trip, 1);
17127	}
17128
17129	cleanup:
17130	mpz_clear (frame.value);
17131	mpz_clear (trip);
17132
17133	gfc_free_expr (start);
17134	gfc_free_expr (end);
17135	gfc_free_expr (step);
17136
17137	iter_stack = frame.prev;
17138	return retval;
17139	}
17140
17141
17142	/* Type resolve variables in the variable list of a DATA statement. */
17143
17144	static bool
17145	traverse_data_var (gfc_data_variable *var, locus *where)
17146	{
17147	bool t;
17148
17149	for (; var; var = var->next)
17150	{
17151	if (var->expr == NULL)
17152	t = traverse_data_list (var, where);
17153	else
17154	t = check_data_variable (var, where);
17155
17156	if (!t)
17157	return false;
17158	}
17159
17160	return true;
17161	}
17162
17163
17164	/* Resolve the expressions and iterators associated with a data statement.
17165	This is separate from the assignment checking because data lists should
17166	only be resolved once. */
17167
17168	static bool
17169	resolve_data_variables (gfc_data_variable *d)
17170	{
17171	for (; d; d = d->next)
17172	{
17173	if (d->list == NULL)
17174	{
17175	if (!gfc_resolve_expr (e: d->expr))
17176	return false;
17177	}
17178	else
17179	{
17180	if (!gfc_resolve_iterator (iter: &d->iter, real_ok: false, own_scope: true))
17181	return false;
17182
17183	if (!resolve_data_variables (d: d->list))
17184	return false;
17185	}
17186	}
17187
17188	return true;
17189	}
17190
17191
17192	/* Resolve a single DATA statement. We implement this by storing a pointer to
17193	the value list into static variables, and then recursively traversing the
17194	variables list, expanding iterators and such. */
17195
17196	static void
17197	resolve_data (gfc_data *d)
17198	{
17199
17200	if (!resolve_data_variables (d: d->var))
17201	return;
17202
17203	values.vnode = d->value;
17204	if (d->value == NULL)
17205	mpz_set_ui (values.left, 0);
17206	else
17207	mpz_set (values.left, d->value->repeat);
17208
17209	if (!traverse_data_var (var: d->var, where: &d->where))
17210	return;
17211
17212	/* At this point, we better not have any values left. */
17213
17214	if (next_data_value ())
17215	gfc_error ("DATA statement at %L has more values than variables",
17216	&d->where);
17217	}
17218
17219
17220	/* 12.6 Constraint: In a pure subprogram any variable which is in common or
17221	accessed by host or use association, is a dummy argument to a pure function,
17222	is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
17223	is storage associated with any such variable, shall not be used in the
17224	following contexts: (clients of this function). */
17225
17226	/* Determines if a variable is not 'pure', i.e., not assignable within a pure
17227	procedure. Returns zero if assignment is OK, nonzero if there is a
17228	problem. */
17229	bool
17230	gfc_impure_variable (gfc_symbol *sym)
17231	{
17232	gfc_symbol *proc;
17233	gfc_namespace *ns;
17234
17235	if (sym->attr.use_assoc || sym->attr.in_common)
17236	return 1;
17237
17238	/* Check if the symbol's ns is inside the pure procedure. */
17239	for (ns = gfc_current_ns; ns; ns = ns->parent)
17240	{
17241	if (ns == sym->ns)
17242	break;
17243	if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
17244	return 1;
17245	}
17246
17247	proc = sym->ns->proc_name;
17248	if (sym->attr.dummy
17249	&& !sym->attr.value
17250	&& ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
17251	|| proc->attr.function))
17252	return 1;
17253
17254	/* TODO: Sort out what can be storage associated, if anything, and include
17255	it here. In principle equivalences should be scanned but it does not
17256	seem to be possible to storage associate an impure variable this way. */
17257	return 0;
17258	}
17259
17260
17261	/* Test whether a symbol is pure or not. For a NULL pointer, checks if the
17262	current namespace is inside a pure procedure. */
17263
17264	bool
17265	gfc_pure (gfc_symbol *sym)
17266	{
17267	symbol_attribute attr;
17268	gfc_namespace *ns;
17269
17270	if (sym == NULL)
17271	{
17272	/* Check if the current namespace or one of its parents
17273	belongs to a pure procedure. */
17274	for (ns = gfc_current_ns; ns; ns = ns->parent)
17275	{
17276	sym = ns->proc_name;
17277	if (sym == NULL)
17278	return 0;
17279	attr = sym->attr;
17280	if (attr.flavor == FL_PROCEDURE && attr.pure)
17281	return 1;
17282	}
17283	return 0;
17284	}
17285
17286	attr = sym->attr;
17287
17288	return attr.flavor == FL_PROCEDURE && attr.pure;
17289	}
17290
17291
17292	/* Test whether a symbol is implicitly pure or not. For a NULL pointer,
17293	checks if the current namespace is implicitly pure. Note that this
17294	function returns false for a PURE procedure. */
17295
17296	bool
17297	gfc_implicit_pure (gfc_symbol *sym)
17298	{
17299	gfc_namespace *ns;
17300
17301	if (sym == NULL)
17302	{
17303	/* Check if the current procedure is implicit_pure. Walk up
17304	the procedure list until we find a procedure. */
17305	for (ns = gfc_current_ns; ns; ns = ns->parent)
17306	{
17307	sym = ns->proc_name;
17308	if (sym == NULL)
17309	return 0;
17310
17311	if (sym->attr.flavor == FL_PROCEDURE)
17312	break;
17313	}
17314	}
17315
17316	return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
17317	&& !sym->attr.pure;
17318	}
17319
17320
17321	void
17322	gfc_unset_implicit_pure (gfc_symbol *sym)
17323	{
17324	gfc_namespace *ns;
17325
17326	if (sym == NULL)
17327	{
17328	/* Check if the current procedure is implicit_pure. Walk up
17329	the procedure list until we find a procedure. */
17330	for (ns = gfc_current_ns; ns; ns = ns->parent)
17331	{
17332	sym = ns->proc_name;
17333	if (sym == NULL)
17334	return;
17335
17336	if (sym->attr.flavor == FL_PROCEDURE)
17337	break;
17338	}
17339	}
17340
17341	if (sym->attr.flavor == FL_PROCEDURE)
17342	sym->attr.implicit_pure = 0;
17343	else
17344	sym->attr.pure = 0;
17345	}
17346
17347
17348	/* Test whether the current procedure is elemental or not. */
17349
17350	bool
17351	gfc_elemental (gfc_symbol *sym)
17352	{
17353	symbol_attribute attr;
17354
17355	if (sym == NULL)
17356	sym = gfc_current_ns->proc_name;
17357	if (sym == NULL)
17358	return 0;
17359	attr = sym->attr;
17360
17361	return attr.flavor == FL_PROCEDURE && attr.elemental;
17362	}
17363
17364
17365	/* Warn about unused labels. */
17366
17367	static void
17368	warn_unused_fortran_label (gfc_st_label *label)
17369	{
17370	if (label == NULL)
17371	return;
17372
17373	warn_unused_fortran_label (label: label->left);
17374
17375	if (label->defined == ST_LABEL_UNKNOWN)
17376	return;
17377
17378	switch (label->referenced)
17379	{
17380	case ST_LABEL_UNKNOWN:
17381	gfc_warning (opt: OPT_Wunused_label, "Label %d at %L defined but not used",
17382	label->value, &label->where);
17383	break;
17384
17385	case ST_LABEL_BAD_TARGET:
17386	gfc_warning (opt: OPT_Wunused_label,
17387	"Label %d at %L defined but cannot be used",
17388	label->value, &label->where);
17389	break;
17390
17391	default:
17392	break;
17393	}
17394
17395	warn_unused_fortran_label (label: label->right);
17396	}
17397
17398
17399	/* Returns the sequence type of a symbol or sequence. */
17400
17401	static seq_type
17402	sequence_type (gfc_typespec ts)
17403	{
17404	seq_type result;
17405	gfc_component *c;
17406
17407	switch (ts.type)
17408	{
17409	case BT_DERIVED:
17410
17411	if (ts.u.derived->components == NULL)
17412	return SEQ_NONDEFAULT;
17413
17414	result = sequence_type (ts: ts.u.derived->components->ts);
17415	for (c = ts.u.derived->components->next; c; c = c->next)
17416	if (sequence_type (ts: c->ts) != result)
17417	return SEQ_MIXED;
17418
17419	return result;
17420
17421	case BT_CHARACTER:
17422	if (ts.kind != gfc_default_character_kind)
17423	return SEQ_NONDEFAULT;
17424
17425	return SEQ_CHARACTER;
17426
17427	case BT_INTEGER:
17428	if (ts.kind != gfc_default_integer_kind)
17429	return SEQ_NONDEFAULT;
17430
17431	return SEQ_NUMERIC;
17432
17433	case BT_REAL:
17434	if (!(ts.kind == gfc_default_real_kind
17435	|| ts.kind == gfc_default_double_kind))
17436	return SEQ_NONDEFAULT;
17437
17438	return SEQ_NUMERIC;
17439
17440	case BT_COMPLEX:
17441	if (ts.kind != gfc_default_complex_kind)
17442	return SEQ_NONDEFAULT;
17443
17444	return SEQ_NUMERIC;
17445
17446	case BT_LOGICAL:
17447	if (ts.kind != gfc_default_logical_kind)
17448	return SEQ_NONDEFAULT;
17449
17450	return SEQ_NUMERIC;
17451
17452	default:
17453	return SEQ_NONDEFAULT;
17454	}
17455	}
17456
17457
17458	/* Resolve derived type EQUIVALENCE object. */
17459
17460	static bool
17461	resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
17462	{
17463	gfc_component *c = derived->components;
17464
17465	if (!derived)
17466	return true;
17467
17468	/* Shall not be an object of nonsequence derived type. */
17469	if (!derived->attr.sequence)
17470	{
17471	gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
17472	"attribute to be an EQUIVALENCE object", sym->name,
17473	&e->where);
17474	return false;
17475	}
17476
17477	/* Shall not have allocatable components. */
17478	if (derived->attr.alloc_comp)
17479	{
17480	gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
17481	"components to be an EQUIVALENCE object",sym->name,
17482	&e->where);
17483	return false;
17484	}
17485
17486	if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
17487	{
17488	gfc_error ("Derived type variable %qs at %L with default "
17489	"initialization cannot be in EQUIVALENCE with a variable "
17490	"in COMMON", sym->name, &e->where);
17491	return false;
17492	}
17493
17494	for (; c ; c = c->next)
17495	{
17496	if (gfc_bt_struct (c->ts.type)
17497	&& (!resolve_equivalence_derived(derived: c->ts.u.derived, sym, e)))
17498	return false;
17499
17500	/* Shall not be an object of sequence derived type containing a pointer
17501	in the structure. */
17502	if (c->attr.pointer)
17503	{
17504	gfc_error ("Derived type variable %qs at %L with pointer "
17505	"component(s) cannot be an EQUIVALENCE object",
17506	sym->name, &e->where);
17507	return false;
17508	}
17509	}
17510	return true;
17511	}
17512
17513
17514	/* Resolve equivalence object.
17515	An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
17516	an allocatable array, an object of nonsequence derived type, an object of
17517	sequence derived type containing a pointer at any level of component
17518	selection, an automatic object, a function name, an entry name, a result
17519	name, a named constant, a structure component, or a subobject of any of
17520	the preceding objects. A substring shall not have length zero. A
17521	derived type shall not have components with default initialization nor
17522	shall two objects of an equivalence group be initialized.
17523	Either all or none of the objects shall have an protected attribute.
17524	The simple constraints are done in symbol.cc(check_conflict) and the rest
17525	are implemented here. */
17526
17527	static void
17528	resolve_equivalence (gfc_equiv *eq)
17529	{
17530	gfc_symbol *sym;
17531	gfc_symbol *first_sym;
17532	gfc_expr *e;
17533	gfc_ref *r;
17534	locus *last_where = NULL;
17535	seq_type eq_type, last_eq_type;
17536	gfc_typespec *last_ts;
17537	int object, cnt_protected;
17538	const char *msg;
17539
17540	last_ts = &eq->expr->symtree->n.sym->ts;
17541
17542	first_sym = eq->expr->symtree->n.sym;
17543
17544	cnt_protected = 0;
17545
17546	for (object = 1; eq; eq = eq->eq, object++)
17547	{
17548	e = eq->expr;
17549
17550	e->ts = e->symtree->n.sym->ts;
17551	/* match_varspec might not know yet if it is seeing
17552	array reference or substring reference, as it doesn't
17553	know the types. */
17554	if (e->ref && e->ref->type == REF_ARRAY)
17555	{
17556	gfc_ref *ref = e->ref;
17557	sym = e->symtree->n.sym;
17558
17559	if (sym->attr.dimension)
17560	{
17561	ref->u.ar.as = sym->as;
17562	ref = ref->next;
17563	}
17564
17565	/* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
17566	if (e->ts.type == BT_CHARACTER
17567	&& ref
17568	&& ref->type == REF_ARRAY
17569	&& ref->u.ar.dimen == 1
17570	&& ref->u.ar.dimen_type[0] == DIMEN_RANGE
17571	&& ref->u.ar.stride[0] == NULL)
17572	{
17573	gfc_expr *start = ref->u.ar.start[0];
17574	gfc_expr *end = ref->u.ar.end[0];
17575	void *mem = NULL;
17576
17577	/* Optimize away the (:) reference. */
17578	if (start == NULL && end == NULL)
17579	{
17580	if (e->ref == ref)
17581	e->ref = ref->next;
17582	else
17583	e->ref->next = ref->next;
17584	mem = ref;
17585	}
17586	else
17587	{
17588	ref->type = REF_SUBSTRING;
17589	if (start == NULL)
17590	start = gfc_get_int_expr (gfc_charlen_int_kind,
17591	NULL, 1);
17592	ref->u.ss.start = start;
17593	if (end == NULL && e->ts.u.cl)
17594	end = gfc_copy_expr (e->ts.u.cl->length);
17595	ref->u.ss.end = end;
17596	ref->u.ss.length = e->ts.u.cl;
17597	e->ts.u.cl = NULL;
17598	}
17599	ref = ref->next;
17600	free (ptr: mem);
17601	}
17602
17603	/* Any further ref is an error. */
17604	if (ref)
17605	{
17606	gcc_assert (ref->type == REF_ARRAY);
17607	gfc_error ("Syntax error in EQUIVALENCE statement at %L",
17608	&ref->u.ar.where);
17609	continue;
17610	}
17611	}
17612
17613	if (!gfc_resolve_expr (e))
17614	continue;
17615
17616	sym = e->symtree->n.sym;
17617
17618	if (sym->attr.is_protected)
17619	cnt_protected++;
17620	if (cnt_protected > 0 && cnt_protected != object)
17621	{
17622	gfc_error ("Either all or none of the objects in the "
17623	"EQUIVALENCE set at %L shall have the "
17624	"PROTECTED attribute",
17625	&e->where);
17626	break;
17627	}
17628
17629	/* Shall not equivalence common block variables in a PURE procedure. */
17630	if (sym->ns->proc_name
17631	&& sym->ns->proc_name->attr.pure
17632	&& sym->attr.in_common)
17633	{
17634	/* Need to check for symbols that may have entered the pure
17635	procedure via a USE statement. */
17636	bool saw_sym = false;
17637	if (sym->ns->use_stmts)
17638	{
17639	gfc_use_rename *r;
17640	for (r = sym->ns->use_stmts->rename; r; r = r->next)
17641	if (strcmp(s1: r->use_name, s2: sym->name) == 0) saw_sym = true;
17642	}
17643	else
17644	saw_sym = true;
17645
17646	if (saw_sym)
17647	gfc_error ("COMMON block member %qs at %L cannot be an "
17648	"EQUIVALENCE object in the pure procedure %qs",
17649	sym->name, &e->where, sym->ns->proc_name->name);
17650	break;
17651	}
17652
17653	/* Shall not be a named constant. */
17654	if (e->expr_type == EXPR_CONSTANT)
17655	{
17656	gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
17657	"object", sym->name, &e->where);
17658	continue;
17659	}
17660
17661	if (e->ts.type == BT_DERIVED
17662	&& !resolve_equivalence_derived (derived: e->ts.u.derived, sym, e))
17663	continue;
17664
17665	/* Check that the types correspond correctly:
17666	Note 5.28:
17667	A numeric sequence structure may be equivalenced to another sequence
17668	structure, an object of default integer type, default real type, double
17669	precision real type, default logical type such that components of the
17670	structure ultimately only become associated to objects of the same
17671	kind. A character sequence structure may be equivalenced to an object
17672	of default character kind or another character sequence structure.
17673	Other objects may be equivalenced only to objects of the same type and
17674	kind parameters. */
17675
17676	/* Identical types are unconditionally OK. */
17677	if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
17678	goto identical_types;
17679
17680	last_eq_type = sequence_type (ts: *last_ts);
17681	eq_type = sequence_type (ts: sym->ts);
17682
17683	/* Since the pair of objects is not of the same type, mixed or
17684	non-default sequences can be rejected. */
17685
17686	msg = "Sequence %s with mixed components in EQUIVALENCE "
17687	"statement at %L with different type objects";
17688	if ((object ==2
17689	&& last_eq_type == SEQ_MIXED
17690	&& last_where
17691	&& !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
17692	|| (eq_type == SEQ_MIXED
17693	&& !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
17694	continue;
17695
17696	msg = "Non-default type object or sequence %s in EQUIVALENCE "
17697	"statement at %L with objects of different type";
17698	if ((object ==2
17699	&& last_eq_type == SEQ_NONDEFAULT
17700	&& last_where
17701	&& !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
17702	|| (eq_type == SEQ_NONDEFAULT
17703	&& !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
17704	continue;
17705
17706	msg ="Non-CHARACTER object %qs in default CHARACTER "
17707	"EQUIVALENCE statement at %L";
17708	if (last_eq_type == SEQ_CHARACTER
17709	&& eq_type != SEQ_CHARACTER
17710	&& !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
17711	continue;
17712
17713	msg ="Non-NUMERIC object %qs in default NUMERIC "
17714	"EQUIVALENCE statement at %L";
17715	if (last_eq_type == SEQ_NUMERIC
17716	&& eq_type != SEQ_NUMERIC
17717	&& !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
17718	continue;
17719
17720	identical_types:
17721
17722	last_ts =&sym->ts;
17723	last_where = &e->where;
17724
17725	if (!e->ref)
17726	continue;
17727
17728	/* Shall not be an automatic array. */
17729	if (e->ref->type == REF_ARRAY && is_non_constant_shape_array (sym))
17730	{
17731	gfc_error ("Array %qs at %L with non-constant bounds cannot be "
17732	"an EQUIVALENCE object", sym->name, &e->where);
17733	continue;
17734	}
17735
17736	r = e->ref;
17737	while (r)
17738	{
17739	/* Shall not be a structure component. */
17740	if (r->type == REF_COMPONENT)
17741	{
17742	gfc_error ("Structure component %qs at %L cannot be an "
17743	"EQUIVALENCE object",
17744	r->u.c.component->name, &e->where);
17745	break;
17746	}
17747
17748	/* A substring shall not have length zero. */
17749	if (r->type == REF_SUBSTRING)
17750	{
17751	if (compare_bound (a: r->u.ss.start, b: r->u.ss.end) == CMP_GT)
17752	{
17753	gfc_error ("Substring at %L has length zero",
17754	&r->u.ss.start->where);
17755	break;
17756	}
17757	}
17758	r = r->next;
17759	}
17760	}
17761	}
17762
17763
17764	/* Function called by resolve_fntype to flag other symbols used in the
17765	length type parameter specification of function results. */
17766
17767	static bool
17768	flag_fn_result_spec (gfc_expr *expr,
17769	gfc_symbol *sym,
17770	int *f ATTRIBUTE_UNUSED)
17771	{
17772	gfc_namespace *ns;
17773	gfc_symbol *s;
17774
17775	if (expr->expr_type == EXPR_VARIABLE)
17776	{
17777	s = expr->symtree->n.sym;
17778	for (ns = s->ns; ns; ns = ns->parent)
17779	if (!ns->parent)
17780	break;
17781
17782	if (sym == s)
17783	{
17784	gfc_error ("Self reference in character length expression "
17785	"for %qs at %L", sym->name, &expr->where);
17786	return true;
17787	}
17788
17789	if (!s->fn_result_spec
17790	&& s->attr.flavor == FL_PARAMETER)
17791	{
17792	/* Function contained in a module.... */
17793	if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE)
17794	{
17795	gfc_symtree *st;
17796	s->fn_result_spec = 1;
17797	/* Make sure that this symbol is translated as a module
17798	variable. */
17799	st = gfc_get_unique_symtree (ns);
17800	st->n.sym = s;
17801	s->refs++;
17802	}
17803	/* ... which is use associated and called. */
17804	else if (s->attr.use_assoc || s->attr.used_in_submodule
17805	||
17806	/* External function matched with an interface. */
17807	(s->ns->proc_name
17808	&& ((s->ns == ns
17809	&& s->ns->proc_name->attr.if_source == IFSRC_DECL)
17810	|| s->ns->proc_name->attr.if_source == IFSRC_IFBODY)
17811	&& s->ns->proc_name->attr.function))
17812	s->fn_result_spec = 1;
17813	}
17814	}
17815	return false;
17816	}
17817
17818
17819	/* Resolve function and ENTRY types, issue diagnostics if needed. */
17820
17821	static void
17822	resolve_fntype (gfc_namespace *ns)
17823	{
17824	gfc_entry_list *el;
17825	gfc_symbol *sym;
17826
17827	if (ns->proc_name == NULL || !ns->proc_name->attr.function)
17828	return;
17829
17830	/* If there are any entries, ns->proc_name is the entry master
17831	synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
17832	if (ns->entries)
17833	sym = ns->entries->sym;
17834	else
17835	sym = ns->proc_name;
17836	if (sym->result == sym
17837	&& sym->ts.type == BT_UNKNOWN
17838	&& !gfc_set_default_type (sym, 0, NULL)
17839	&& !sym->attr.untyped)
17840	{
17841	gfc_error ("Function %qs at %L has no IMPLICIT type",
17842	sym->name, &sym->declared_at);
17843	sym->attr.untyped = 1;
17844	}
17845
17846	if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
17847	&& !sym->attr.contained
17848	&& !gfc_check_symbol_access (sym->ts.u.derived)
17849	&& gfc_check_symbol_access (sym))
17850	{
17851	gfc_notify_std (GFC_STD_F2003, "PUBLIC function %qs at "
17852	"%L of PRIVATE type %qs", sym->name,
17853	&sym->declared_at, sym->ts.u.derived->name);
17854	}
17855
17856	if (ns->entries)
17857	for (el = ns->entries->next; el; el = el->next)
17858	{
17859	if (el->sym->result == el->sym
17860	&& el->sym->ts.type == BT_UNKNOWN
17861	&& !gfc_set_default_type (el->sym, 0, NULL)
17862	&& !el->sym->attr.untyped)
17863	{
17864	gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
17865	el->sym->name, &el->sym->declared_at);
17866	el->sym->attr.untyped = 1;
17867	}
17868	}
17869
17870	if (sym->ts.type == BT_CHARACTER
17871	&& sym->ts.u.cl->length
17872	&& sym->ts.u.cl->length->ts.type == BT_INTEGER)
17873	gfc_traverse_expr (sym->ts.u.cl->length, sym, flag_fn_result_spec, 0);
17874	}
17875
17876
17877	/* 12.3.2.1.1 Defined operators. */
17878
17879	static bool
17880	check_uop_procedure (gfc_symbol *sym, locus where)
17881	{
17882	gfc_formal_arglist *formal;
17883
17884	if (!sym->attr.function)
17885	{
17886	gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
17887	sym->name, &where);
17888	return false;
17889	}
17890
17891	if (sym->ts.type == BT_CHARACTER
17892	&& !((sym->ts.u.cl && sym->ts.u.cl->length) || sym->ts.deferred)
17893	&& !(sym->result && ((sym->result->ts.u.cl
17894	&& sym->result->ts.u.cl->length) || sym->result->ts.deferred)))
17895	{
17896	gfc_error ("User operator procedure %qs at %L cannot be assumed "
17897	"character length", sym->name, &where);
17898	return false;
17899	}
17900
17901	formal = gfc_sym_get_dummy_args (sym);
17902	if (!formal || !formal->sym)
17903	{
17904	gfc_error ("User operator procedure %qs at %L must have at least "
17905	"one argument", sym->name, &where);
17906	return false;
17907	}
17908
17909	if (formal->sym->attr.intent != INTENT_IN)
17910	{
17911	gfc_error ("First argument of operator interface at %L must be "
17912	"INTENT(IN)", &where);
17913	return false;
17914	}
17915
17916	if (formal->sym->attr.optional)
17917	{
17918	gfc_error ("First argument of operator interface at %L cannot be "
17919	"optional", &where);
17920	return false;
17921	}
17922
17923	formal = formal->next;
17924	if (!formal || !formal->sym)
17925	return true;
17926
17927	if (formal->sym->attr.intent != INTENT_IN)
17928	{
17929	gfc_error ("Second argument of operator interface at %L must be "
17930	"INTENT(IN)", &where);
17931	return false;
17932	}
17933
17934	if (formal->sym->attr.optional)
17935	{
17936	gfc_error ("Second argument of operator interface at %L cannot be "
17937	"optional", &where);
17938	return false;
17939	}
17940
17941	if (formal->next)
17942	{
17943	gfc_error ("Operator interface at %L must have, at most, two "
17944	"arguments", &where);
17945	return false;
17946	}
17947
17948	return true;
17949	}
17950
17951	static void
17952	gfc_resolve_uops (gfc_symtree *symtree)
17953	{
17954	gfc_interface *itr;
17955
17956	if (symtree == NULL)
17957	return;
17958
17959	gfc_resolve_uops (symtree: symtree->left);
17960	gfc_resolve_uops (symtree: symtree->right);
17961
17962	for (itr = symtree->n.uop->op; itr; itr = itr->next)
17963	check_uop_procedure (sym: itr->sym, where: itr->sym->declared_at);
17964	}
17965
17966
17967	/* Examine all of the expressions associated with a program unit,
17968	assign types to all intermediate expressions, make sure that all
17969	assignments are to compatible types and figure out which names
17970	refer to which functions or subroutines. It doesn't check code
17971	block, which is handled by gfc_resolve_code. */
17972
17973	static void
17974	resolve_types (gfc_namespace *ns)
17975	{
17976	gfc_namespace *n;
17977	gfc_charlen *cl;
17978	gfc_data *d;
17979	gfc_equiv *eq;
17980	gfc_namespace* old_ns = gfc_current_ns;
17981	bool recursive = ns->proc_name && ns->proc_name->attr.recursive;
17982
17983	if (ns->types_resolved)
17984	return;
17985
17986	/* Check that all IMPLICIT types are ok. */
17987	if (!ns->seen_implicit_none)
17988	{
17989	unsigned letter;
17990	for (letter = 0; letter != GFC_LETTERS; ++letter)
17991	if (ns->set_flag[letter]
17992	&& !resolve_typespec_used (ts: &ns->default_type[letter],
17993	where: &ns->implicit_loc[letter], NULL))
17994	return;
17995	}
17996
17997	gfc_current_ns = ns;
17998
17999	resolve_entries (ns);
18000
18001	resolve_common_vars (common_block: &ns->blank_common, named_common: false);
18002	resolve_common_blocks (common_root: ns->common_root);
18003
18004	resolve_contained_functions (ns);
18005
18006	if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
18007	&& ns->proc_name->attr.if_source == IFSRC_IFBODY)
18008	gfc_resolve_formal_arglist (proc: ns->proc_name);
18009
18010	gfc_traverse_ns (ns, resolve_bind_c_derived_types);
18011
18012	for (cl = ns->cl_list; cl; cl = cl->next)
18013	resolve_charlen (cl);
18014
18015	gfc_traverse_ns (ns, resolve_symbol);
18016
18017	resolve_fntype (ns);
18018
18019	for (n = ns->contained; n; n = n->sibling)
18020	{
18021	/* Exclude final wrappers with the test for the artificial attribute. */
18022	if (gfc_pure (sym: ns->proc_name)
18023	&& !gfc_pure (sym: n->proc_name)
18024	&& !n->proc_name->attr.artificial)
18025	gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
18026	"also be PURE", n->proc_name->name,
18027	&n->proc_name->declared_at);
18028
18029	resolve_types (ns: n);
18030	}
18031
18032	forall_flag = 0;
18033	gfc_do_concurrent_flag = 0;
18034	gfc_check_interfaces (ns);
18035
18036	gfc_traverse_ns (ns, resolve_values);
18037
18038	if (ns->save_all || (!flag_automatic && !recursive))
18039	gfc_save_all (ns);
18040
18041	iter_stack = NULL;
18042	for (d = ns->data; d; d = d->next)
18043	resolve_data (d);
18044
18045	iter_stack = NULL;
18046	gfc_traverse_ns (ns, gfc_formalize_init_value);
18047
18048	gfc_traverse_ns (ns, gfc_verify_binding_labels);
18049
18050	for (eq = ns->equiv; eq; eq = eq->next)
18051	resolve_equivalence (eq);
18052
18053	/* Warn about unused labels. */
18054	if (warn_unused_label)
18055	warn_unused_fortran_label (label: ns->st_labels);
18056
18057	gfc_resolve_uops (symtree: ns->uop_root);
18058
18059	gfc_traverse_ns (ns, gfc_verify_DTIO_procedures);
18060
18061	gfc_resolve_omp_declare_simd (ns);
18062
18063	gfc_resolve_omp_udrs (ns->omp_udr_root);
18064
18065	ns->types_resolved = 1;
18066
18067	gfc_current_ns = old_ns;
18068	}
18069
18070
18071	/* Call gfc_resolve_code recursively. */
18072
18073	static void
18074	resolve_codes (gfc_namespace *ns)
18075	{
18076	gfc_namespace *n;
18077	bitmap_obstack old_obstack;
18078
18079	if (ns->resolved == 1)
18080	return;
18081
18082	for (n = ns->contained; n; n = n->sibling)
18083	resolve_codes (ns: n);
18084
18085	gfc_current_ns = ns;
18086
18087	/* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
18088	if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
18089	cs_base = NULL;
18090
18091	/* Set to an out of range value. */
18092	current_entry_id = -1;
18093
18094	old_obstack = labels_obstack;
18095	bitmap_obstack_initialize (&labels_obstack);
18096
18097	gfc_resolve_oacc_declare (ns);
18098	gfc_resolve_oacc_routines (ns);
18099	gfc_resolve_omp_local_vars (ns);
18100	if (ns->omp_allocate)
18101	gfc_resolve_omp_allocate (ns, ns->omp_allocate);
18102	gfc_resolve_code (code: ns->code, ns);
18103
18104	bitmap_obstack_release (&labels_obstack);
18105	labels_obstack = old_obstack;
18106	}
18107
18108
18109	/* This function is called after a complete program unit has been compiled.
18110	Its purpose is to examine all of the expressions associated with a program
18111	unit, assign types to all intermediate expressions, make sure that all
18112	assignments are to compatible types and figure out which names refer to
18113	which functions or subroutines. */
18114
18115	void
18116	gfc_resolve (gfc_namespace *ns)
18117	{
18118	gfc_namespace *old_ns;
18119	code_stack *old_cs_base;
18120	struct gfc_omp_saved_state old_omp_state;
18121
18122	if (ns->resolved)
18123	return;
18124
18125	ns->resolved = -1;
18126	old_ns = gfc_current_ns;
18127	old_cs_base = cs_base;
18128
18129	/* As gfc_resolve can be called during resolution of an OpenMP construct
18130	body, we should clear any state associated to it, so that say NS's
18131	DO loops are not interpreted as OpenMP loops. */
18132	if (!ns->construct_entities)
18133	gfc_omp_save_and_clear_state (&old_omp_state);
18134
18135	resolve_types (ns);
18136	component_assignment_level = 0;
18137	resolve_codes (ns);
18138
18139	if (ns->omp_assumes)
18140	gfc_resolve_omp_assumptions (ns->omp_assumes);
18141
18142	gfc_current_ns = old_ns;
18143	cs_base = old_cs_base;
18144	ns->resolved = 1;
18145
18146	gfc_run_passes (ns);
18147
18148	if (!ns->construct_entities)
18149	gfc_omp_restore_state (&old_omp_state);
18150	}
18151