1	/* Maintain binary trees of symbols.
2	Copyright (C) 2000-2023 Free Software Foundation, Inc.
3	Contributed by Andy Vaught
4
5	This file is part of GCC.
6
7	GCC is free software; you can redistribute it and/or modify it under
8	the terms of the GNU General Public License as published by the Free
9	Software Foundation; either version 3, or (at your option) any later
10	version.
11
12	GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13	WARRANTY; without even the implied warranty of MERCHANTABILITY or
14	FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15	for more details.
16
17	You should have received a copy of the GNU General Public License
18	along with GCC; see the file COPYING3. If not see
19	<http://www.gnu.org/licenses/>. */
20
21
22	#include "config.h"
23	#include "system.h"
24	#include "coretypes.h"
25	#include "options.h"
26	#include "gfortran.h"
27	#include "parse.h"
28	#include "match.h"
29	#include "constructor.h"
30
31
32	/* Strings for all symbol attributes. We use these for dumping the
33	parse tree, in error messages, and also when reading and writing
34	modules. */
35
36	const mstring flavors[] =
37	{
38	minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
39	minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
40	minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
41	minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
42	minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
43	minit ("UNION", FL_UNION), minit ("STRUCTURE", FL_STRUCT),
44	minit (NULL, -1)
45	};
46
47	const mstring procedures[] =
48	{
49	minit ("UNKNOWN-PROC", PROC_UNKNOWN),
50	minit ("MODULE-PROC", PROC_MODULE),
51	minit ("INTERNAL-PROC", PROC_INTERNAL),
52	minit ("DUMMY-PROC", PROC_DUMMY),
53	minit ("INTRINSIC-PROC", PROC_INTRINSIC),
54	minit ("EXTERNAL-PROC", PROC_EXTERNAL),
55	minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
56	minit (NULL, -1)
57	};
58
59	const mstring intents[] =
60	{
61	minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
62	minit ("IN", INTENT_IN),
63	minit ("OUT", INTENT_OUT),
64	minit ("INOUT", INTENT_INOUT),
65	minit (NULL, -1)
66	};
67
68	const mstring access_types[] =
69	{
70	minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
71	minit ("PUBLIC", ACCESS_PUBLIC),
72	minit ("PRIVATE", ACCESS_PRIVATE),
73	minit (NULL, -1)
74	};
75
76	const mstring ifsrc_types[] =
77	{
78	minit ("UNKNOWN", IFSRC_UNKNOWN),
79	minit ("DECL", IFSRC_DECL),
80	minit ("BODY", IFSRC_IFBODY)
81	};
82
83	const mstring save_status[] =
84	{
85	minit ("UNKNOWN", SAVE_NONE),
86	minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
87	minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
88	};
89
90	/* Set the mstrings for DTIO procedure names. */
91	const mstring dtio_procs[] =
92	{
93	minit ("_dtio_formatted_read", DTIO_RF),
94	minit ("_dtio_formatted_write", DTIO_WF),
95	minit ("_dtio_unformatted_read", DTIO_RUF),
96	minit ("_dtio_unformatted_write", DTIO_WUF),
97	};
98
99	/* This is to make sure the backend generates setup code in the correct
100	order. */
101
102	static int next_dummy_order = 1;
103
104
105	gfc_namespace *gfc_current_ns;
106	gfc_namespace *gfc_global_ns_list;
107
108	gfc_gsymbol *gfc_gsym_root = NULL;
109
110	gfc_symbol *gfc_derived_types;
111
112	static gfc_undo_change_set default_undo_chgset_var = { .syms: vNULL, .tbps: vNULL, NULL };
113	static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var;
114
115
116	/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
117
118	/* The following static variable indicates whether a particular element has
119	been explicitly set or not. */
120
121	static int new_flag[GFC_LETTERS];
122
123
124	/* Handle a correctly parsed IMPLICIT NONE. */
125
126	void
127	gfc_set_implicit_none (bool type, bool external, locus *loc)
128	{
129	int i;
130
131	if (external)
132	gfc_current_ns->has_implicit_none_export = 1;
133
134	if (type)
135	{
136	gfc_current_ns->seen_implicit_none = 1;
137	for (i = 0; i < GFC_LETTERS; i++)
138	{
139	if (gfc_current_ns->set_flag[i])
140	{
141	gfc_error_now ("IMPLICIT NONE (type) statement at %L following an "
142	"IMPLICIT statement", loc);
143	return;
144	}
145	gfc_clear_ts (&gfc_current_ns->default_type[i]);
146	gfc_current_ns->set_flag[i] = 1;
147	}
148	}
149	}
150
151
152	/* Reset the implicit range flags. */
153
154	void
155	gfc_clear_new_implicit (void)
156	{
157	int i;
158
159	for (i = 0; i < GFC_LETTERS; i++)
160	new_flag[i] = 0;
161	}
162
163
164	/* Prepare for a new implicit range. Sets flags in new_flag[]. */
165
166	bool
167	gfc_add_new_implicit_range (int c1, int c2)
168	{
169	int i;
170
171	c1 -= 'a';
172	c2 -= 'a';
173
174	for (i = c1; i <= c2; i++)
175	{
176	if (new_flag[i])
177	{
178	gfc_error ("Letter %qc already set in IMPLICIT statement at %C",
179	i + 'A');
180	return false;
181	}
182
183	new_flag[i] = 1;
184	}
185
186	return true;
187	}
188
189
190	/* Add a matched implicit range for gfc_set_implicit(). Check if merging
191	the new implicit types back into the existing types will work. */
192
193	bool
194	gfc_merge_new_implicit (gfc_typespec *ts)
195	{
196	int i;
197
198	if (gfc_current_ns->seen_implicit_none)
199	{
200	gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
201	return false;
202	}
203
204	for (i = 0; i < GFC_LETTERS; i++)
205	{
206	if (new_flag[i])
207	{
208	if (gfc_current_ns->set_flag[i])
209	{
210	gfc_error ("Letter %qc already has an IMPLICIT type at %C",
211	i + 'A');
212	return false;
213	}
214
215	gfc_current_ns->default_type[i] = *ts;
216	gfc_current_ns->implicit_loc[i] = gfc_current_locus;
217	gfc_current_ns->set_flag[i] = 1;
218	}
219	}
220	return true;
221	}
222
223
224	/* Given a symbol, return a pointer to the typespec for its default type. */
225
226	gfc_typespec *
227	gfc_get_default_type (const char *name, gfc_namespace *ns)
228	{
229	char letter;
230
231	letter = name[0];
232
233	if (flag_allow_leading_underscore && letter == '_')
234	gfc_fatal_error ("Option %<-fallow-leading-underscore%> is for use only by "
235	"gfortran developers, and should not be used for "
236	"implicitly typed variables");
237
238	if (letter < 'a' || letter > 'z')
239	gfc_internal_error ("gfc_get_default_type(): Bad symbol %qs", name);
240
241	if (ns == NULL)
242	ns = gfc_current_ns;
243
244	return &ns->default_type[letter - 'a'];
245	}
246
247
248	/* Recursively append candidate SYM to CANDIDATES. Store the number of
249	candidates in CANDIDATES_LEN. */
250
251	static void
252	lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
253	char **&candidates,
254	size_t &candidates_len)
255	{
256	gfc_symtree *p;
257
258	if (sym == NULL)
259	return;
260
261	if (sym->n.sym->ts.type != BT_UNKNOWN && sym->n.sym->ts.type != BT_PROCEDURE)
262	vec_push (optr&: candidates, osz&: candidates_len, elt: sym->name);
263	p = sym->left;
264	if (p)
265	lookup_symbol_fuzzy_find_candidates (sym: p, candidates, candidates_len);
266
267	p = sym->right;
268	if (p)
269	lookup_symbol_fuzzy_find_candidates (sym: p, candidates, candidates_len);
270	}
271
272
273	/* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account. */
274
275	static const char*
276	lookup_symbol_fuzzy (const char *sym_name, gfc_symbol *symbol)
277	{
278	char **candidates = NULL;
279	size_t candidates_len = 0;
280	lookup_symbol_fuzzy_find_candidates (sym: symbol->ns->sym_root, candidates,
281	candidates_len);
282	return gfc_closest_fuzzy_match (sym_name, candidates);
283	}
284
285
286	/* Given a pointer to a symbol, set its type according to the first
287	letter of its name. Fails if the letter in question has no default
288	type. */
289
290	bool
291	gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
292	{
293	gfc_typespec *ts;
294
295	if (sym->ts.type != BT_UNKNOWN)
296	gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
297
298	ts = gfc_get_default_type (name: sym->name, ns);
299
300	if (ts->type == BT_UNKNOWN)
301	{
302	if (error_flag && !sym->attr.untyped && !gfc_query_suppress_errors ())
303	{
304	const char *guessed = lookup_symbol_fuzzy (sym_name: sym->name, symbol: sym);
305	if (guessed)
306	gfc_error ("Symbol %qs at %L has no IMPLICIT type"
307	"; did you mean %qs?",
308	sym->name, &sym->declared_at, guessed);
309	else
310	gfc_error ("Symbol %qs at %L has no IMPLICIT type",
311	sym->name, &sym->declared_at);
312	sym->attr.untyped = 1; /* Ensure we only give an error once. */
313	}
314
315	return false;
316	}
317
318	sym->ts = *ts;
319	sym->attr.implicit_type = 1;
320
321	if (ts->type == BT_CHARACTER && ts->u.cl)
322	sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
323	else if (ts->type == BT_CLASS
324	&& !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
325	return false;
326
327	if (sym->attr.is_bind_c == 1 && warn_c_binding_type)
328	{
329	/* BIND(C) variables should not be implicitly declared. */
330	gfc_warning_now (opt: OPT_Wc_binding_type, "Implicitly declared BIND(C) "
331	"variable %qs at %L may not be C interoperable",
332	sym->name, &sym->declared_at);
333	sym->ts.f90_type = sym->ts.type;
334	}
335
336	if (sym->attr.dummy != 0)
337	{
338	if (sym->ns->proc_name != NULL
339	&& (sym->ns->proc_name->attr.subroutine != 0
340	|| sym->ns->proc_name->attr.function != 0)
341	&& sym->ns->proc_name->attr.is_bind_c != 0
342	&& warn_c_binding_type)
343	{
344	/* Dummy args to a BIND(C) routine may not be interoperable if
345	they are implicitly typed. */
346	gfc_warning_now (opt: OPT_Wc_binding_type, "Implicitly declared variable "
347	"%qs at %L may not be C interoperable but it is a "
348	"dummy argument to the BIND(C) procedure %qs at %L",
349	sym->name, &(sym->declared_at),
350	sym->ns->proc_name->name,
351	&(sym->ns->proc_name->declared_at));
352	sym->ts.f90_type = sym->ts.type;
353	}
354	}
355
356	return true;
357	}
358
359
360	/* This function is called from parse.cc(parse_progunit) to check the
361	type of the function is not implicitly typed in the host namespace
362	and to implicitly type the function result, if necessary. */
363
364	void
365	gfc_check_function_type (gfc_namespace *ns)
366	{
367	gfc_symbol *proc = ns->proc_name;
368
369	if (!proc->attr.contained || proc->result->attr.implicit_type)
370	return;
371
372	if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
373	{
374	if (gfc_set_default_type (sym: proc->result, error_flag: 0, ns: gfc_current_ns))
375	{
376	if (proc->result != proc)
377	{
378	proc->ts = proc->result->ts;
379	proc->as = gfc_copy_array_spec (proc->result->as);
380	proc->attr.dimension = proc->result->attr.dimension;
381	proc->attr.pointer = proc->result->attr.pointer;
382	proc->attr.allocatable = proc->result->attr.allocatable;
383	}
384	}
385	else if (!proc->result->attr.proc_pointer)
386	{
387	gfc_error ("Function result %qs at %L has no IMPLICIT type",
388	proc->result->name, &proc->result->declared_at);
389	proc->result->attr.untyped = 1;
390	}
391	}
392	}
393
394
395	/******************** Symbol attribute stuff *********************/
396
397	/* This is a generic conflict-checker. We do this to avoid having a
398	single conflict in two places. */
399
400	#define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
401	#define conf2(a) if (attr->a) { a2 = a; goto conflict; }
402	#define conf_std(a, b, std) if (attr->a && attr->b)\
403	{\
404	a1 = a;\
405	a2 = b;\
406	standard = std;\
407	goto conflict_std;\
408	}
409
410	bool
411	gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where)
412	{
413	static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
414	*target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
415	*intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
416	*intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
417	*allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
418	*privat = "PRIVATE", *recursive = "RECURSIVE",
419	*in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
420	*publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
421	*function = "FUNCTION", *subroutine = "SUBROUTINE",
422	*dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
423	*use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
424	*cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
425	*volatile_ = "VOLATILE", *is_protected = "PROTECTED",
426	*is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
427	*proc_pointer = "PROCEDURE POINTER", *abstract = "ABSTRACT",
428	*asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
429	*contiguous = "CONTIGUOUS", *generic = "GENERIC", *automatic = "AUTOMATIC",
430	*pdt_len = "LEN", *pdt_kind = "KIND";
431	static const char *threadprivate = "THREADPRIVATE";
432	static const char *omp_declare_target = "OMP DECLARE TARGET";
433	static const char *omp_declare_target_link = "OMP DECLARE TARGET LINK";
434	static const char *oacc_declare_copyin = "OACC DECLARE COPYIN";
435	static const char *oacc_declare_create = "OACC DECLARE CREATE";
436	static const char *oacc_declare_deviceptr = "OACC DECLARE DEVICEPTR";
437	static const char *oacc_declare_device_resident =
438	"OACC DECLARE DEVICE_RESIDENT";
439
440	const char *a1, *a2;
441	int standard;
442
443	if (attr->artificial)
444	return true;
445
446	if (where == NULL)
447	where = &gfc_current_locus;
448
449	if (attr->pointer && attr->intent != INTENT_UNKNOWN)
450	{
451	a1 = pointer;
452	a2 = intent;
453	standard = GFC_STD_F2003;
454	goto conflict_std;
455	}
456
457	if (attr->in_namelist && (attr->allocatable || attr->pointer))
458	{
459	a1 = in_namelist;
460	a2 = attr->allocatable ? allocatable : pointer;
461	standard = GFC_STD_F2003;
462	goto conflict_std;
463	}
464
465	/* Check for attributes not allowed in a BLOCK DATA. */
466	if (gfc_current_state () == COMP_BLOCK_DATA)
467	{
468	a1 = NULL;
469
470	if (attr->in_namelist)
471	a1 = in_namelist;
472	if (attr->allocatable)
473	a1 = allocatable;
474	if (attr->external)
475	a1 = external;
476	if (attr->optional)
477	a1 = optional;
478	if (attr->access == ACCESS_PRIVATE)
479	a1 = privat;
480	if (attr->access == ACCESS_PUBLIC)
481	a1 = publik;
482	if (attr->intent != INTENT_UNKNOWN)
483	a1 = intent;
484
485	if (a1 != NULL)
486	{
487	gfc_error
488	("%s attribute not allowed in BLOCK DATA program unit at %L",
489	a1, where);
490	return false;
491	}
492	}
493
494	if (attr->save == SAVE_EXPLICIT)
495	{
496	conf (dummy, save);
497	conf (in_common, save);
498	conf (result, save);
499	conf (automatic, save);
500
501	switch (attr->flavor)
502	{
503	case FL_PROGRAM:
504	case FL_BLOCK_DATA:
505	case FL_MODULE:
506	case FL_LABEL:
507	case_fl_struct:
508	case FL_PARAMETER:
509	a1 = gfc_code2string (flavors, attr->flavor);
510	a2 = save;
511	goto conflict;
512	case FL_NAMELIST:
513	gfc_error ("Namelist group name at %L cannot have the "
514	"SAVE attribute", where);
515	return false;
516	case FL_PROCEDURE:
517	/* Conflicts between SAVE and PROCEDURE will be checked at
518	resolution stage, see "resolve_fl_procedure". */
519	case FL_VARIABLE:
520	default:
521	break;
522	}
523	}
524
525	/* The copying of procedure dummy arguments for module procedures in
526	a submodule occur whilst the current state is COMP_CONTAINS. It
527	is necessary, therefore, to let this through. */
528	if (name && attr->dummy
529	&& (attr->function || attr->subroutine)
530	&& gfc_current_state () == COMP_CONTAINS
531	&& !(gfc_new_block && gfc_new_block->abr_modproc_decl))
532	gfc_error_now ("internal procedure %qs at %L conflicts with "
533	"DUMMY argument", name, where);
534
535	conf (dummy, entry);
536	conf (dummy, intrinsic);
537	conf (dummy, threadprivate);
538	conf (dummy, omp_declare_target);
539	conf (dummy, omp_declare_target_link);
540	conf (pointer, target);
541	conf (pointer, intrinsic);
542	conf (pointer, elemental);
543	conf (pointer, codimension);
544	conf (allocatable, elemental);
545
546	conf (in_common, automatic);
547	conf (result, automatic);
548	conf (use_assoc, automatic);
549	conf (dummy, automatic);
550
551	conf (target, external);
552	conf (target, intrinsic);
553
554	if (!attr->if_source)
555	conf (external, dimension); /* See Fortran 95's R504. */
556
557	conf (external, intrinsic);
558	conf (entry, intrinsic);
559	conf (abstract, intrinsic);
560
561	if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
562	conf (external, subroutine);
563
564	if (attr->proc_pointer && !gfc_notify_std (GFC_STD_F2003,
565	"Procedure pointer at %C"))
566	return false;
567
568	conf (allocatable, pointer);
569	conf_std (allocatable, dummy, GFC_STD_F2003);
570	conf_std (allocatable, function, GFC_STD_F2003);
571	conf_std (allocatable, result, GFC_STD_F2003);
572	conf_std (elemental, recursive, GFC_STD_F2018);
573
574	conf (in_common, dummy);
575	conf (in_common, allocatable);
576	conf (in_common, codimension);
577	conf (in_common, result);
578
579	conf (in_equivalence, use_assoc);
580	conf (in_equivalence, codimension);
581	conf (in_equivalence, dummy);
582	conf (in_equivalence, target);
583	conf (in_equivalence, pointer);
584	conf (in_equivalence, function);
585	conf (in_equivalence, result);
586	conf (in_equivalence, entry);
587	conf (in_equivalence, allocatable);
588	conf (in_equivalence, threadprivate);
589	conf (in_equivalence, omp_declare_target);
590	conf (in_equivalence, omp_declare_target_link);
591	conf (in_equivalence, oacc_declare_create);
592	conf (in_equivalence, oacc_declare_copyin);
593	conf (in_equivalence, oacc_declare_deviceptr);
594	conf (in_equivalence, oacc_declare_device_resident);
595	conf (in_equivalence, is_bind_c);
596
597	conf (dummy, result);
598	conf (entry, result);
599	conf (generic, result);
600	conf (generic, omp_declare_target);
601	conf (generic, omp_declare_target_link);
602
603	conf (function, subroutine);
604
605	if (!function && !subroutine)
606	conf (is_bind_c, dummy);
607
608	conf (is_bind_c, cray_pointer);
609	conf (is_bind_c, cray_pointee);
610	conf (is_bind_c, codimension);
611	conf (is_bind_c, allocatable);
612	conf (is_bind_c, elemental);
613
614	/* Need to also get volatile attr, according to 5.1 of F2003 draft.
615	Parameter conflict caught below. Also, value cannot be specified
616	for a dummy procedure. */
617
618	/* Cray pointer/pointee conflicts. */
619	conf (cray_pointer, cray_pointee);
620	conf (cray_pointer, dimension);
621	conf (cray_pointer, codimension);
622	conf (cray_pointer, contiguous);
623	conf (cray_pointer, pointer);
624	conf (cray_pointer, target);
625	conf (cray_pointer, allocatable);
626	conf (cray_pointer, external);
627	conf (cray_pointer, intrinsic);
628	conf (cray_pointer, in_namelist);
629	conf (cray_pointer, function);
630	conf (cray_pointer, subroutine);
631	conf (cray_pointer, entry);
632
633	conf (cray_pointee, allocatable);
634	conf (cray_pointee, contiguous);
635	conf (cray_pointee, codimension);
636	conf (cray_pointee, intent);
637	conf (cray_pointee, optional);
638	conf (cray_pointee, dummy);
639	conf (cray_pointee, target);
640	conf (cray_pointee, intrinsic);
641	conf (cray_pointee, pointer);
642	conf (cray_pointee, entry);
643	conf (cray_pointee, in_common);
644	conf (cray_pointee, in_equivalence);
645	conf (cray_pointee, threadprivate);
646	conf (cray_pointee, omp_declare_target);
647	conf (cray_pointee, omp_declare_target_link);
648	conf (cray_pointee, oacc_declare_create);
649	conf (cray_pointee, oacc_declare_copyin);
650	conf (cray_pointee, oacc_declare_deviceptr);
651	conf (cray_pointee, oacc_declare_device_resident);
652
653	conf (data, dummy);
654	conf (data, function);
655	conf (data, result);
656	conf (data, allocatable);
657
658	conf (value, pointer)
659	conf (value, allocatable)
660	conf (value, subroutine)
661	conf (value, function)
662	conf (value, volatile_)
663	conf (value, dimension)
664	conf (value, codimension)
665	conf (value, external)
666
667	conf (codimension, result)
668
669	if (attr->value
670	&& (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
671	{
672	a1 = value;
673	a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
674	goto conflict;
675	}
676
677	conf (is_protected, intrinsic)
678	conf (is_protected, in_common)
679
680	conf (asynchronous, intrinsic)
681	conf (asynchronous, external)
682
683	conf (volatile_, intrinsic)
684	conf (volatile_, external)
685
686	if (attr->volatile_ && attr->intent == INTENT_IN)
687	{
688	a1 = volatile_;
689	a2 = intent_in;
690	goto conflict;
691	}
692
693	conf (procedure, allocatable)
694	conf (procedure, dimension)
695	conf (procedure, codimension)
696	conf (procedure, intrinsic)
697	conf (procedure, target)
698	conf (procedure, value)
699	conf (procedure, volatile_)
700	conf (procedure, asynchronous)
701	conf (procedure, entry)
702
703	conf (proc_pointer, abstract)
704	conf (proc_pointer, omp_declare_target)
705	conf (proc_pointer, omp_declare_target_link)
706
707	conf (entry, omp_declare_target)
708	conf (entry, omp_declare_target_link)
709	conf (entry, oacc_declare_create)
710	conf (entry, oacc_declare_copyin)
711	conf (entry, oacc_declare_deviceptr)
712	conf (entry, oacc_declare_device_resident)
713
714	conf (pdt_kind, allocatable)
715	conf (pdt_kind, pointer)
716	conf (pdt_kind, dimension)
717	conf (pdt_kind, codimension)
718
719	conf (pdt_len, allocatable)
720	conf (pdt_len, pointer)
721	conf (pdt_len, dimension)
722	conf (pdt_len, codimension)
723	conf (pdt_len, pdt_kind)
724
725	if (attr->access == ACCESS_PRIVATE)
726	{
727	a1 = privat;
728	conf2 (pdt_kind);
729	conf2 (pdt_len);
730	}
731
732	a1 = gfc_code2string (flavors, attr->flavor);
733
734	if (attr->in_namelist
735	&& attr->flavor != FL_VARIABLE
736	&& attr->flavor != FL_PROCEDURE
737	&& attr->flavor != FL_UNKNOWN)
738	{
739	a2 = in_namelist;
740	goto conflict;
741	}
742
743	switch (attr->flavor)
744	{
745	case FL_PROGRAM:
746	case FL_BLOCK_DATA:
747	case FL_MODULE:
748	case FL_LABEL:
749	conf2 (codimension);
750	conf2 (dimension);
751	conf2 (dummy);
752	conf2 (volatile_);
753	conf2 (asynchronous);
754	conf2 (contiguous);
755	conf2 (pointer);
756	conf2 (is_protected);
757	conf2 (target);
758	conf2 (external);
759	conf2 (intrinsic);
760	conf2 (allocatable);
761	conf2 (result);
762	conf2 (in_namelist);
763	conf2 (optional);
764	conf2 (function);
765	conf2 (subroutine);
766	conf2 (threadprivate);
767	conf2 (omp_declare_target);
768	conf2 (omp_declare_target_link);
769	conf2 (oacc_declare_create);
770	conf2 (oacc_declare_copyin);
771	conf2 (oacc_declare_deviceptr);
772	conf2 (oacc_declare_device_resident);
773
774	if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
775	{
776	a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
777	gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
778	name, where);
779	return false;
780	}
781
782	if (attr->is_bind_c)
783	{
784	gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
785	return false;
786	}
787
788	break;
789
790	case FL_VARIABLE:
791	break;
792
793	case FL_NAMELIST:
794	conf2 (result);
795	break;
796
797	case FL_PROCEDURE:
798	/* Conflicts with INTENT, SAVE and RESULT will be checked
799	at resolution stage, see "resolve_fl_procedure". */
800
801	if (attr->subroutine)
802	{
803	a1 = subroutine;
804	conf2 (target);
805	conf2 (allocatable);
806	conf2 (volatile_);
807	conf2 (asynchronous);
808	conf2 (in_namelist);
809	conf2 (codimension);
810	conf2 (dimension);
811	conf2 (function);
812	if (!attr->proc_pointer)
813	conf2 (threadprivate);
814	}
815
816	/* Procedure pointers in COMMON blocks are allowed in F03,
817	* but forbidden per F08:C5100. */
818	if (!attr->proc_pointer || (gfc_option.allow_std & GFC_STD_F2008))
819	conf2 (in_common);
820
821	conf2 (omp_declare_target_link);
822
823	switch (attr->proc)
824	{
825	case PROC_ST_FUNCTION:
826	conf2 (dummy);
827	conf2 (target);
828	break;
829
830	case PROC_MODULE:
831	conf2 (dummy);
832	break;
833
834	case PROC_DUMMY:
835	conf2 (result);
836	conf2 (threadprivate);
837	break;
838
839	default:
840	break;
841	}
842
843	break;
844
845	case_fl_struct:
846	conf2 (dummy);
847	conf2 (pointer);
848	conf2 (target);
849	conf2 (external);
850	conf2 (intrinsic);
851	conf2 (allocatable);
852	conf2 (optional);
853	conf2 (entry);
854	conf2 (function);
855	conf2 (subroutine);
856	conf2 (threadprivate);
857	conf2 (result);
858	conf2 (omp_declare_target);
859	conf2 (omp_declare_target_link);
860	conf2 (oacc_declare_create);
861	conf2 (oacc_declare_copyin);
862	conf2 (oacc_declare_deviceptr);
863	conf2 (oacc_declare_device_resident);
864
865	if (attr->intent != INTENT_UNKNOWN)
866	{
867	a2 = intent;
868	goto conflict;
869	}
870	break;
871
872	case FL_PARAMETER:
873	conf2 (external);
874	conf2 (intrinsic);
875	conf2 (optional);
876	conf2 (allocatable);
877	conf2 (function);
878	conf2 (subroutine);
879	conf2 (entry);
880	conf2 (contiguous);
881	conf2 (pointer);
882	conf2 (is_protected);
883	conf2 (target);
884	conf2 (dummy);
885	conf2 (in_common);
886	conf2 (value);
887	conf2 (volatile_);
888	conf2 (asynchronous);
889	conf2 (threadprivate);
890	conf2 (value);
891	conf2 (codimension);
892	conf2 (result);
893	if (!attr->is_iso_c)
894	conf2 (is_bind_c);
895	break;
896
897	default:
898	break;
899	}
900
901	return true;
902
903	conflict:
904	if (name == NULL)
905	gfc_error ("%s attribute conflicts with %s attribute at %L",
906	a1, a2, where);
907	else
908	gfc_error ("%s attribute conflicts with %s attribute in %qs at %L",
909	a1, a2, name, where);
910
911	return false;
912
913	conflict_std:
914	if (name == NULL)
915	{
916	return gfc_notify_std (standard, "%s attribute conflicts "
917	"with %s attribute at %L", a1, a2,
918	where);
919	}
920	else
921	{
922	return gfc_notify_std (standard, "%s attribute conflicts "
923	"with %s attribute in %qs at %L",
924	a1, a2, name, where);
925	}
926	}
927
928	#undef conf
929	#undef conf2
930	#undef conf_std
931
932
933	/* Mark a symbol as referenced. */
934
935	void
936	gfc_set_sym_referenced (gfc_symbol *sym)
937	{
938
939	if (sym->attr.referenced)
940	return;
941
942	sym->attr.referenced = 1;
943
944	/* Remember which order dummy variables are accessed in. */
945	if (sym->attr.dummy)
946	sym->dummy_order = next_dummy_order++;
947	}
948
949
950	/* Common subroutine called by attribute changing subroutines in order
951	to prevent them from changing a symbol that has been
952	use-associated. Returns zero if it is OK to change the symbol,
953	nonzero if not. */
954
955	static int
956	check_used (symbol_attribute *attr, const char *name, locus *where)
957	{
958
959	if (attr->use_assoc == 0)
960	return 0;
961
962	if (where == NULL)
963	where = &gfc_current_locus;
964
965	if (name == NULL)
966	gfc_error ("Cannot change attributes of USE-associated symbol at %L",
967	where);
968	else
969	gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
970	name, where);
971
972	return 1;
973	}
974
975
976	/* Generate an error because of a duplicate attribute. */
977
978	static void
979	duplicate_attr (const char *attr, locus *where)
980	{
981
982	if (where == NULL)
983	where = &gfc_current_locus;
984
985	gfc_error ("Duplicate %s attribute specified at %L", attr, where);
986	}
987
988
989	bool
990	gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
991	locus *where ATTRIBUTE_UNUSED)
992	{
993	attr->ext_attr |= 1 << ext_attr;
994	return true;
995	}
996
997
998	/* Called from decl.cc (attr_decl1) to check attributes, when declared
999	separately. */
1000
1001	bool
1002	gfc_add_attribute (symbol_attribute *attr, locus *where)
1003	{
1004	if (check_used (attr, NULL, where))
1005	return false;
1006
1007	return gfc_check_conflict (attr, NULL, where);
1008	}
1009
1010
1011	bool
1012	gfc_add_allocatable (symbol_attribute *attr, locus *where)
1013	{
1014
1015	if (check_used (attr, NULL, where))
1016	return false;
1017
1018	if (attr->allocatable && ! gfc_submodule_procedure(attr))
1019	{
1020	duplicate_attr (attr: "ALLOCATABLE", where);
1021	return false;
1022	}
1023
1024	if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
1025	&& !gfc_find_state (COMP_INTERFACE))
1026	{
1027	gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
1028	where);
1029	return false;
1030	}
1031
1032	attr->allocatable = 1;
1033	return gfc_check_conflict (attr, NULL, where);
1034	}
1035
1036
1037	bool
1038	gfc_add_automatic (symbol_attribute *attr, const char *name, locus *where)
1039	{
1040	if (check_used (attr, name, where))
1041	return false;
1042
1043	if (attr->automatic && !gfc_notify_std (GFC_STD_LEGACY,
1044	"Duplicate AUTOMATIC attribute specified at %L", where))
1045	return false;
1046
1047	attr->automatic = 1;
1048	return gfc_check_conflict (attr, name, where);
1049	}
1050
1051
1052	bool
1053	gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
1054	{
1055
1056	if (check_used (attr, name, where))
1057	return false;
1058
1059	if (attr->codimension)
1060	{
1061	duplicate_attr (attr: "CODIMENSION", where);
1062	return false;
1063	}
1064
1065	if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
1066	&& !gfc_find_state (COMP_INTERFACE))
1067	{
1068	gfc_error ("CODIMENSION specified for %qs outside its INTERFACE body "
1069	"at %L", name, where);
1070	return false;
1071	}
1072
1073	attr->codimension = 1;
1074	return gfc_check_conflict (attr, name, where);
1075	}
1076
1077
1078	bool
1079	gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
1080	{
1081
1082	if (check_used (attr, name, where))
1083	return false;
1084
1085	if (attr->dimension && ! gfc_submodule_procedure(attr))
1086	{
1087	duplicate_attr (attr: "DIMENSION", where);
1088	return false;
1089	}
1090
1091	if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
1092	&& !gfc_find_state (COMP_INTERFACE))
1093	{
1094	gfc_error ("DIMENSION specified for %qs outside its INTERFACE body "
1095	"at %L", name, where);
1096	return false;
1097	}
1098
1099	attr->dimension = 1;
1100	return gfc_check_conflict (attr, name, where);
1101	}
1102
1103
1104	bool
1105	gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
1106	{
1107
1108	if (check_used (attr, name, where))
1109	return false;
1110
1111	if (attr->contiguous)
1112	{
1113	duplicate_attr (attr: "CONTIGUOUS", where);
1114	return false;
1115	}
1116
1117	attr->contiguous = 1;
1118	return gfc_check_conflict (attr, name, where);
1119	}
1120
1121
1122	bool
1123	gfc_add_external (symbol_attribute *attr, locus *where)
1124	{
1125
1126	if (check_used (attr, NULL, where))
1127	return false;
1128
1129	if (attr->external)
1130	{
1131	duplicate_attr (attr: "EXTERNAL", where);
1132	return false;
1133	}
1134
1135	if (attr->pointer && attr->if_source != IFSRC_IFBODY)
1136	{
1137	attr->pointer = 0;
1138	attr->proc_pointer = 1;
1139	}
1140
1141	attr->external = 1;
1142
1143	return gfc_check_conflict (attr, NULL, where);
1144	}
1145
1146
1147	bool
1148	gfc_add_intrinsic (symbol_attribute *attr, locus *where)
1149	{
1150
1151	if (check_used (attr, NULL, where))
1152	return false;
1153
1154	if (attr->intrinsic)
1155	{
1156	duplicate_attr (attr: "INTRINSIC", where);
1157	return false;
1158	}
1159
1160	attr->intrinsic = 1;
1161
1162	return gfc_check_conflict (attr, NULL, where);
1163	}
1164
1165
1166	bool
1167	gfc_add_optional (symbol_attribute *attr, locus *where)
1168	{
1169
1170	if (check_used (attr, NULL, where))
1171	return false;
1172
1173	if (attr->optional)
1174	{
1175	duplicate_attr (attr: "OPTIONAL", where);
1176	return false;
1177	}
1178
1179	attr->optional = 1;
1180	return gfc_check_conflict (attr, NULL, where);
1181	}
1182
1183	bool
1184	gfc_add_kind (symbol_attribute *attr, locus *where)
1185	{
1186	if (attr->pdt_kind)
1187	{
1188	duplicate_attr (attr: "KIND", where);
1189	return false;
1190	}
1191
1192	attr->pdt_kind = 1;
1193	return gfc_check_conflict (attr, NULL, where);
1194	}
1195
1196	bool
1197	gfc_add_len (symbol_attribute *attr, locus *where)
1198	{
1199	if (attr->pdt_len)
1200	{
1201	duplicate_attr (attr: "LEN", where);
1202	return false;
1203	}
1204
1205	attr->pdt_len = 1;
1206	return gfc_check_conflict (attr, NULL, where);
1207	}
1208
1209
1210	bool
1211	gfc_add_pointer (symbol_attribute *attr, locus *where)
1212	{
1213
1214	if (check_used (attr, NULL, where))
1215	return false;
1216
1217	if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
1218	&& !gfc_find_state (COMP_INTERFACE))
1219	&& ! gfc_submodule_procedure(attr))
1220	{
1221	duplicate_attr (attr: "POINTER", where);
1222	return false;
1223	}
1224
1225	if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
1226	|| (attr->if_source == IFSRC_IFBODY
1227	&& !gfc_find_state (COMP_INTERFACE)))
1228	attr->proc_pointer = 1;
1229	else
1230	attr->pointer = 1;
1231
1232	return gfc_check_conflict (attr, NULL, where);
1233	}
1234
1235
1236	bool
1237	gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
1238	{
1239
1240	if (check_used (attr, NULL, where))
1241	return false;
1242
1243	attr->cray_pointer = 1;
1244	return gfc_check_conflict (attr, NULL, where);
1245	}
1246
1247
1248	bool
1249	gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
1250	{
1251
1252	if (check_used (attr, NULL, where))
1253	return false;
1254
1255	if (attr->cray_pointee)
1256	{
1257	gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1258	" statements", where);
1259	return false;
1260	}
1261
1262	attr->cray_pointee = 1;
1263	return gfc_check_conflict (attr, NULL, where);
1264	}
1265
1266
1267	bool
1268	gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
1269	{
1270	if (check_used (attr, name, where))
1271	return false;
1272
1273	if (attr->is_protected)
1274	{
1275	if (!gfc_notify_std (GFC_STD_LEGACY,
1276	"Duplicate PROTECTED attribute specified at %L",
1277	where))
1278	return false;
1279	}
1280
1281	attr->is_protected = 1;
1282	return gfc_check_conflict (attr, name, where);
1283	}
1284
1285
1286	bool
1287	gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
1288	{
1289
1290	if (check_used (attr, name, where))
1291	return false;
1292
1293	attr->result = 1;
1294	return gfc_check_conflict (attr, name, where);
1295	}
1296
1297
1298	bool
1299	gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
1300	locus *where)
1301	{
1302
1303	if (check_used (attr, name, where))
1304	return false;
1305
1306	if (s == SAVE_EXPLICIT && gfc_pure (NULL))
1307	{
1308	gfc_error
1309	("SAVE attribute at %L cannot be specified in a PURE procedure",
1310	where);
1311	return false;
1312	}
1313
1314	if (s == SAVE_EXPLICIT)
1315	gfc_unset_implicit_pure (NULL);
1316
1317	if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT
1318	&& (flag_automatic || pedantic))
1319	{
1320	if (!gfc_notify_std (GFC_STD_LEGACY,
1321	"Duplicate SAVE attribute specified at %L",
1322	where))
1323	return false;
1324	}
1325
1326	attr->save = s;
1327	return gfc_check_conflict (attr, name, where);
1328	}
1329
1330
1331	bool
1332	gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1333	{
1334
1335	if (check_used (attr, name, where))
1336	return false;
1337
1338	if (attr->value)
1339	{
1340	if (!gfc_notify_std (GFC_STD_LEGACY,
1341	"Duplicate VALUE attribute specified at %L",
1342	where))
1343	return false;
1344	}
1345
1346	attr->value = 1;
1347	return gfc_check_conflict (attr, name, where);
1348	}
1349
1350
1351	bool
1352	gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1353	{
1354	/* No check_used needed as 11.2.1 of the F2003 standard allows
1355	that the local identifier made accessible by a use statement can be
1356	given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1357
1358	if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1359	if (!gfc_notify_std (GFC_STD_LEGACY,
1360	"Duplicate VOLATILE attribute specified at %L",
1361	where))
1362	return false;
1363
1364	/* F2008: C1282 A designator of a variable with the VOLATILE attribute
1365	shall not appear in a pure subprogram.
1366
1367	F2018: C1588 A local variable of a pure subprogram, or of a BLOCK
1368	construct within a pure subprogram, shall not have the SAVE or
1369	VOLATILE attribute. */
1370	if (gfc_pure (NULL))
1371	{
1372	gfc_error ("VOLATILE attribute at %L cannot be specified in a "
1373	"PURE procedure", where);
1374	return false;
1375	}
1376
1377
1378	attr->volatile_ = 1;
1379	attr->volatile_ns = gfc_current_ns;
1380	return gfc_check_conflict (attr, name, where);
1381	}
1382
1383
1384	bool
1385	gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
1386	{
1387	/* No check_used needed as 11.2.1 of the F2003 standard allows
1388	that the local identifier made accessible by a use statement can be
1389	given a ASYNCHRONOUS attribute. */
1390
1391	if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
1392	if (!gfc_notify_std (GFC_STD_LEGACY,
1393	"Duplicate ASYNCHRONOUS attribute specified at %L",
1394	where))
1395	return false;
1396
1397	attr->asynchronous = 1;
1398	attr->asynchronous_ns = gfc_current_ns;
1399	return gfc_check_conflict (attr, name, where);
1400	}
1401
1402
1403	bool
1404	gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1405	{
1406
1407	if (check_used (attr, name, where))
1408	return false;
1409
1410	if (attr->threadprivate)
1411	{
1412	duplicate_attr (attr: "THREADPRIVATE", where);
1413	return false;
1414	}
1415
1416	attr->threadprivate = 1;
1417	return gfc_check_conflict (attr, name, where);
1418	}
1419
1420
1421	bool
1422	gfc_add_omp_declare_target (symbol_attribute *attr, const char *name,
1423	locus *where)
1424	{
1425
1426	if (check_used (attr, name, where))
1427	return false;
1428
1429	if (attr->omp_declare_target)
1430	return true;
1431
1432	attr->omp_declare_target = 1;
1433	return gfc_check_conflict (attr, name, where);
1434	}
1435
1436
1437	bool
1438	gfc_add_omp_declare_target_link (symbol_attribute *attr, const char *name,
1439	locus *where)
1440	{
1441
1442	if (check_used (attr, name, where))
1443	return false;
1444
1445	if (attr->omp_declare_target_link)
1446	return true;
1447
1448	attr->omp_declare_target_link = 1;
1449	return gfc_check_conflict (attr, name, where);
1450	}
1451
1452
1453	bool
1454	gfc_add_oacc_declare_create (symbol_attribute *attr, const char *name,
1455	locus *where)
1456	{
1457	if (check_used (attr, name, where))
1458	return false;
1459
1460	if (attr->oacc_declare_create)
1461	return true;
1462
1463	attr->oacc_declare_create = 1;
1464	return gfc_check_conflict (attr, name, where);
1465	}
1466
1467
1468	bool
1469	gfc_add_oacc_declare_copyin (symbol_attribute *attr, const char *name,
1470	locus *where)
1471	{
1472	if (check_used (attr, name, where))
1473	return false;
1474
1475	if (attr->oacc_declare_copyin)
1476	return true;
1477
1478	attr->oacc_declare_copyin = 1;
1479	return gfc_check_conflict (attr, name, where);
1480	}
1481
1482
1483	bool
1484	gfc_add_oacc_declare_deviceptr (symbol_attribute *attr, const char *name,
1485	locus *where)
1486	{
1487	if (check_used (attr, name, where))
1488	return false;
1489
1490	if (attr->oacc_declare_deviceptr)
1491	return true;
1492
1493	attr->oacc_declare_deviceptr = 1;
1494	return gfc_check_conflict (attr, name, where);
1495	}
1496
1497
1498	bool
1499	gfc_add_oacc_declare_device_resident (symbol_attribute *attr, const char *name,
1500	locus *where)
1501	{
1502	if (check_used (attr, name, where))
1503	return false;
1504
1505	if (attr->oacc_declare_device_resident)
1506	return true;
1507
1508	attr->oacc_declare_device_resident = 1;
1509	return gfc_check_conflict (attr, name, where);
1510	}
1511
1512
1513	bool
1514	gfc_add_target (symbol_attribute *attr, locus *where)
1515	{
1516
1517	if (check_used (attr, NULL, where))
1518	return false;
1519
1520	if (attr->target)
1521	{
1522	duplicate_attr (attr: "TARGET", where);
1523	return false;
1524	}
1525
1526	attr->target = 1;
1527	return gfc_check_conflict (attr, NULL, where);
1528	}
1529
1530
1531	bool
1532	gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1533	{
1534
1535	if (check_used (attr, name, where))
1536	return false;
1537
1538	/* Duplicate dummy arguments are allowed due to ENTRY statements. */
1539	attr->dummy = 1;
1540	return gfc_check_conflict (attr, name, where);
1541	}
1542
1543
1544	bool
1545	gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1546	{
1547
1548	if (check_used (attr, name, where))
1549	return false;
1550
1551	/* Duplicate attribute already checked for. */
1552	attr->in_common = 1;
1553	return gfc_check_conflict (attr, name, where);
1554	}
1555
1556
1557	bool
1558	gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1559	{
1560
1561	/* Duplicate attribute already checked for. */
1562	attr->in_equivalence = 1;
1563	if (!gfc_check_conflict (attr, name, where))
1564	return false;
1565
1566	if (attr->flavor == FL_VARIABLE)
1567	return true;
1568
1569	return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1570	}
1571
1572
1573	bool
1574	gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1575	{
1576
1577	if (check_used (attr, name, where))
1578	return false;
1579
1580	attr->data = 1;
1581	return gfc_check_conflict (attr, name, where);
1582	}
1583
1584
1585	bool
1586	gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1587	{
1588
1589	attr->in_namelist = 1;
1590	return gfc_check_conflict (attr, name, where);
1591	}
1592
1593
1594	bool
1595	gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1596	{
1597
1598	if (check_used (attr, name, where))
1599	return false;
1600
1601	attr->sequence = 1;
1602	return gfc_check_conflict (attr, name, where);
1603	}
1604
1605
1606	bool
1607	gfc_add_elemental (symbol_attribute *attr, locus *where)
1608	{
1609
1610	if (check_used (attr, NULL, where))
1611	return false;
1612
1613	if (attr->elemental)
1614	{
1615	duplicate_attr (attr: "ELEMENTAL", where);
1616	return false;
1617	}
1618
1619	attr->elemental = 1;
1620	return gfc_check_conflict (attr, NULL, where);
1621	}
1622
1623
1624	bool
1625	gfc_add_pure (symbol_attribute *attr, locus *where)
1626	{
1627
1628	if (check_used (attr, NULL, where))
1629	return false;
1630
1631	if (attr->pure)
1632	{
1633	duplicate_attr (attr: "PURE", where);
1634	return false;
1635	}
1636
1637	attr->pure = 1;
1638	return gfc_check_conflict (attr, NULL, where);
1639	}
1640
1641
1642	bool
1643	gfc_add_recursive (symbol_attribute *attr, locus *where)
1644	{
1645
1646	if (check_used (attr, NULL, where))
1647	return false;
1648
1649	if (attr->recursive)
1650	{
1651	duplicate_attr (attr: "RECURSIVE", where);
1652	return false;
1653	}
1654
1655	attr->recursive = 1;
1656	return gfc_check_conflict (attr, NULL, where);
1657	}
1658
1659
1660	bool
1661	gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1662	{
1663
1664	if (check_used (attr, name, where))
1665	return false;
1666
1667	if (attr->entry)
1668	{
1669	duplicate_attr (attr: "ENTRY", where);
1670	return false;
1671	}
1672
1673	attr->entry = 1;
1674	return gfc_check_conflict (attr, name, where);
1675	}
1676
1677
1678	bool
1679	gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1680	{
1681
1682	if (attr->flavor != FL_PROCEDURE
1683	&& !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1684	return false;
1685
1686	attr->function = 1;
1687	return gfc_check_conflict (attr, name, where);
1688	}
1689
1690
1691	bool
1692	gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1693	{
1694
1695	if (attr->flavor != FL_PROCEDURE
1696	&& !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1697	return false;
1698
1699	attr->subroutine = 1;
1700
1701	/* If we are looking at a BLOCK DATA statement and we encounter a
1702	name with a leading underscore (which must be
1703	compiler-generated), do not check. See PR 84394. */
1704
1705	if (name && *name != '_' && gfc_current_state () != COMP_BLOCK_DATA)
1706	return gfc_check_conflict (attr, name, where);
1707	else
1708	return true;
1709	}
1710
1711
1712	bool
1713	gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1714	{
1715
1716	if (attr->flavor != FL_PROCEDURE
1717	&& !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1718	return false;
1719
1720	attr->generic = 1;
1721	return gfc_check_conflict (attr, name, where);
1722	}
1723
1724
1725	bool
1726	gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1727	{
1728
1729	if (check_used (attr, NULL, where))
1730	return false;
1731
1732	if (attr->flavor != FL_PROCEDURE
1733	&& !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1734	return false;
1735
1736	if (attr->procedure)
1737	{
1738	duplicate_attr (attr: "PROCEDURE", where);
1739	return false;
1740	}
1741
1742	attr->procedure = 1;
1743
1744	return gfc_check_conflict (attr, NULL, where);
1745	}
1746
1747
1748	bool
1749	gfc_add_abstract (symbol_attribute* attr, locus* where)
1750	{
1751	if (attr->abstract)
1752	{
1753	duplicate_attr (attr: "ABSTRACT", where);
1754	return false;
1755	}
1756
1757	attr->abstract = 1;
1758
1759	return gfc_check_conflict (attr, NULL, where);
1760	}
1761
1762
1763	/* Flavors are special because some flavors are not what Fortran
1764	considers attributes and can be reaffirmed multiple times. */
1765
1766	bool
1767	gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1768	locus *where)
1769	{
1770
1771	if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1772	|| f == FL_PARAMETER || f == FL_LABEL || gfc_fl_struct(f)
1773	|| f == FL_NAMELIST) && check_used (attr, name, where))
1774	return false;
1775
1776	if (attr->flavor == f && f == FL_VARIABLE)
1777	return true;
1778
1779	/* Copying a procedure dummy argument for a module procedure in a
1780	submodule results in the flavor being copied and would result in
1781	an error without this. */
1782	if (attr->flavor == f && f == FL_PROCEDURE
1783	&& gfc_new_block && gfc_new_block->abr_modproc_decl)
1784	return true;
1785
1786	if (attr->flavor != FL_UNKNOWN)
1787	{
1788	if (where == NULL)
1789	where = &gfc_current_locus;
1790
1791	if (name)
1792	gfc_error ("%s attribute of %qs conflicts with %s attribute at %L",
1793	gfc_code2string (flavors, attr->flavor), name,
1794	gfc_code2string (flavors, f), where);
1795	else
1796	gfc_error ("%s attribute conflicts with %s attribute at %L",
1797	gfc_code2string (flavors, attr->flavor),
1798	gfc_code2string (flavors, f), where);
1799
1800	return false;
1801	}
1802
1803	attr->flavor = f;
1804
1805	return gfc_check_conflict (attr, name, where);
1806	}
1807
1808
1809	bool
1810	gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1811	const char *name, locus *where)
1812	{
1813
1814	if (check_used (attr, name, where))
1815	return false;
1816
1817	if (attr->flavor != FL_PROCEDURE
1818	&& !gfc_add_flavor (attr, f: FL_PROCEDURE, name, where))
1819	return false;
1820
1821	if (where == NULL)
1822	where = &gfc_current_locus;
1823
1824	if (attr->proc != PROC_UNKNOWN && !attr->module_procedure
1825	&& attr->access == ACCESS_UNKNOWN)
1826	{
1827	if (attr->proc == PROC_ST_FUNCTION && t == PROC_INTERNAL
1828	&& !gfc_notification_std (GFC_STD_F2008))
1829	gfc_error ("%s procedure at %L is already declared as %s "
1830	"procedure. \nF2008: A pointer function assignment "
1831	"is ambiguous if it is the first executable statement "
1832	"after the specification block. Please add any other "
1833	"kind of executable statement before it. FIXME",
1834	gfc_code2string (procedures, t), where,
1835	gfc_code2string (procedures, attr->proc));
1836	else
1837	gfc_error ("%s procedure at %L is already declared as %s "
1838	"procedure", gfc_code2string (procedures, t), where,
1839	gfc_code2string (procedures, attr->proc));
1840
1841	return false;
1842	}
1843
1844	attr->proc = t;
1845
1846	/* Statement functions are always scalar and functions. */
1847	if (t == PROC_ST_FUNCTION
1848	&& ((!attr->function && !gfc_add_function (attr, name, where))
1849	|| attr->dimension))
1850	return false;
1851
1852	return gfc_check_conflict (attr, name, where);
1853	}
1854
1855
1856	bool
1857	gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1858	{
1859
1860	if (check_used (attr, NULL, where))
1861	return false;
1862
1863	if (attr->intent == INTENT_UNKNOWN)
1864	{
1865	attr->intent = intent;
1866	return gfc_check_conflict (attr, NULL, where);
1867	}
1868
1869	if (where == NULL)
1870	where = &gfc_current_locus;
1871
1872	gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1873	gfc_intent_string (attr->intent),
1874	gfc_intent_string (intent), where);
1875
1876	return false;
1877	}
1878
1879
1880	/* No checks for use-association in public and private statements. */
1881
1882	bool
1883	gfc_add_access (symbol_attribute *attr, gfc_access access,
1884	const char *name, locus *where)
1885	{
1886
1887	if (attr->access == ACCESS_UNKNOWN
1888	|| (attr->use_assoc && attr->access != ACCESS_PRIVATE))
1889	{
1890	attr->access = access;
1891	return gfc_check_conflict (attr, name, where);
1892	}
1893
1894	if (where == NULL)
1895	where = &gfc_current_locus;
1896	gfc_error ("ACCESS specification at %L was already specified", where);
1897
1898	return false;
1899	}
1900
1901
1902	/* Set the is_bind_c field for the given symbol_attribute. */
1903
1904	bool
1905	gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1906	int is_proc_lang_bind_spec)
1907	{
1908
1909	if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1910	gfc_error_now ("BIND(C) attribute at %L can only be used for "
1911	"variables or common blocks", where);
1912	else if (attr->is_bind_c)
1913	gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1914	else
1915	attr->is_bind_c = 1;
1916
1917	if (where == NULL)
1918	where = &gfc_current_locus;
1919
1920	if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where))
1921	return false;
1922
1923	return gfc_check_conflict (attr, name, where);
1924	}
1925
1926
1927	/* Set the extension field for the given symbol_attribute. */
1928
1929	bool
1930	gfc_add_extension (symbol_attribute *attr, locus *where)
1931	{
1932	if (where == NULL)
1933	where = &gfc_current_locus;
1934
1935	if (attr->extension)
1936	gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1937	else
1938	attr->extension = 1;
1939
1940	if (!gfc_notify_std (GFC_STD_F2003, "EXTENDS at %L", where))
1941	return false;
1942
1943	return true;
1944	}
1945
1946
1947	bool
1948	gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1949	gfc_formal_arglist * formal, locus *where)
1950	{
1951	if (check_used (attr: &sym->attr, name: sym->name, where))
1952	return false;
1953
1954	/* Skip the following checks in the case of a module_procedures in a
1955	submodule since they will manifestly fail. */
1956	if (sym->attr.module_procedure == 1
1957	&& source == IFSRC_DECL)
1958	goto finish;
1959
1960	if (where == NULL)
1961	where = &gfc_current_locus;
1962
1963	if (sym->attr.if_source != IFSRC_UNKNOWN
1964	&& sym->attr.if_source != IFSRC_DECL)
1965	{
1966	gfc_error ("Symbol %qs at %L already has an explicit interface",
1967	sym->name, where);
1968	return false;
1969	}
1970
1971	if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1972	{
1973	gfc_error ("%qs at %L has attributes specified outside its INTERFACE "
1974	"body", sym->name, where);
1975	return false;
1976	}
1977
1978	finish:
1979	sym->formal = formal;
1980	sym->attr.if_source = source;
1981
1982	return true;
1983	}
1984
1985
1986	/* Add a type to a symbol. */
1987
1988	bool
1989	gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1990	{
1991	sym_flavor flavor;
1992	bt type;
1993
1994	if (where == NULL)
1995	where = &gfc_current_locus;
1996
1997	if (sym->result)
1998	type = sym->result->ts.type;
1999	else
2000	type = sym->ts.type;
2001
2002	if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
2003	type = sym->ns->proc_name->ts.type;
2004
2005	if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type)
2006	&& !(gfc_state_stack->previous && gfc_state_stack->previous->previous
2007	&& gfc_state_stack->previous->previous->state == COMP_SUBMODULE)
2008	&& !sym->attr.module_procedure)
2009	{
2010	if (sym->attr.use_assoc)
2011	gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, "
2012	"use-associated at %L", sym->name, where, sym->module,
2013	&sym->declared_at);
2014	else if (sym->attr.function && sym->attr.result)
2015	gfc_error ("Symbol %qs at %L already has basic type of %s",
2016	sym->ns->proc_name->name, where, gfc_basic_typename (type));
2017	else
2018	gfc_error ("Symbol %qs at %L already has basic type of %s", sym->name,
2019	where, gfc_basic_typename (type));
2020	return false;
2021	}
2022
2023	if (sym->attr.procedure && sym->ts.interface)
2024	{
2025	gfc_error ("Procedure %qs at %L may not have basic type of %s",
2026	sym->name, where, gfc_basic_typename (ts->type));
2027	return false;
2028	}
2029
2030	flavor = sym->attr.flavor;
2031
2032	if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
2033	|| flavor == FL_LABEL
2034	|| (flavor == FL_PROCEDURE && sym->attr.subroutine)
2035	|| flavor == FL_DERIVED || flavor == FL_NAMELIST)
2036	{
2037	gfc_error ("Symbol %qs at %L cannot have a type",
2038	sym->ns->proc_name ? sym->ns->proc_name->name : sym->name,
2039	where);
2040	return false;
2041	}
2042
2043	sym->ts = *ts;
2044	return true;
2045	}
2046
2047
2048	/* Clears all attributes. */
2049
2050	void
2051	gfc_clear_attr (symbol_attribute *attr)
2052	{
2053	memset (s: attr, c: 0, n: sizeof (symbol_attribute));
2054	}
2055
2056
2057	/* Check for missing attributes in the new symbol. Currently does
2058	nothing, but it's not clear that it is unnecessary yet. */
2059
2060	bool
2061	gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
2062	locus *where ATTRIBUTE_UNUSED)
2063	{
2064
2065	return true;
2066	}
2067
2068
2069	/* Copy an attribute to a symbol attribute, bit by bit. Some
2070	attributes have a lot of side-effects but cannot be present given
2071	where we are called from, so we ignore some bits. */
2072
2073	bool
2074	gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
2075	{
2076	int is_proc_lang_bind_spec;
2077
2078	/* In line with the other attributes, we only add bits but do not remove
2079	them; cf. also PR 41034. */
2080	dest->ext_attr |= src->ext_attr;
2081
2082	if (src->allocatable && !gfc_add_allocatable (attr: dest, where))
2083	goto fail;
2084
2085	if (src->automatic && !gfc_add_automatic (attr: dest, NULL, where))
2086	goto fail;
2087	if (src->dimension && !gfc_add_dimension (attr: dest, NULL, where))
2088	goto fail;
2089	if (src->codimension && !gfc_add_codimension (attr: dest, NULL, where))
2090	goto fail;
2091	if (src->contiguous && !gfc_add_contiguous (attr: dest, NULL, where))
2092	goto fail;
2093	if (src->optional && !gfc_add_optional (attr: dest, where))
2094	goto fail;
2095	if (src->pointer && !gfc_add_pointer (attr: dest, where))
2096	goto fail;
2097	if (src->is_protected && !gfc_add_protected (attr: dest, NULL, where))
2098	goto fail;
2099	if (src->save && !gfc_add_save (attr: dest, s: src->save, NULL, where))
2100	goto fail;
2101	if (src->value && !gfc_add_value (attr: dest, NULL, where))
2102	goto fail;
2103	if (src->volatile_ && !gfc_add_volatile (attr: dest, NULL, where))
2104	goto fail;
2105	if (src->asynchronous && !gfc_add_asynchronous (attr: dest, NULL, where))
2106	goto fail;
2107	if (src->threadprivate
2108	&& !gfc_add_threadprivate (attr: dest, NULL, where))
2109	goto fail;
2110	if (src->omp_declare_target
2111	&& !gfc_add_omp_declare_target (attr: dest, NULL, where))
2112	goto fail;
2113	if (src->omp_declare_target_link
2114	&& !gfc_add_omp_declare_target_link (attr: dest, NULL, where))
2115	goto fail;
2116	if (src->oacc_declare_create
2117	&& !gfc_add_oacc_declare_create (attr: dest, NULL, where))
2118	goto fail;
2119	if (src->oacc_declare_copyin
2120	&& !gfc_add_oacc_declare_copyin (attr: dest, NULL, where))
2121	goto fail;
2122	if (src->oacc_declare_deviceptr
2123	&& !gfc_add_oacc_declare_deviceptr (attr: dest, NULL, where))
2124	goto fail;
2125	if (src->oacc_declare_device_resident
2126	&& !gfc_add_oacc_declare_device_resident (attr: dest, NULL, where))
2127	goto fail;
2128	if (src->target && !gfc_add_target (attr: dest, where))
2129	goto fail;
2130	if (src->dummy && !gfc_add_dummy (attr: dest, NULL, where))
2131	goto fail;
2132	if (src->result && !gfc_add_result (attr: dest, NULL, where))
2133	goto fail;
2134	if (src->entry)
2135	dest->entry = 1;
2136
2137	if (src->in_namelist && !gfc_add_in_namelist (attr: dest, NULL, where))
2138	goto fail;
2139
2140	if (src->in_common && !gfc_add_in_common (attr: dest, NULL, where))
2141	goto fail;
2142
2143	if (src->generic && !gfc_add_generic (attr: dest, NULL, where))
2144	goto fail;
2145	if (src->function && !gfc_add_function (attr: dest, NULL, where))
2146	goto fail;
2147	if (src->subroutine && !gfc_add_subroutine (attr: dest, NULL, where))
2148	goto fail;
2149
2150	if (src->sequence && !gfc_add_sequence (attr: dest, NULL, where))
2151	goto fail;
2152	if (src->elemental && !gfc_add_elemental (attr: dest, where))
2153	goto fail;
2154	if (src->pure && !gfc_add_pure (attr: dest, where))
2155	goto fail;
2156	if (src->recursive && !gfc_add_recursive (attr: dest, where))
2157	goto fail;
2158
2159	if (src->flavor != FL_UNKNOWN
2160	&& !gfc_add_flavor (attr: dest, f: src->flavor, NULL, where))
2161	goto fail;
2162
2163	if (src->intent != INTENT_UNKNOWN
2164	&& !gfc_add_intent (attr: dest, intent: src->intent, where))
2165	goto fail;
2166
2167	if (src->access != ACCESS_UNKNOWN
2168	&& !gfc_add_access (attr: dest, access: src->access, NULL, where))
2169	goto fail;
2170
2171	if (!gfc_missing_attr (attr: dest, where))
2172	goto fail;
2173
2174	if (src->cray_pointer && !gfc_add_cray_pointer (attr: dest, where))
2175	goto fail;
2176	if (src->cray_pointee && !gfc_add_cray_pointee (attr: dest, where))
2177	goto fail;
2178
2179	is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
2180	if (src->is_bind_c
2181	&& !gfc_add_is_bind_c (attr: dest, NULL, where, is_proc_lang_bind_spec))
2182	return false;
2183
2184	if (src->is_c_interop)
2185	dest->is_c_interop = 1;
2186	if (src->is_iso_c)
2187	dest->is_iso_c = 1;
2188
2189	if (src->external && !gfc_add_external (attr: dest, where))
2190	goto fail;
2191	if (src->intrinsic && !gfc_add_intrinsic (attr: dest, where))
2192	goto fail;
2193	if (src->proc_pointer)
2194	dest->proc_pointer = 1;
2195
2196	return true;
2197
2198	fail:
2199	return false;
2200	}
2201
2202
2203	/* A function to generate a dummy argument symbol using that from the
2204	interface declaration. Can be used for the result symbol as well if
2205	the flag is set. */
2206
2207	int
2208	gfc_copy_dummy_sym (gfc_symbol **dsym, gfc_symbol *sym, int result)
2209	{
2210	int rc;
2211
2212	rc = gfc_get_symbol (sym->name, NULL, dsym);
2213	if (rc)
2214	return rc;
2215
2216	if (!gfc_add_type (sym: *dsym, ts: &(sym->ts), where: &gfc_current_locus))
2217	return 1;
2218
2219	if (!gfc_copy_attr (dest: &(*dsym)->attr, src: &(sym->attr),
2220	where: &gfc_current_locus))
2221	return 1;
2222
2223	if ((*dsym)->attr.dimension)
2224	(*dsym)->as = gfc_copy_array_spec (sym->as);
2225
2226	(*dsym)->attr.class_ok = sym->attr.class_ok;
2227
2228	if ((*dsym) != NULL && !result
2229	&& (!gfc_add_dummy(attr: &(*dsym)->attr, name: (*dsym)->name, NULL)
2230	|| !gfc_missing_attr (attr: &(*dsym)->attr, NULL)))
2231	return 1;
2232	else if ((*dsym) != NULL && result
2233	&& (!gfc_add_result(attr: &(*dsym)->attr, name: (*dsym)->name, NULL)
2234	|| !gfc_missing_attr (attr: &(*dsym)->attr, NULL)))
2235	return 1;
2236
2237	return 0;
2238	}
2239
2240
2241	/************** Component name management ************/
2242
2243	/* Component names of a derived type form their own little namespaces
2244	that are separate from all other spaces. The space is composed of
2245	a singly linked list of gfc_component structures whose head is
2246	located in the parent symbol. */
2247
2248
2249	/* Add a component name to a symbol. The call fails if the name is
2250	already present. On success, the component pointer is modified to
2251	point to the additional component structure. */
2252
2253	bool
2254	gfc_add_component (gfc_symbol *sym, const char *name,
2255	gfc_component **component)
2256	{
2257	gfc_component *p, *tail;
2258
2259	/* Check for existing components with the same name, but not for union
2260	components or containers. Unions and maps are anonymous so they have
2261	unique internal names which will never conflict.
2262	Don't use gfc_find_component here because it calls gfc_use_derived,
2263	but the derived type may not be fully defined yet. */
2264	tail = NULL;
2265
2266	for (p = sym->components; p; p = p->next)
2267	{
2268	if (strcmp (s1: p->name, s2: name) == 0)
2269	{
2270	gfc_error ("Component %qs at %C already declared at %L",
2271	name, &p->loc);
2272	return false;
2273	}
2274
2275	tail = p;
2276	}
2277
2278	if (sym->attr.extension
2279	&& gfc_find_component (sym->components->ts.u.derived,
2280	name, true, true, NULL))
2281	{
2282	gfc_error ("Component %qs at %C already in the parent type "
2283	"at %L", name, &sym->components->ts.u.derived->declared_at);
2284	return false;
2285	}
2286
2287	/* Allocate a new component. */
2288	p = gfc_get_component ();
2289
2290	if (tail == NULL)
2291	sym->components = p;
2292	else
2293	tail->next = p;
2294
2295	p->name = gfc_get_string ("%s", name);
2296	p->loc = gfc_current_locus;
2297	p->ts.type = BT_UNKNOWN;
2298
2299	*component = p;
2300	return true;
2301	}
2302
2303
2304	/* Recursive function to switch derived types of all symbol in a
2305	namespace. */
2306
2307	static void
2308	switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
2309	{
2310	gfc_symbol *sym;
2311
2312	if (st == NULL)
2313	return;
2314
2315	sym = st->n.sym;
2316	if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
2317	sym->ts.u.derived = to;
2318
2319	switch_types (st: st->left, from, to);
2320	switch_types (st: st->right, from, to);
2321	}
2322
2323
2324	/* This subroutine is called when a derived type is used in order to
2325	make the final determination about which version to use. The
2326	standard requires that a type be defined before it is 'used', but
2327	such types can appear in IMPLICIT statements before the actual
2328	definition. 'Using' in this context means declaring a variable to
2329	be that type or using the type constructor.
2330
2331	If a type is used and the components haven't been defined, then we
2332	have to have a derived type in a parent unit. We find the node in
2333	the other namespace and point the symtree node in this namespace to
2334	that node. Further reference to this name point to the correct
2335	node. If we can't find the node in a parent namespace, then we have
2336	an error.
2337
2338	This subroutine takes a pointer to a symbol node and returns a
2339	pointer to the translated node or NULL for an error. Usually there
2340	is no translation and we return the node we were passed. */
2341
2342	gfc_symbol *
2343	gfc_use_derived (gfc_symbol *sym)
2344	{
2345	gfc_symbol *s;
2346	gfc_typespec *t;
2347	gfc_symtree *st;
2348	int i;
2349
2350	if (!sym)
2351	return NULL;
2352
2353	if (sym->attr.unlimited_polymorphic)
2354	return sym;
2355
2356	if (sym->attr.generic)
2357	sym = gfc_find_dt_in_generic (sym);
2358
2359	if (sym->components != NULL || sym->attr.zero_comp)
2360	return sym; /* Already defined. */
2361
2362	if (sym->ns->parent == NULL)
2363	goto bad;
2364
2365	if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
2366	{
2367	gfc_error ("Symbol %qs at %C is ambiguous", sym->name);
2368	return NULL;
2369	}
2370
2371	if (s == NULL || !gfc_fl_struct (s->attr.flavor))
2372	goto bad;
2373
2374	/* Get rid of symbol sym, translating all references to s. */
2375	for (i = 0; i < GFC_LETTERS; i++)
2376	{
2377	t = &sym->ns->default_type[i];
2378	if (t->u.derived == sym)
2379	t->u.derived = s;
2380	}
2381
2382	st = gfc_find_symtree (sym->ns->sym_root, sym->name);
2383	st->n.sym = s;
2384
2385	s->refs++;
2386
2387	/* Unlink from list of modified symbols. */
2388	gfc_commit_symbol (sym);
2389
2390	switch_types (st: sym->ns->sym_root, from: sym, to: s);
2391
2392	/* TODO: Also have to replace sym -> s in other lists like
2393	namelists, common lists and interface lists. */
2394	gfc_free_symbol (sym);
2395
2396	return s;
2397
2398	bad:
2399	gfc_error ("Derived type %qs at %C is being used before it is defined",
2400	sym->name);
2401	return NULL;
2402	}
2403
2404
2405	/* Find the component with the given name in the union type symbol.
2406	If ref is not NULL it will be set to the chain of components through which
2407	the component can actually be accessed. This is necessary for unions because
2408	intermediate structures may be maps, nested structures, or other unions,
2409	all of which may (or must) be 'anonymous' to user code. */
2410
2411	static gfc_component *
2412	find_union_component (gfc_symbol *un, const char *name,
2413	bool noaccess, gfc_ref **ref)
2414	{
2415	gfc_component *m, *check;
2416	gfc_ref *sref, *tmp;
2417
2418	for (m = un->components; m; m = m->next)
2419	{
2420	check = gfc_find_component (m->ts.u.derived, name, noaccess, true, &tmp);
2421	if (check == NULL)
2422	continue;
2423
2424	/* Found component somewhere in m; chain the refs together. */
2425	if (ref)
2426	{
2427	/* Map ref. */
2428	sref = gfc_get_ref ();
2429	sref->type = REF_COMPONENT;
2430	sref->u.c.component = m;
2431	sref->u.c.sym = m->ts.u.derived;
2432	sref->next = tmp;
2433
2434	*ref = sref;
2435	}
2436	/* Other checks (such as access) were done in the recursive calls. */
2437	return check;
2438	}
2439	return NULL;
2440	}
2441
2442
2443	/* Recursively append candidate COMPONENT structures to CANDIDATES. Store
2444	the number of total candidates in CANDIDATES_LEN. */
2445
2446	static void
2447	lookup_component_fuzzy_find_candidates (gfc_component *component,
2448	char **&candidates,
2449	size_t &candidates_len)
2450	{
2451	for (gfc_component *p = component; p; p = p->next)
2452	vec_push (optr&: candidates, osz&: candidates_len, elt: p->name);
2453	}
2454
2455
2456	/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */
2457
2458	static const char*
2459	lookup_component_fuzzy (const char *member, gfc_component *component)
2460	{
2461	char **candidates = NULL;
2462	size_t candidates_len = 0;
2463	lookup_component_fuzzy_find_candidates (component, candidates,
2464	candidates_len);
2465	return gfc_closest_fuzzy_match (member, candidates);
2466	}
2467
2468
2469	/* Given a derived type node and a component name, try to locate the
2470	component structure. Returns the NULL pointer if the component is
2471	not found or the components are private. If noaccess is set, no access
2472	checks are done. If silent is set, an error will not be generated if
2473	the component cannot be found or accessed.
2474
2475	If ref is not NULL, *ref is set to represent the chain of components
2476	required to get to the ultimate component.
2477
2478	If the component is simply a direct subcomponent, or is inherited from a
2479	parent derived type in the given derived type, this is a single ref with its
2480	component set to the returned component.
2481
2482	Otherwise, *ref is constructed as a chain of subcomponents. This occurs
2483	when the component is found through an implicit chain of nested union and
2484	map components. Unions and maps are "anonymous" substructures in FORTRAN
2485	which cannot be explicitly referenced, but the reference chain must be
2486	considered as in C for backend translation to correctly compute layouts.
2487	(For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a). */
2488
2489	gfc_component *
2490	gfc_find_component (gfc_symbol *sym, const char *name,
2491	bool noaccess, bool silent, gfc_ref **ref)
2492	{
2493	gfc_component *p, *check;
2494	gfc_ref *sref = NULL, *tmp = NULL;
2495
2496	if (name == NULL || sym == NULL)
2497	return NULL;
2498
2499	if (sym->attr.flavor == FL_DERIVED)
2500	sym = gfc_use_derived (sym);
2501	else
2502	gcc_assert (gfc_fl_struct (sym->attr.flavor));
2503
2504	if (sym == NULL)
2505	return NULL;
2506
2507	/* Handle UNIONs specially - mutually recursive with gfc_find_component. */
2508	if (sym->attr.flavor == FL_UNION)
2509	return find_union_component (un: sym, name, noaccess, ref);
2510
2511	if (ref) *ref = NULL;
2512	for (p = sym->components; p; p = p->next)
2513	{
2514	/* Nest search into union's maps. */
2515	if (p->ts.type == BT_UNION)
2516	{
2517	check = find_union_component (un: p->ts.u.derived, name, noaccess, ref: &tmp);
2518	if (check != NULL)
2519	{
2520	/* Union ref. */
2521	if (ref)
2522	{
2523	sref = gfc_get_ref ();
2524	sref->type = REF_COMPONENT;
2525	sref->u.c.component = p;
2526	sref->u.c.sym = p->ts.u.derived;
2527	sref->next = tmp;
2528	*ref = sref;
2529	}
2530	return check;
2531	}
2532	}
2533	else if (strcmp (s1: p->name, s2: name) == 0)
2534	break;
2535
2536	continue;
2537	}
2538
2539	if (p && sym->attr.use_assoc && !noaccess)
2540	{
2541	bool is_parent_comp = sym->attr.extension && (p == sym->components);
2542	if (p->attr.access == ACCESS_PRIVATE ||
2543	(p->attr.access != ACCESS_PUBLIC
2544	&& sym->component_access == ACCESS_PRIVATE
2545	&& !is_parent_comp))
2546	{
2547	if (!silent)
2548	gfc_error ("Component %qs at %C is a PRIVATE component of %qs",
2549	name, sym->name);
2550	return NULL;
2551	}
2552	}
2553
2554	if (p == NULL
2555	&& sym->attr.extension
2556	&& sym->components->ts.type == BT_DERIVED)
2557	{
2558	p = gfc_find_component (sym: sym->components->ts.u.derived, name,
2559	noaccess, silent, ref);
2560	/* Do not overwrite the error. */
2561	if (p == NULL)
2562	return p;
2563	}
2564
2565	if (p == NULL && !silent)
2566	{
2567	const char *guessed = lookup_component_fuzzy (member: name, component: sym->components);
2568	if (guessed)
2569	gfc_error ("%qs at %C is not a member of the %qs structure"
2570	"; did you mean %qs?",
2571	name, sym->name, guessed);
2572	else
2573	gfc_error ("%qs at %C is not a member of the %qs structure",
2574	name, sym->name);
2575	}
2576
2577	/* Component was found; build the ultimate component reference. */
2578	if (p != NULL && ref)
2579	{
2580	tmp = gfc_get_ref ();
2581	tmp->type = REF_COMPONENT;
2582	tmp->u.c.component = p;
2583	tmp->u.c.sym = sym;
2584	/* Link the final component ref to the end of the chain of subrefs. */
2585	if (sref)
2586	{
2587	*ref = sref;
2588	for (; sref->next; sref = sref->next)
2589	;
2590	sref->next = tmp;
2591	}
2592	else
2593	*ref = tmp;
2594	}
2595
2596	return p;
2597	}
2598
2599
2600	/* Given a symbol, free all of the component structures and everything
2601	they point to. */
2602
2603	static void
2604	free_components (gfc_component *p)
2605	{
2606	gfc_component *q;
2607
2608	for (; p; p = q)
2609	{
2610	q = p->next;
2611
2612	gfc_free_array_spec (p->as);
2613	gfc_free_expr (p->initializer);
2614	if (p->kind_expr)
2615	gfc_free_expr (p->kind_expr);
2616	if (p->param_list)
2617	gfc_free_actual_arglist (p->param_list);
2618	free (ptr: p->tb);
2619	p->tb = NULL;
2620	free (ptr: p);
2621	}
2622	}
2623
2624
2625	/******************** Statement label management ********************/
2626
2627	/* Comparison function for statement labels, used for managing the
2628	binary tree. */
2629
2630	static int
2631	compare_st_labels (void *a1, void *b1)
2632	{
2633	int a = ((gfc_st_label *) a1)->value;
2634	int b = ((gfc_st_label *) b1)->value;
2635
2636	return (b - a);
2637	}
2638
2639
2640	/* Free a single gfc_st_label structure, making sure the tree is not
2641	messed up. This function is called only when some parse error
2642	occurs. */
2643
2644	void
2645	gfc_free_st_label (gfc_st_label *label)
2646	{
2647
2648	if (label == NULL)
2649	return;
2650
2651	gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels);
2652
2653	if (label->format != NULL)
2654	gfc_free_expr (label->format);
2655
2656	free (ptr: label);
2657	}
2658
2659
2660	/* Free a whole tree of gfc_st_label structures. */
2661
2662	static void
2663	free_st_labels (gfc_st_label *label)
2664	{
2665
2666	if (label == NULL)
2667	return;
2668
2669	free_st_labels (label: label->left);
2670	free_st_labels (label: label->right);
2671
2672	if (label->format != NULL)
2673	gfc_free_expr (label->format);
2674	free (ptr: label);
2675	}
2676
2677
2678	/* Given a label number, search for and return a pointer to the label
2679	structure, creating it if it does not exist. */
2680
2681	gfc_st_label *
2682	gfc_get_st_label (int labelno)
2683	{
2684	gfc_st_label *lp;
2685	gfc_namespace *ns;
2686
2687	if (gfc_current_state () == COMP_DERIVED)
2688	ns = gfc_current_block ()->f2k_derived;
2689	else
2690	{
2691	/* Find the namespace of the scoping unit:
2692	If we're in a BLOCK construct, jump to the parent namespace. */
2693	ns = gfc_current_ns;
2694	while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
2695	ns = ns->parent;
2696	}
2697
2698	/* First see if the label is already in this namespace. */
2699	lp = ns->st_labels;
2700	while (lp)
2701	{
2702	if (lp->value == labelno)
2703	return lp;
2704
2705	if (lp->value < labelno)
2706	lp = lp->left;
2707	else
2708	lp = lp->right;
2709	}
2710
2711	lp = XCNEW (gfc_st_label);
2712
2713	lp->value = labelno;
2714	lp->defined = ST_LABEL_UNKNOWN;
2715	lp->referenced = ST_LABEL_UNKNOWN;
2716	lp->ns = ns;
2717
2718	gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
2719
2720	return lp;
2721	}
2722
2723
2724	/* Called when a statement with a statement label is about to be
2725	accepted. We add the label to the list of the current namespace,
2726	making sure it hasn't been defined previously and referenced
2727	correctly. */
2728
2729	void
2730	gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2731	{
2732	int labelno;
2733
2734	labelno = lp->value;
2735
2736	if (lp->defined != ST_LABEL_UNKNOWN)
2737	gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2738	&lp->where, label_locus);
2739	else
2740	{
2741	lp->where = *label_locus;
2742
2743	switch (type)
2744	{
2745	case ST_LABEL_FORMAT:
2746	if (lp->referenced == ST_LABEL_TARGET
2747	|| lp->referenced == ST_LABEL_DO_TARGET)
2748	gfc_error ("Label %d at %C already referenced as branch target",
2749	labelno);
2750	else
2751	lp->defined = ST_LABEL_FORMAT;
2752
2753	break;
2754
2755	case ST_LABEL_TARGET:
2756	case ST_LABEL_DO_TARGET:
2757	if (lp->referenced == ST_LABEL_FORMAT)
2758	gfc_error ("Label %d at %C already referenced as a format label",
2759	labelno);
2760	else
2761	lp->defined = type;
2762
2763	if (lp->referenced == ST_LABEL_DO_TARGET && type != ST_LABEL_DO_TARGET
2764	&& !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
2765	"DO termination statement which is not END DO"
2766	" or CONTINUE with label %d at %C", labelno))
2767	return;
2768	break;
2769
2770	default:
2771	lp->defined = ST_LABEL_BAD_TARGET;
2772	lp->referenced = ST_LABEL_BAD_TARGET;
2773	}
2774	}
2775	}
2776
2777
2778	/* Reference a label. Given a label and its type, see if that
2779	reference is consistent with what is known about that label,
2780	updating the unknown state. Returns false if something goes
2781	wrong. */
2782
2783	bool
2784	gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2785	{
2786	gfc_sl_type label_type;
2787	int labelno;
2788	bool rc;
2789
2790	if (lp == NULL)
2791	return true;
2792
2793	labelno = lp->value;
2794
2795	if (lp->defined != ST_LABEL_UNKNOWN)
2796	label_type = lp->defined;
2797	else
2798	{
2799	label_type = lp->referenced;
2800	lp->where = gfc_current_locus;
2801	}
2802
2803	if (label_type == ST_LABEL_FORMAT
2804	&& (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET))
2805	{
2806	gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2807	rc = false;
2808	goto done;
2809	}
2810
2811	if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET
2812	|| label_type == ST_LABEL_BAD_TARGET)
2813	&& type == ST_LABEL_FORMAT)
2814	{
2815	gfc_error ("Label %d at %C previously used as branch target", labelno);
2816	rc = false;
2817	goto done;
2818	}
2819
2820	if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET
2821	&& !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
2822	"Shared DO termination label %d at %C", labelno))
2823	return false;
2824
2825	if (type == ST_LABEL_DO_TARGET
2826	&& !gfc_notify_std (GFC_STD_F2018_OBS, "Labeled DO statement "
2827	"at %L", &gfc_current_locus))
2828	return false;
2829
2830	if (lp->referenced != ST_LABEL_DO_TARGET)
2831	lp->referenced = type;
2832	rc = true;
2833
2834	done:
2835	return rc;
2836	}
2837
2838
2839	/************** Symbol table management subroutines ****************/
2840
2841	/* Basic details: Fortran 95 requires a potentially unlimited number
2842	of distinct namespaces when compiling a program unit. This case
2843	occurs during a compilation of internal subprograms because all of
2844	the internal subprograms must be read before we can start
2845	generating code for the host.
2846
2847	Given the tricky nature of the Fortran grammar, we must be able to
2848	undo changes made to a symbol table if the current interpretation
2849	of a statement is found to be incorrect. Whenever a symbol is
2850	looked up, we make a copy of it and link to it. All of these
2851	symbols are kept in a vector so that we can commit or
2852	undo the changes at a later time.
2853
2854	A symtree may point to a symbol node outside of its namespace. In
2855	this case, that symbol has been used as a host associated variable
2856	at some previous time. */
2857
2858	/* Allocate a new namespace structure. Copies the implicit types from
2859	PARENT if PARENT_TYPES is set. */
2860
2861	gfc_namespace *
2862	gfc_get_namespace (gfc_namespace *parent, int parent_types)
2863	{
2864	gfc_namespace *ns;
2865	gfc_typespec *ts;
2866	int in;
2867	int i;
2868
2869	ns = XCNEW (gfc_namespace);
2870	ns->sym_root = NULL;
2871	ns->uop_root = NULL;
2872	ns->tb_sym_root = NULL;
2873	ns->finalizers = NULL;
2874	ns->default_access = ACCESS_UNKNOWN;
2875	ns->parent = parent;
2876
2877	for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2878	{
2879	ns->operator_access[in] = ACCESS_UNKNOWN;
2880	ns->tb_op[in] = NULL;
2881	}
2882
2883	/* Initialize default implicit types. */
2884	for (i = 'a'; i <= 'z'; i++)
2885	{
2886	ns->set_flag[i - 'a'] = 0;
2887	ts = &ns->default_type[i - 'a'];
2888
2889	if (parent_types && ns->parent != NULL)
2890	{
2891	/* Copy parent settings. */
2892	*ts = ns->parent->default_type[i - 'a'];
2893	continue;
2894	}
2895
2896	if (flag_implicit_none != 0)
2897	{
2898	gfc_clear_ts (ts);
2899	continue;
2900	}
2901
2902	if ('i' <= i && i <= 'n')
2903	{
2904	ts->type = BT_INTEGER;
2905	ts->kind = gfc_default_integer_kind;
2906	}
2907	else
2908	{
2909	ts->type = BT_REAL;
2910	ts->kind = gfc_default_real_kind;
2911	}
2912	}
2913
2914	ns->refs = 1;
2915
2916	return ns;
2917	}
2918
2919
2920	/* Comparison function for symtree nodes. */
2921
2922	static int
2923	compare_symtree (void *_st1, void *_st2)
2924	{
2925	gfc_symtree *st1, *st2;
2926
2927	st1 = (gfc_symtree *) _st1;
2928	st2 = (gfc_symtree *) _st2;
2929
2930	return strcmp (s1: st1->name, s2: st2->name);
2931	}
2932
2933
2934	/* Allocate a new symtree node and associate it with the new symbol. */
2935
2936	gfc_symtree *
2937	gfc_new_symtree (gfc_symtree **root, const char *name)
2938	{
2939	gfc_symtree *st;
2940
2941	st = XCNEW (gfc_symtree);
2942	st->name = gfc_get_string ("%s", name);
2943
2944	gfc_insert_bbt (root, st, compare_symtree);
2945	return st;
2946	}
2947
2948
2949	/* Delete a symbol from the tree. Does not free the symbol itself! */
2950
2951	static void
2952	gfc_delete_symtree (gfc_symtree **root, const char *name)
2953	{
2954	gfc_symtree st, *st0;
2955	const char *p;
2956
2957	/* Submodules are marked as mod.submod. When freeing a submodule
2958	symbol, the symtree only has "submod", so adjust that here. */
2959
2960	p = strrchr(s: name, c: '.');
2961	if (p)
2962	p++;
2963	else
2964	p = name;
2965
2966	st.name = gfc_get_string ("%s", p);
2967	st0 = (gfc_symtree *) gfc_delete_bbt (root, &st, compare_symtree);
2968
2969	free (ptr: st0);
2970	}
2971
2972
2973	/* Given a root symtree node and a name, try to find the symbol within
2974	the namespace. Returns NULL if the symbol is not found. */
2975
2976	gfc_symtree *
2977	gfc_find_symtree (gfc_symtree *st, const char *name)
2978	{
2979	int c;
2980
2981	while (st != NULL)
2982	{
2983	c = strcmp (s1: name, s2: st->name);
2984	if (c == 0)
2985	return st;
2986
2987	st = (c < 0) ? st->left : st->right;
2988	}
2989
2990	return NULL;
2991	}
2992
2993
2994	/* Return a symtree node with a name that is guaranteed to be unique
2995	within the namespace and corresponds to an illegal fortran name. */
2996
2997	gfc_symtree *
2998	gfc_get_unique_symtree (gfc_namespace *ns)
2999	{
3000	char name[GFC_MAX_SYMBOL_LEN + 1];
3001	static int serial = 0;
3002
3003	sprintf (s: name, format: "@%d", serial++);
3004	return gfc_new_symtree (root: &ns->sym_root, name);
3005	}
3006
3007
3008	/* Given a name find a user operator node, creating it if it doesn't
3009	exist. These are much simpler than symbols because they can't be
3010	ambiguous with one another. */
3011
3012	gfc_user_op *
3013	gfc_get_uop (const char *name)
3014	{
3015	gfc_user_op *uop;
3016	gfc_symtree *st;
3017	gfc_namespace *ns = gfc_current_ns;
3018
3019	if (ns->omp_udr_ns)
3020	ns = ns->parent;
3021	st = gfc_find_symtree (st: ns->uop_root, name);
3022	if (st != NULL)
3023	return st->n.uop;
3024
3025	st = gfc_new_symtree (root: &ns->uop_root, name);
3026
3027	uop = st->n.uop = XCNEW (gfc_user_op);
3028	uop->name = gfc_get_string ("%s", name);
3029	uop->access = ACCESS_UNKNOWN;
3030	uop->ns = ns;
3031
3032	return uop;
3033	}
3034
3035
3036	/* Given a name find the user operator node. Returns NULL if it does
3037	not exist. */
3038
3039	gfc_user_op *
3040	gfc_find_uop (const char *name, gfc_namespace *ns)
3041	{
3042	gfc_symtree *st;
3043
3044	if (ns == NULL)
3045	ns = gfc_current_ns;
3046
3047	st = gfc_find_symtree (st: ns->uop_root, name);
3048	return (st == NULL) ? NULL : st->n.uop;
3049	}
3050
3051
3052	/* Update a symbol's common_block field, and take care of the associated
3053	memory management. */
3054
3055	static void
3056	set_symbol_common_block (gfc_symbol *sym, gfc_common_head *common_block)
3057	{
3058	if (sym->common_block == common_block)
3059	return;
3060
3061	if (sym->common_block && sym->common_block->name[0] != '\0')
3062	{
3063	sym->common_block->refs--;
3064	if (sym->common_block->refs == 0)
3065	free (ptr: sym->common_block);
3066	}
3067	sym->common_block = common_block;
3068	}
3069
3070
3071	/* Remove a gfc_symbol structure and everything it points to. */
3072
3073	void
3074	gfc_free_symbol (gfc_symbol *&sym)
3075	{
3076
3077	if (sym == NULL)
3078	return;
3079
3080	gfc_free_array_spec (sym->as);
3081
3082	free_components (p: sym->components);
3083
3084	gfc_free_expr (sym->value);
3085
3086	gfc_free_namelist (sym->namelist);
3087
3088	if (sym->ns != sym->formal_ns)
3089	gfc_free_namespace (sym->formal_ns);
3090
3091	if (!sym->attr.generic_copy)
3092	gfc_free_interface (sym->generic);
3093
3094	gfc_free_formal_arglist (sym->formal);
3095
3096	gfc_free_namespace (sym->f2k_derived);
3097
3098	set_symbol_common_block (sym, NULL);
3099
3100	if (sym->param_list)
3101	gfc_free_actual_arglist (sym->param_list);
3102
3103	free (ptr: sym);
3104	sym = NULL;
3105	}
3106
3107
3108	/* Decrease the reference counter and free memory when we reach zero.
3109	Returns true if the symbol has been freed, false otherwise. */
3110
3111	bool
3112	gfc_release_symbol (gfc_symbol *&sym)
3113	{
3114	if (sym == NULL)
3115	return false;
3116
3117	if (sym->formal_ns != NULL && sym->refs == 2 && sym->formal_ns != sym->ns
3118	&& (!sym->attr.entry || !sym->module))
3119	{
3120	/* As formal_ns contains a reference to sym, delete formal_ns just
3121	before the deletion of sym. */
3122	gfc_namespace *ns = sym->formal_ns;
3123	sym->formal_ns = NULL;
3124	gfc_free_namespace (ns);
3125	}
3126
3127	sym->refs--;
3128	if (sym->refs > 0)
3129	return false;
3130
3131	gcc_assert (sym->refs == 0);
3132	gfc_free_symbol (sym);
3133	return true;
3134	}
3135
3136
3137	/* Allocate and initialize a new symbol node. */
3138
3139	gfc_symbol *
3140	gfc_new_symbol (const char *name, gfc_namespace *ns)
3141	{
3142	gfc_symbol *p;
3143
3144	p = XCNEW (gfc_symbol);
3145
3146	gfc_clear_ts (&p->ts);
3147	gfc_clear_attr (attr: &p->attr);
3148	p->ns = ns;
3149	p->declared_at = gfc_current_locus;
3150	p->name = gfc_get_string ("%s", name);
3151
3152	return p;
3153	}
3154
3155
3156	/* Generate an error if a symbol is ambiguous, and set the error flag
3157	on it. */
3158
3159	static void
3160	ambiguous_symbol (const char *name, gfc_symtree *st)
3161	{
3162
3163	if (st->n.sym->error)
3164	return;
3165
3166	if (st->n.sym->module)
3167	gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3168	"from module %qs", name, st->n.sym->name, st->n.sym->module);
3169	else
3170	gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3171	"from current program unit", name, st->n.sym->name);
3172
3173	st->n.sym->error = 1;
3174	}
3175
3176
3177	/* If we're in a SELECT TYPE block, check if the variable 'st' matches any
3178	selector on the stack. If yes, replace it by the corresponding temporary. */
3179
3180	static void
3181	select_type_insert_tmp (gfc_symtree **st)
3182	{
3183	gfc_select_type_stack *stack = select_type_stack;
3184	for (; stack; stack = stack->prev)
3185	if ((*st)->n.sym == stack->selector && stack->tmp)
3186	{
3187	*st = stack->tmp;
3188	select_type_insert_tmp (st);
3189	return;
3190	}
3191	}
3192
3193
3194	/* Look for a symtree in the current procedure -- that is, go up to
3195	parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
3196
3197	gfc_symtree*
3198	gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns)
3199	{
3200	while (ns)
3201	{
3202	gfc_symtree* st = gfc_find_symtree (st: ns->sym_root, name);
3203	if (st)
3204	return st;
3205
3206	if (!ns->construct_entities)
3207	break;
3208	ns = ns->parent;
3209	}
3210
3211	return NULL;
3212	}
3213
3214
3215	/* Search for a symtree starting in the current namespace, resorting to
3216	any parent namespaces if requested by a nonzero parent_flag.
3217	Returns true if the name is ambiguous. */
3218
3219	bool
3220	gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
3221	gfc_symtree **result)
3222	{
3223	gfc_symtree *st;
3224
3225	if (ns == NULL)
3226	ns = gfc_current_ns;
3227
3228	do
3229	{
3230	st = gfc_find_symtree (st: ns->sym_root, name);
3231	if (st != NULL)
3232	{
3233	select_type_insert_tmp (st: &st);
3234
3235	*result = st;
3236	/* Ambiguous generic interfaces are permitted, as long
3237	as the specific interfaces are different. */
3238	if (st->ambiguous && !st->n.sym->attr.generic)
3239	{
3240	ambiguous_symbol (name, st);
3241	return true;
3242	}
3243
3244	return false;
3245	}
3246
3247	if (!parent_flag)
3248	break;
3249
3250	/* Don't escape an interface block. */
3251	if (ns && !ns->has_import_set
3252	&& ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
3253	break;
3254
3255	ns = ns->parent;
3256	}
3257	while (ns != NULL);
3258
3259	if (gfc_current_state() == COMP_DERIVED
3260	&& gfc_current_block ()->attr.pdt_template)
3261	{
3262	gfc_symbol *der = gfc_current_block ();
3263	for (; der; der = gfc_get_derived_super_type (der))
3264	{
3265	if (der->f2k_derived && der->f2k_derived->sym_root)
3266	{
3267	st = gfc_find_symtree (st: der->f2k_derived->sym_root, name);
3268	if (st)
3269	break;
3270	}
3271	}
3272	*result = st;
3273	return false;
3274	}
3275
3276	*result = NULL;
3277
3278	return false;
3279	}
3280
3281
3282	/* Same, but returns the symbol instead. */
3283
3284	int
3285	gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
3286	gfc_symbol **result)
3287	{
3288	gfc_symtree *st;
3289	int i;
3290
3291	i = gfc_find_sym_tree (name, ns, parent_flag, result: &st);
3292
3293	if (st == NULL)
3294	*result = NULL;
3295	else
3296	*result = st->n.sym;
3297
3298	return i;
3299	}
3300
3301
3302	/* Tells whether there is only one set of changes in the stack. */
3303
3304	static bool
3305	single_undo_checkpoint_p (void)
3306	{
3307	if (latest_undo_chgset == &default_undo_chgset_var)
3308	{
3309	gcc_assert (latest_undo_chgset->previous == NULL);
3310	return true;
3311	}
3312	else
3313	{
3314	gcc_assert (latest_undo_chgset->previous != NULL);
3315	return false;
3316	}
3317	}
3318
3319	/* Save symbol with the information necessary to back it out. */
3320
3321	void
3322	gfc_save_symbol_data (gfc_symbol *sym)
3323	{
3324	gfc_symbol *s;
3325	unsigned i;
3326
3327	if (!single_undo_checkpoint_p ())
3328	{
3329	/* If there is more than one change set, look for the symbol in the
3330	current one. If it is found there, we can reuse it. */
3331	FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
3332	if (s == sym)
3333	{
3334	gcc_assert (sym->gfc_new || sym->old_symbol != NULL);
3335	return;
3336	}
3337	}
3338	else if (sym->gfc_new || sym->old_symbol != NULL)
3339	return;
3340
3341	s = XCNEW (gfc_symbol);
3342	*s = *sym;
3343	sym->old_symbol = s;
3344	sym->gfc_new = 0;
3345
3346	latest_undo_chgset->syms.safe_push (obj: sym);
3347	}
3348
3349
3350	/* Given a name, find a symbol, or create it if it does not exist yet
3351	in the current namespace. If the symbol is found we make sure that
3352	it's OK.
3353
3354	The integer return code indicates
3355	0 All OK
3356	1 The symbol name was ambiguous
3357	2 The name meant to be established was already host associated.
3358
3359	So if the return value is nonzero, then an error was issued. */
3360
3361	int
3362	gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
3363	bool allow_subroutine)
3364	{
3365	gfc_symtree *st;
3366	gfc_symbol *p;
3367
3368	/* This doesn't usually happen during resolution. */
3369	if (ns == NULL)
3370	ns = gfc_current_ns;
3371
3372	/* Try to find the symbol in ns. */
3373	st = gfc_find_symtree (st: ns->sym_root, name);
3374
3375	if (st == NULL && ns->omp_udr_ns)
3376	{
3377	ns = ns->parent;
3378	st = gfc_find_symtree (st: ns->sym_root, name);
3379	}
3380
3381	if (st == NULL)
3382	{
3383	/* If not there, create a new symbol. */
3384	p = gfc_new_symbol (name, ns);
3385
3386	/* Add to the list of tentative symbols. */
3387	p->old_symbol = NULL;
3388	p->mark = 1;
3389	p->gfc_new = 1;
3390	latest_undo_chgset->syms.safe_push (obj: p);
3391
3392	st = gfc_new_symtree (root: &ns->sym_root, name);
3393	st->n.sym = p;
3394	p->refs++;
3395
3396	}
3397	else
3398	{
3399	/* Make sure the existing symbol is OK. Ambiguous
3400	generic interfaces are permitted, as long as the
3401	specific interfaces are different. */
3402	if (st->ambiguous && !st->n.sym->attr.generic)
3403	{
3404	ambiguous_symbol (name, st);
3405	return 1;
3406	}
3407
3408	p = st->n.sym;
3409	if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
3410	&& !(allow_subroutine && p->attr.subroutine)
3411	&& !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
3412	&& (ns->has_import_set || p->attr.imported)))
3413	{
3414	/* Symbol is from another namespace. */
3415	gfc_error ("Symbol %qs at %C has already been host associated",
3416	name);
3417	return 2;
3418	}
3419
3420	p->mark = 1;
3421
3422	/* Copy in case this symbol is changed. */
3423	gfc_save_symbol_data (sym: p);
3424	}
3425
3426	*result = st;
3427	return 0;
3428	}
3429
3430
3431	int
3432	gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
3433	{
3434	gfc_symtree *st;
3435	int i;
3436
3437	i = gfc_get_sym_tree (name, ns, result: &st, allow_subroutine: false);
3438	if (i != 0)
3439	return i;
3440
3441	if (st)
3442	*result = st->n.sym;
3443	else
3444	*result = NULL;
3445	return i;
3446	}
3447
3448
3449	/* Subroutine that searches for a symbol, creating it if it doesn't
3450	exist, but tries to host-associate the symbol if possible. */
3451
3452	int
3453	gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
3454	{
3455	gfc_symtree *st;
3456	int i;
3457
3458	i = gfc_find_sym_tree (name, ns: gfc_current_ns, parent_flag: 0, result: &st);
3459
3460	if (st != NULL)
3461	{
3462	gfc_save_symbol_data (sym: st->n.sym);
3463	*result = st;
3464	return i;
3465	}
3466
3467	i = gfc_find_sym_tree (name, ns: gfc_current_ns, parent_flag: 1, result: &st);
3468	if (i)
3469	return i;
3470
3471	if (st != NULL)
3472	{
3473	*result = st;
3474	return 0;
3475	}
3476
3477	return gfc_get_sym_tree (name, ns: gfc_current_ns, result, allow_subroutine: false);
3478	}
3479
3480
3481	int
3482	gfc_get_ha_symbol (const char *name, gfc_symbol **result)
3483	{
3484	int i;
3485	gfc_symtree *st;
3486
3487	i = gfc_get_ha_sym_tree (name, result: &st);
3488
3489	if (st)
3490	*result = st->n.sym;
3491	else
3492	*result = NULL;
3493
3494	return i;
3495	}
3496
3497
3498	/* Search for the symtree belonging to a gfc_common_head; we cannot use
3499	head->name as the common_root symtree's name might be mangled. */
3500
3501	static gfc_symtree *
3502	find_common_symtree (gfc_symtree *st, gfc_common_head *head)
3503	{
3504
3505	gfc_symtree *result;
3506
3507	if (st == NULL)
3508	return NULL;
3509
3510	if (st->n.common == head)
3511	return st;
3512
3513	result = find_common_symtree (st: st->left, head);
3514	if (!result)
3515	result = find_common_symtree (st: st->right, head);
3516
3517	return result;
3518	}
3519
3520
3521	/* Restore previous state of symbol. Just copy simple stuff. */
3522
3523	static void
3524	restore_old_symbol (gfc_symbol *p)
3525	{
3526	gfc_symbol *old;
3527
3528	p->mark = 0;
3529	old = p->old_symbol;
3530
3531	p->ts.type = old->ts.type;
3532	p->ts.kind = old->ts.kind;
3533
3534	p->attr = old->attr;
3535
3536	if (p->value != old->value)
3537	{
3538	gcc_checking_assert (old->value == NULL);
3539	gfc_free_expr (p->value);
3540	p->value = NULL;
3541	}
3542
3543	if (p->as != old->as)
3544	{
3545	if (p->as)
3546	gfc_free_array_spec (p->as);
3547	p->as = old->as;
3548	}
3549
3550	p->generic = old->generic;
3551	p->component_access = old->component_access;
3552
3553	if (p->namelist != NULL && old->namelist == NULL)
3554	{
3555	gfc_free_namelist (p->namelist);
3556	p->namelist = NULL;
3557	}
3558	else
3559	{
3560	if (p->namelist_tail != old->namelist_tail)
3561	{
3562	gfc_free_namelist (old->namelist_tail->next);
3563	old->namelist_tail->next = NULL;
3564	}
3565	}
3566
3567	p->namelist_tail = old->namelist_tail;
3568
3569	if (p->formal != old->formal)
3570	{
3571	gfc_free_formal_arglist (p->formal);
3572	p->formal = old->formal;
3573	}
3574
3575	set_symbol_common_block (sym: p, common_block: old->common_block);
3576	p->common_head = old->common_head;
3577
3578	p->old_symbol = old->old_symbol;
3579	free (ptr: old);
3580	}
3581
3582
3583	/* Frees the internal data of a gfc_undo_change_set structure. Doesn't free
3584	the structure itself. */
3585
3586	static void
3587	free_undo_change_set_data (gfc_undo_change_set &cs)
3588	{
3589	cs.syms.release ();
3590	cs.tbps.release ();
3591	}
3592
3593
3594	/* Given a change set pointer, free its target's contents and update it with
3595	the address of the previous change set. Note that only the contents are
3596	freed, not the target itself (the contents' container). It is not a problem
3597	as the latter will be a local variable usually. */
3598
3599	static void
3600	pop_undo_change_set (gfc_undo_change_set *&cs)
3601	{
3602	free_undo_change_set_data (cs&: *cs);
3603	cs = cs->previous;
3604	}
3605
3606
3607	static void free_old_symbol (gfc_symbol *sym);
3608
3609
3610	/* Merges the current change set into the previous one. The changes themselves
3611	are left untouched; only one checkpoint is forgotten. */
3612
3613	void
3614	gfc_drop_last_undo_checkpoint (void)
3615	{
3616	gfc_symbol *s, *t;
3617	unsigned i, j;
3618
3619	FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
3620	{
3621	/* No need to loop in this case. */
3622	if (s->old_symbol == NULL)
3623	continue;
3624
3625	/* Remove the duplicate symbols. */
3626	FOR_EACH_VEC_ELT (latest_undo_chgset->previous->syms, j, t)
3627	if (t == s)
3628	{
3629	latest_undo_chgset->previous->syms.unordered_remove (ix: j);
3630
3631	/* S->OLD_SYMBOL is the backup symbol for S as it was at the
3632	last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL
3633	shall contain from now on the backup symbol for S as it was
3634	at the checkpoint before. */
3635	if (s->old_symbol->gfc_new)
3636	{
3637	gcc_assert (s->old_symbol->old_symbol == NULL);
3638	s->gfc_new = s->old_symbol->gfc_new;
3639	free_old_symbol (sym: s);
3640	}
3641	else
3642	restore_old_symbol (p: s->old_symbol);
3643	break;
3644	}
3645	}
3646
3647	latest_undo_chgset->previous->syms.safe_splice (src: latest_undo_chgset->syms);
3648	latest_undo_chgset->previous->tbps.safe_splice (src: latest_undo_chgset->tbps);
3649
3650	pop_undo_change_set (cs&: latest_undo_chgset);
3651	}
3652
3653
3654	/* Remove the reference to the symbol SYM in the symbol tree held by NS
3655	and free SYM if the last reference to it has been removed.
3656	Returns whether the symbol has been freed. */
3657
3658	static bool
3659	delete_symbol_from_ns (gfc_symbol *sym, gfc_namespace *ns)
3660	{
3661	if (ns == nullptr)
3662	return false;
3663
3664	/* The derived type is saved in the symtree with the first
3665	letter capitalized; the all lower-case version to the
3666	derived type contains its associated generic function. */
3667	const char *sym_name = gfc_fl_struct (sym->attr.flavor)
3668	? gfc_dt_upper_string (sym->name)
3669	: sym->name;
3670
3671	gfc_delete_symtree (root: &ns->sym_root, name: sym_name);
3672
3673	return gfc_release_symbol (sym);
3674	}
3675
3676
3677	/* Undoes all the changes made to symbols since the previous checkpoint.
3678	This subroutine is made simpler due to the fact that attributes are
3679	never removed once added. */
3680
3681	void
3682	gfc_restore_last_undo_checkpoint (void)
3683	{
3684	gfc_symbol *p;
3685	unsigned i;
3686
3687	FOR_EACH_VEC_ELT_REVERSE (latest_undo_chgset->syms, i, p)
3688	{
3689	/* Symbol in a common block was new. Or was old and just put in common */
3690	if (p->common_block
3691	&& (p->gfc_new || !p->old_symbol->common_block))
3692	{
3693	/* If the symbol was added to any common block, it
3694	needs to be removed to stop the resolver looking
3695	for a (possibly) dead symbol. */
3696	if (p->common_block->head == p && !p->common_next)
3697	{
3698	gfc_symtree st, *st0;
3699	st0 = find_common_symtree (st: p->ns->common_root,
3700	head: p->common_block);
3701	if (st0)
3702	{
3703	st.name = st0->name;
3704	gfc_delete_bbt (&p->ns->common_root, &st, compare_symtree);
3705	free (ptr: st0);
3706	}
3707	}
3708
3709	if (p->common_block->head == p)
3710	p->common_block->head = p->common_next;
3711	else
3712	{
3713	gfc_symbol *cparent, *csym;
3714
3715	cparent = p->common_block->head;
3716	csym = cparent->common_next;
3717
3718	while (csym != p)
3719	{
3720	cparent = csym;
3721	csym = csym->common_next;
3722	}
3723
3724	gcc_assert(cparent->common_next == p);
3725	cparent->common_next = csym->common_next;
3726	}
3727	p->common_next = NULL;
3728	}
3729	if (p->gfc_new)
3730	{
3731	bool freed = delete_symbol_from_ns (sym: p, ns: p->ns);
3732
3733	/* If the symbol is a procedure (function or subroutine), remove
3734	it from the procedure body namespace as well as from the outer
3735	namespace. */
3736	if (!freed
3737	&& p->formal_ns != p->ns)
3738	freed = delete_symbol_from_ns (sym: p, ns: p->formal_ns);
3739
3740	/* If the formal_ns field has not been set yet, the previous
3741	conditional does nothing. In that case, we can assume that
3742	gfc_current_ns is the procedure body namespace, and remove the
3743	symbol from there. */
3744	if (!freed
3745	&& gfc_current_ns != p->ns
3746	&& gfc_current_ns != p->formal_ns)
3747	freed = delete_symbol_from_ns (sym: p, ns: gfc_current_ns);
3748	}
3749	else
3750	restore_old_symbol (p);
3751	}
3752
3753	latest_undo_chgset->syms.truncate (size: 0);
3754	latest_undo_chgset->tbps.truncate (size: 0);
3755
3756	if (!single_undo_checkpoint_p ())
3757	pop_undo_change_set (cs&: latest_undo_chgset);
3758	}
3759
3760
3761	/* Makes sure that there is only one set of changes; in other words we haven't
3762	forgotten to pair a call to gfc_new_checkpoint with a call to either
3763	gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */
3764
3765	static void
3766	enforce_single_undo_checkpoint (void)
3767	{
3768	gcc_checking_assert (single_undo_checkpoint_p ());
3769	}
3770
3771
3772	/* Undoes all the changes made to symbols in the current statement. */
3773
3774	void
3775	gfc_undo_symbols (void)
3776	{
3777	enforce_single_undo_checkpoint ();
3778	gfc_restore_last_undo_checkpoint ();
3779	}
3780
3781
3782	/* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
3783	components of old_symbol that might need deallocation are the "allocatables"
3784	that are restored in gfc_undo_symbols(), with two exceptions: namelist and
3785	namelist_tail. In case these differ between old_symbol and sym, it's just
3786	because sym->namelist has gotten a few more items. */
3787
3788	static void
3789	free_old_symbol (gfc_symbol *sym)
3790	{
3791
3792	if (sym->old_symbol == NULL)
3793	return;
3794
3795	if (sym->old_symbol->as != NULL
3796	&& sym->old_symbol->as != sym->as
3797	&& !(sym->ts.type == BT_CLASS
3798	&& sym->ts.u.derived->attr.is_class
3799	&& sym->old_symbol->as == CLASS_DATA (sym)->as))
3800	gfc_free_array_spec (sym->old_symbol->as);
3801
3802	if (sym->old_symbol->value != sym->value)
3803	gfc_free_expr (sym->old_symbol->value);
3804
3805	if (sym->old_symbol->formal != sym->formal)
3806	gfc_free_formal_arglist (sym->old_symbol->formal);
3807
3808	free (ptr: sym->old_symbol);
3809	sym->old_symbol = NULL;
3810	}
3811
3812
3813	/* Makes the changes made in the current statement permanent-- gets
3814	rid of undo information. */
3815
3816	void
3817	gfc_commit_symbols (void)
3818	{
3819	gfc_symbol *p;
3820	gfc_typebound_proc *tbp;
3821	unsigned i;
3822
3823	enforce_single_undo_checkpoint ();
3824
3825	FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
3826	{
3827	p->mark = 0;
3828	p->gfc_new = 0;
3829	free_old_symbol (sym: p);
3830	}
3831	latest_undo_chgset->syms.truncate (size: 0);
3832
3833	FOR_EACH_VEC_ELT (latest_undo_chgset->tbps, i, tbp)
3834	tbp->error = 0;
3835	latest_undo_chgset->tbps.truncate (size: 0);
3836	}
3837
3838
3839	/* Makes the changes made in one symbol permanent -- gets rid of undo
3840	information. */
3841
3842	void
3843	gfc_commit_symbol (gfc_symbol *sym)
3844	{
3845	gfc_symbol *p;
3846	unsigned i;
3847
3848	enforce_single_undo_checkpoint ();
3849
3850	FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
3851	if (p == sym)
3852	{
3853	latest_undo_chgset->syms.unordered_remove (ix: i);
3854	break;
3855	}
3856
3857	sym->mark = 0;
3858	sym->gfc_new = 0;
3859
3860	free_old_symbol (sym);
3861	}
3862
3863
3864	/* Recursively free trees containing type-bound procedures. */
3865
3866	static void
3867	free_tb_tree (gfc_symtree *t)
3868	{
3869	if (t == NULL)
3870	return;
3871
3872	free_tb_tree (t: t->left);
3873	free_tb_tree (t: t->right);
3874
3875	/* TODO: Free type-bound procedure u.generic */
3876	free (ptr: t->n.tb);
3877	t->n.tb = NULL;
3878	free (ptr: t);
3879	}
3880
3881
3882	/* Recursive function that deletes an entire tree and all the common
3883	head structures it points to. */
3884
3885	static void
3886	free_common_tree (gfc_symtree * common_tree)
3887	{
3888	if (common_tree == NULL)
3889	return;
3890
3891	free_common_tree (common_tree: common_tree->left);
3892	free_common_tree (common_tree: common_tree->right);
3893
3894	free (ptr: common_tree);
3895	}
3896
3897
3898	/* Recursive function that deletes an entire tree and all the common
3899	head structures it points to. */
3900
3901	static void
3902	free_omp_udr_tree (gfc_symtree * omp_udr_tree)
3903	{
3904	if (omp_udr_tree == NULL)
3905	return;
3906
3907	free_omp_udr_tree (omp_udr_tree: omp_udr_tree->left);
3908	free_omp_udr_tree (omp_udr_tree: omp_udr_tree->right);
3909
3910	gfc_free_omp_udr (omp_udr_tree->n.omp_udr);
3911	free (ptr: omp_udr_tree);
3912	}
3913
3914
3915	/* Recursive function that deletes an entire tree and all the user
3916	operator nodes that it contains. */
3917
3918	static void
3919	free_uop_tree (gfc_symtree *uop_tree)
3920	{
3921	if (uop_tree == NULL)
3922	return;
3923
3924	free_uop_tree (uop_tree: uop_tree->left);
3925	free_uop_tree (uop_tree: uop_tree->right);
3926
3927	gfc_free_interface (uop_tree->n.uop->op);
3928	free (ptr: uop_tree->n.uop);
3929	free (ptr: uop_tree);
3930	}
3931
3932
3933	/* Recursive function that deletes an entire tree and all the symbols
3934	that it contains. */
3935
3936	static void
3937	free_sym_tree (gfc_symtree *sym_tree)
3938	{
3939	if (sym_tree == NULL)
3940	return;
3941
3942	free_sym_tree (sym_tree: sym_tree->left);
3943	free_sym_tree (sym_tree: sym_tree->right);
3944
3945	gfc_release_symbol (sym&: sym_tree->n.sym);
3946	free (ptr: sym_tree);
3947	}
3948
3949
3950	/* Free the gfc_equiv_info's. */
3951
3952	static void
3953	gfc_free_equiv_infos (gfc_equiv_info *s)
3954	{
3955	if (s == NULL)
3956	return;
3957	gfc_free_equiv_infos (s: s->next);
3958	free (ptr: s);
3959	}
3960
3961
3962	/* Free the gfc_equiv_lists. */
3963
3964	static void
3965	gfc_free_equiv_lists (gfc_equiv_list *l)
3966	{
3967	if (l == NULL)
3968	return;
3969	gfc_free_equiv_lists (l: l->next);
3970	gfc_free_equiv_infos (s: l->equiv);
3971	free (ptr: l);
3972	}
3973
3974
3975	/* Free a finalizer procedure list. */
3976
3977	void
3978	gfc_free_finalizer (gfc_finalizer* el)
3979	{
3980	if (el)
3981	{
3982	gfc_release_symbol (sym&: el->proc_sym);
3983	free (ptr: el);
3984	}
3985	}
3986
3987	static void
3988	gfc_free_finalizer_list (gfc_finalizer* list)
3989	{
3990	while (list)
3991	{
3992	gfc_finalizer* current = list;
3993	list = list->next;
3994	gfc_free_finalizer (el: current);
3995	}
3996	}
3997
3998
3999	/* Create a new gfc_charlen structure and add it to a namespace.
4000	If 'old_cl' is given, the newly created charlen will be a copy of it. */
4001
4002	gfc_charlen*
4003	gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
4004	{
4005	gfc_charlen *cl;
4006
4007	cl = gfc_get_charlen ();
4008
4009	/* Copy old_cl. */
4010	if (old_cl)
4011	{
4012	cl->length = gfc_copy_expr (old_cl->length);
4013	cl->length_from_typespec = old_cl->length_from_typespec;
4014	cl->backend_decl = old_cl->backend_decl;
4015	cl->passed_length = old_cl->passed_length;
4016	cl->resolved = old_cl->resolved;
4017	}
4018
4019	/* Put into namespace. */
4020	cl->next = ns->cl_list;
4021	ns->cl_list = cl;
4022
4023	return cl;
4024	}
4025
4026
4027	/* Free the charlen list from cl to end (end is not freed).
4028	Free the whole list if end is NULL. */
4029
4030	static void
4031	gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
4032	{
4033	gfc_charlen *cl2;
4034
4035	for (; cl != end; cl = cl2)
4036	{
4037	gcc_assert (cl);
4038
4039	cl2 = cl->next;
4040	gfc_free_expr (cl->length);
4041	free (ptr: cl);
4042	}
4043	}
4044
4045
4046	/* Free entry list structs. */
4047
4048	static void
4049	free_entry_list (gfc_entry_list *el)
4050	{
4051	gfc_entry_list *next;
4052
4053	if (el == NULL)
4054	return;
4055
4056	next = el->next;
4057	free (ptr: el);
4058	free_entry_list (el: next);
4059	}
4060
4061
4062	/* Free a namespace structure and everything below it. Interface
4063	lists associated with intrinsic operators are not freed. These are
4064	taken care of when a specific name is freed. */
4065
4066	void
4067	gfc_free_namespace (gfc_namespace *&ns)
4068	{
4069	gfc_namespace *p, *q;
4070	int i;
4071	gfc_was_finalized *f;
4072
4073	if (ns == NULL)
4074	return;
4075
4076	ns->refs--;
4077	if (ns->refs > 0)
4078	return;
4079
4080	gcc_assert (ns->refs == 0);
4081
4082	gfc_free_statements (ns->code);
4083
4084	free_sym_tree (sym_tree: ns->sym_root);
4085	free_uop_tree (uop_tree: ns->uop_root);
4086	free_common_tree (common_tree: ns->common_root);
4087	free_omp_udr_tree (omp_udr_tree: ns->omp_udr_root);
4088	free_tb_tree (t: ns->tb_sym_root);
4089	free_tb_tree (t: ns->tb_uop_root);
4090	gfc_free_finalizer_list (list: ns->finalizers);
4091	gfc_free_omp_declare_simd_list (ns->omp_declare_simd);
4092	gfc_free_omp_declare_variant_list (list: ns->omp_declare_variant);
4093	gfc_free_charlen (cl: ns->cl_list, NULL);
4094	free_st_labels (label: ns->st_labels);
4095
4096	free_entry_list (el: ns->entries);
4097	gfc_free_equiv (ns->equiv);
4098	gfc_free_equiv_lists (l: ns->equiv_lists);
4099	gfc_free_use_stmts (ns->use_stmts);
4100
4101	for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
4102	gfc_free_interface (ns->op[i]);
4103
4104	gfc_free_data (ns->data);
4105
4106	/* Free all the expr + component combinations that have been
4107	finalized. */
4108	f = ns->was_finalized;
4109	while (f)
4110	{
4111	gfc_was_finalized* current = f;
4112	f = f->next;
4113	free (ptr: current);
4114	}
4115	if (ns->omp_assumes)
4116	{
4117	free (ptr: ns->omp_assumes->absent);
4118	free (ptr: ns->omp_assumes->contains);
4119	gfc_free_expr_list (ns->omp_assumes->holds);
4120	free (ptr: ns->omp_assumes);
4121	}
4122	p = ns->contained;
4123	free (ptr: ns);
4124	ns = NULL;
4125
4126	/* Recursively free any contained namespaces. */
4127	while (p != NULL)
4128	{
4129	q = p;
4130	p = p->sibling;
4131	gfc_free_namespace (ns&: q);
4132	}
4133	}
4134
4135
4136	void
4137	gfc_symbol_init_2 (void)
4138	{
4139
4140	gfc_current_ns = gfc_get_namespace (NULL, parent_types: 0);
4141	}
4142
4143
4144	void
4145	gfc_symbol_done_2 (void)
4146	{
4147	if (gfc_current_ns != NULL)
4148	{
4149	/* free everything from the root. */
4150	while (gfc_current_ns->parent != NULL)
4151	gfc_current_ns = gfc_current_ns->parent;
4152	gfc_free_namespace (ns&: gfc_current_ns);
4153	gfc_current_ns = NULL;
4154	}
4155	gfc_derived_types = NULL;
4156
4157	enforce_single_undo_checkpoint ();
4158	free_undo_change_set_data (cs&: *latest_undo_chgset);
4159	}
4160
4161
4162	/* Count how many nodes a symtree has. */
4163
4164	static unsigned
4165	count_st_nodes (const gfc_symtree *st)
4166	{
4167	unsigned nodes;
4168	if (!st)
4169	return 0;
4170
4171	nodes = count_st_nodes (st: st->left);
4172	nodes++;
4173	nodes += count_st_nodes (st: st->right);
4174
4175	return nodes;
4176	}
4177
4178
4179	/* Convert symtree tree into symtree vector. */
4180
4181	static unsigned
4182	fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr)
4183	{
4184	if (!st)
4185	return node_cntr;
4186
4187	node_cntr = fill_st_vector (st: st->left, st_vec, node_cntr);
4188	st_vec[node_cntr++] = st;
4189	node_cntr = fill_st_vector (st: st->right, st_vec, node_cntr);
4190
4191	return node_cntr;
4192	}
4193
4194
4195	/* Traverse namespace. As the functions might modify the symtree, we store the
4196	symtree as a vector and operate on this vector. Note: We assume that
4197	sym_func or st_func never deletes nodes from the symtree - only adding is
4198	allowed. Additionally, newly added nodes are not traversed. */
4199
4200	static void
4201	do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *),
4202	void (*sym_func) (gfc_symbol *))
4203	{
4204	gfc_symtree **st_vec;
4205	unsigned nodes, i, node_cntr;
4206
4207	gcc_assert ((st_func && !sym_func) || (!st_func && sym_func));
4208	nodes = count_st_nodes (st);
4209	st_vec = XALLOCAVEC (gfc_symtree *, nodes);
4210	node_cntr = 0;
4211	fill_st_vector (st, st_vec, node_cntr);
4212
4213	if (sym_func)
4214	{
4215	/* Clear marks. */
4216	for (i = 0; i < nodes; i++)
4217	st_vec[i]->n.sym->mark = 0;
4218	for (i = 0; i < nodes; i++)
4219	if (!st_vec[i]->n.sym->mark)
4220	{
4221	(*sym_func) (st_vec[i]->n.sym);
4222	st_vec[i]->n.sym->mark = 1;
4223	}
4224	}
4225	else
4226	for (i = 0; i < nodes; i++)
4227	(*st_func) (st_vec[i]);
4228	}
4229
4230
4231	/* Recursively traverse the symtree nodes. */
4232
4233	void
4234	gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *))
4235	{
4236	do_traverse_symtree (st, st_func, NULL);
4237	}
4238
4239
4240	/* Call a given function for all symbols in the namespace. We take
4241	care that each gfc_symbol node is called exactly once. */
4242
4243	void
4244	gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *))
4245	{
4246	do_traverse_symtree (st: ns->sym_root, NULL, sym_func);
4247	}
4248
4249
4250	/* Return TRUE when name is the name of an intrinsic type. */
4251
4252	bool
4253	gfc_is_intrinsic_typename (const char *name)
4254	{
4255	if (strcmp (s1: name, s2: "integer") == 0
4256	|| strcmp (s1: name, s2: "real") == 0
4257	|| strcmp (s1: name, s2: "character") == 0
4258	|| strcmp (s1: name, s2: "logical") == 0
4259	|| strcmp (s1: name, s2: "complex") == 0
4260	|| strcmp (s1: name, s2: "doubleprecision") == 0
4261	|| strcmp (s1: name, s2: "doublecomplex") == 0)
4262	return true;
4263	else
4264	return false;
4265	}
4266
4267
4268	/* Return TRUE if the symbol is an automatic variable. */
4269
4270	static bool
4271	gfc_is_var_automatic (gfc_symbol *sym)
4272	{
4273	/* Pointer and allocatable variables are never automatic. */
4274	if (sym->attr.pointer || sym->attr.allocatable)
4275	return false;
4276	/* Check for arrays with non-constant size. */
4277	if (sym->attr.dimension && sym->as
4278	&& !gfc_is_compile_time_shape (sym->as))
4279	return true;
4280	/* Check for non-constant length character variables. */
4281	if (sym->ts.type == BT_CHARACTER
4282	&& sym->ts.u.cl
4283	&& !gfc_is_constant_expr (sym->ts.u.cl->length))
4284	return true;
4285	/* Variables with explicit AUTOMATIC attribute. */
4286	if (sym->attr.automatic)
4287	return true;
4288
4289	return false;
4290	}
4291
4292	/* Given a symbol, mark it as SAVEd if it is allowed. */
4293
4294	static void
4295	save_symbol (gfc_symbol *sym)
4296	{
4297
4298	if (sym->attr.use_assoc)
4299	return;
4300
4301	if (sym->attr.in_common
4302	|| sym->attr.in_equivalence
4303	|| sym->attr.dummy
4304	|| sym->attr.result
4305	|| sym->attr.flavor != FL_VARIABLE)
4306	return;
4307	/* Automatic objects are not saved. */
4308	if (gfc_is_var_automatic (sym))
4309	return;
4310	gfc_add_save (attr: &sym->attr, s: SAVE_EXPLICIT, name: sym->name, where: &sym->declared_at);
4311	}
4312
4313
4314	/* Mark those symbols which can be SAVEd as such. */
4315
4316	void
4317	gfc_save_all (gfc_namespace *ns)
4318	{
4319	gfc_traverse_ns (ns, sym_func: save_symbol);
4320	}
4321
4322
4323	/* Make sure that no changes to symbols are pending. */
4324
4325	void
4326	gfc_enforce_clean_symbol_state(void)
4327	{
4328	enforce_single_undo_checkpoint ();
4329	gcc_assert (latest_undo_chgset->syms.is_empty ());
4330	}
4331
4332
4333	/************** Global symbol handling ************/
4334
4335
4336	/* Search a tree for the global symbol. */
4337
4338	gfc_gsymbol *
4339	gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
4340	{
4341	int c;
4342
4343	if (symbol == NULL)
4344	return NULL;
4345
4346	while (symbol)
4347	{
4348	c = strcmp (s1: name, s2: symbol->name);
4349	if (!c)
4350	return symbol;
4351
4352	symbol = (c < 0) ? symbol->left : symbol->right;
4353	}
4354
4355	return NULL;
4356	}
4357
4358
4359	/* Case insensitive search a tree for the global symbol. */
4360
4361	gfc_gsymbol *
4362	gfc_find_case_gsymbol (gfc_gsymbol *symbol, const char *name)
4363	{
4364	int c;
4365
4366	if (symbol == NULL)
4367	return NULL;
4368
4369	while (symbol)
4370	{
4371	c = strcasecmp (s1: name, s2: symbol->name);
4372	if (!c)
4373	return symbol;
4374
4375	symbol = (c < 0) ? symbol->left : symbol->right;
4376	}
4377
4378	return NULL;
4379	}
4380
4381
4382	/* Compare two global symbols. Used for managing the BB tree. */
4383
4384	static int
4385	gsym_compare (void *_s1, void *_s2)
4386	{
4387	gfc_gsymbol *s1, *s2;
4388
4389	s1 = (gfc_gsymbol *) _s1;
4390	s2 = (gfc_gsymbol *) _s2;
4391	return strcmp (s1: s1->name, s2: s2->name);
4392	}
4393
4394
4395	/* Get a global symbol, creating it if it doesn't exist. */
4396
4397	gfc_gsymbol *
4398	gfc_get_gsymbol (const char *name, bool bind_c)
4399	{
4400	gfc_gsymbol *s;
4401
4402	s = gfc_find_gsymbol (symbol: gfc_gsym_root, name);
4403	if (s != NULL)
4404	return s;
4405
4406	s = XCNEW (gfc_gsymbol);
4407	s->type = GSYM_UNKNOWN;
4408	s->name = gfc_get_string ("%s", name);
4409	s->bind_c = bind_c;
4410
4411	gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
4412
4413	return s;
4414	}
4415
4416	void
4417	gfc_traverse_gsymbol (gfc_gsymbol *gsym,
4418	void (*do_something) (gfc_gsymbol *, void *),
4419	void *data)
4420	{
4421	if (gsym->left)
4422	gfc_traverse_gsymbol (gsym: gsym->left, do_something, data);
4423
4424	(*do_something) (gsym, data);
4425
4426	if (gsym->right)
4427	gfc_traverse_gsymbol (gsym: gsym->right, do_something, data);
4428	}
4429
4430	static gfc_symbol *
4431	get_iso_c_binding_dt (int sym_id)
4432	{
4433	gfc_symbol *dt_list = gfc_derived_types;
4434
4435	/* Loop through the derived types in the name list, searching for
4436	the desired symbol from iso_c_binding. Search the parent namespaces
4437	if necessary and requested to (parent_flag). */
4438	if (dt_list)
4439	{
4440	while (dt_list->dt_next != gfc_derived_types)
4441	{
4442	if (dt_list->from_intmod != INTMOD_NONE
4443	&& dt_list->intmod_sym_id == sym_id)
4444	return dt_list;
4445
4446	dt_list = dt_list->dt_next;
4447	}
4448	}
4449
4450	return NULL;
4451	}
4452
4453
4454	/* Verifies that the given derived type symbol, derived_sym, is interoperable
4455	with C. This is necessary for any derived type that is BIND(C) and for
4456	derived types that are parameters to functions that are BIND(C). All
4457	fields of the derived type are required to be interoperable, and are tested
4458	for such. If an error occurs, the errors are reported here, allowing for
4459	multiple errors to be handled for a single derived type. */
4460
4461	bool
4462	verify_bind_c_derived_type (gfc_symbol *derived_sym)
4463	{
4464	gfc_component *curr_comp = NULL;
4465	bool is_c_interop = false;
4466	bool retval = true;
4467
4468	if (derived_sym == NULL)
4469	gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
4470	"unexpectedly NULL");
4471
4472	/* If we've already looked at this derived symbol, do not look at it again
4473	so we don't repeat warnings/errors. */
4474	if (derived_sym->ts.is_c_interop)
4475	return true;
4476
4477	/* The derived type must have the BIND attribute to be interoperable
4478	J3/04-007, Section 15.2.3. */
4479	if (derived_sym->attr.is_bind_c != 1)
4480	{
4481	derived_sym->ts.is_c_interop = 0;
4482	gfc_error_now ("Derived type %qs declared at %L must have the BIND "
4483	"attribute to be C interoperable", derived_sym->name,
4484	&(derived_sym->declared_at));
4485	retval = false;
4486	}
4487
4488	curr_comp = derived_sym->components;
4489
4490	/* Fortran 2003 allows an empty derived type. C99 appears to disallow an
4491	empty struct. Section 15.2 in Fortran 2003 states: "The following
4492	subclauses define the conditions under which a Fortran entity is
4493	interoperable. If a Fortran entity is interoperable, an equivalent
4494	entity may be defined by means of C and the Fortran entity is said
4495	to be interoperable with the C entity. There does not have to be such
4496	an interoperating C entity."
4497	*/
4498	if (curr_comp == NULL)
4499	{
4500	gfc_warning (opt: 0, "Derived type %qs with BIND(C) attribute at %L is empty, "
4501	"and may be inaccessible by the C companion processor",
4502	derived_sym->name, &(derived_sym->declared_at));
4503	derived_sym->ts.is_c_interop = 1;
4504	derived_sym->attr.is_bind_c = 1;
4505	return true;
4506	}
4507
4508
4509	/* Initialize the derived type as being C interoperable.
4510	If we find an error in the components, this will be set false. */
4511	derived_sym->ts.is_c_interop = 1;
4512
4513	/* Loop through the list of components to verify that the kind of
4514	each is a C interoperable type. */
4515	do
4516	{
4517	/* The components cannot be pointers (fortran sense).
4518	J3/04-007, Section 15.2.3, C1505. */
4519	if (curr_comp->attr.pointer != 0)
4520	{
4521	gfc_error ("Component %qs at %L cannot have the "
4522	"POINTER attribute because it is a member "
4523	"of the BIND(C) derived type %qs at %L",
4524	curr_comp->name, &(curr_comp->loc),
4525	derived_sym->name, &(derived_sym->declared_at));
4526	retval = false;
4527	}
4528
4529	if (curr_comp->attr.proc_pointer != 0)
4530	{
4531	gfc_error ("Procedure pointer component %qs at %L cannot be a member"
4532	" of the BIND(C) derived type %qs at %L", curr_comp->name,
4533	&curr_comp->loc, derived_sym->name,
4534	&derived_sym->declared_at);
4535	retval = false;
4536	}
4537
4538	/* The components cannot be allocatable.
4539	J3/04-007, Section 15.2.3, C1505. */
4540	if (curr_comp->attr.allocatable != 0)
4541	{
4542	gfc_error ("Component %qs at %L cannot have the "
4543	"ALLOCATABLE attribute because it is a member "
4544	"of the BIND(C) derived type %qs at %L",
4545	curr_comp->name, &(curr_comp->loc),
4546	derived_sym->name, &(derived_sym->declared_at));
4547	retval = false;
4548	}
4549
4550	/* BIND(C) derived types must have interoperable components. */
4551	if (curr_comp->ts.type == BT_DERIVED
4552	&& curr_comp->ts.u.derived->ts.is_iso_c != 1
4553	&& curr_comp->ts.u.derived != derived_sym)
4554	{
4555	/* This should be allowed; the draft says a derived-type cannot
4556	have type parameters if it is has the BIND attribute. Type
4557	parameters seem to be for making parameterized derived types.
4558	There's no need to verify the type if it is c_ptr/c_funptr. */
4559	retval = verify_bind_c_derived_type (derived_sym: curr_comp->ts.u.derived);
4560	}
4561	else
4562	{
4563	/* Grab the typespec for the given component and test the kind. */
4564	is_c_interop = gfc_verify_c_interop (&(curr_comp->ts));
4565
4566	if (!is_c_interop)
4567	{
4568	/* Report warning and continue since not fatal. The
4569	draft does specify a constraint that requires all fields
4570	to interoperate, but if the user says real(4), etc., it
4571	may interoperate with *something* in C, but the compiler
4572	most likely won't know exactly what. Further, it may not
4573	interoperate with the same data type(s) in C if the user
4574	recompiles with different flags (e.g., -m32 and -m64 on
4575	x86_64 and using integer(4) to claim interop with a
4576	C_LONG). */
4577	if (derived_sym->attr.is_bind_c == 1 && warn_c_binding_type)
4578	/* If the derived type is bind(c), all fields must be
4579	interop. */
4580	gfc_warning (opt: OPT_Wc_binding_type,
4581	"Component %qs in derived type %qs at %L "
4582	"may not be C interoperable, even though "
4583	"derived type %qs is BIND(C)",
4584	curr_comp->name, derived_sym->name,
4585	&(curr_comp->loc), derived_sym->name);
4586	else if (warn_c_binding_type)
4587	/* If derived type is param to bind(c) routine, or to one
4588	of the iso_c_binding procs, it must be interoperable, so
4589	all fields must interop too. */
4590	gfc_warning (opt: OPT_Wc_binding_type,
4591	"Component %qs in derived type %qs at %L "
4592	"may not be C interoperable",
4593	curr_comp->name, derived_sym->name,
4594	&(curr_comp->loc));
4595	}
4596	}
4597
4598	curr_comp = curr_comp->next;
4599	} while (curr_comp != NULL);
4600
4601	if (derived_sym->attr.sequence != 0)
4602	{
4603	gfc_error ("Derived type %qs at %L cannot have the SEQUENCE "
4604	"attribute because it is BIND(C)", derived_sym->name,
4605	&(derived_sym->declared_at));
4606	retval = false;
4607	}
4608
4609	/* Mark the derived type as not being C interoperable if we found an
4610	error. If there were only warnings, proceed with the assumption
4611	it's interoperable. */
4612	if (!retval)
4613	derived_sym->ts.is_c_interop = 0;
4614
4615	return retval;
4616	}
4617
4618
4619	/* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
4620
4621	static bool
4622	gen_special_c_interop_ptr (gfc_symbol *tmp_sym, gfc_symtree *dt_symtree)
4623	{
4624	gfc_constructor *c;
4625
4626	gcc_assert (tmp_sym && dt_symtree && dt_symtree->n.sym);
4627	dt_symtree->n.sym->attr.referenced = 1;
4628
4629	tmp_sym->attr.is_c_interop = 1;
4630	tmp_sym->attr.is_bind_c = 1;
4631	tmp_sym->ts.is_c_interop = 1;
4632	tmp_sym->ts.is_iso_c = 1;
4633	tmp_sym->ts.type = BT_DERIVED;
4634	tmp_sym->ts.f90_type = BT_VOID;
4635	tmp_sym->attr.flavor = FL_PARAMETER;
4636	tmp_sym->ts.u.derived = dt_symtree->n.sym;
4637
4638	/* Set the c_address field of c_null_ptr and c_null_funptr to
4639	the value of NULL. */
4640	tmp_sym->value = gfc_get_expr ();
4641	tmp_sym->value->expr_type = EXPR_STRUCTURE;
4642	tmp_sym->value->ts.type = BT_DERIVED;
4643	tmp_sym->value->ts.f90_type = BT_VOID;
4644	tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
4645	gfc_constructor_append_expr (base: &tmp_sym->value->value.constructor, NULL, NULL);
4646	c = gfc_constructor_first (base: tmp_sym->value->value.constructor);
4647	c->expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
4648	c->expr->ts.is_iso_c = 1;
4649
4650	return true;
4651	}
4652
4653
4654	/* Add a formal argument, gfc_formal_arglist, to the
4655	end of the given list of arguments. Set the reference to the
4656	provided symbol, param_sym, in the argument. */
4657
4658	static void
4659	add_formal_arg (gfc_formal_arglist **head,
4660	gfc_formal_arglist **tail,
4661	gfc_formal_arglist *formal_arg,
4662	gfc_symbol *param_sym)
4663	{
4664	/* Put in list, either as first arg or at the tail (curr arg). */
4665	if (*head == NULL)
4666	*head = *tail = formal_arg;
4667	else
4668	{
4669	(*tail)->next = formal_arg;
4670	(*tail) = formal_arg;
4671	}
4672
4673	(*tail)->sym = param_sym;
4674	(*tail)->next = NULL;
4675
4676	return;
4677	}
4678
4679
4680	/* Add a procedure interface to the given symbol (i.e., store a
4681	reference to the list of formal arguments). */
4682
4683	static void
4684	add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
4685	{
4686
4687	sym->formal = formal;
4688	sym->attr.if_source = source;
4689	}
4690
4691
4692	/* Copy the formal args from an existing symbol, src, into a new
4693	symbol, dest. New formal args are created, and the description of
4694	each arg is set according to the existing ones. This function is
4695	used when creating procedure declaration variables from a procedure
4696	declaration statement (see match_proc_decl()) to create the formal
4697	args based on the args of a given named interface.
4698
4699	When an actual argument list is provided, skip the absent arguments
4700	unless copy_type is true.
4701	To be used together with gfc_se->ignore_optional. */
4702
4703	void
4704	gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src,
4705	gfc_actual_arglist *actual, bool copy_type)
4706	{
4707	gfc_formal_arglist *head = NULL;
4708	gfc_formal_arglist *tail = NULL;
4709	gfc_formal_arglist *formal_arg = NULL;
4710	gfc_intrinsic_arg *curr_arg = NULL;
4711	gfc_formal_arglist *formal_prev = NULL;
4712	gfc_actual_arglist *act_arg = actual;
4713	/* Save current namespace so we can change it for formal args. */
4714	gfc_namespace *parent_ns = gfc_current_ns;
4715
4716	/* Create a new namespace, which will be the formal ns (namespace
4717	of the formal args). */
4718	gfc_current_ns = gfc_get_namespace (parent: parent_ns, parent_types: 0);
4719	gfc_current_ns->proc_name = dest;
4720
4721	for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4722	{
4723	/* Skip absent arguments. */
4724	if (actual)
4725	{
4726	gcc_assert (act_arg != NULL);
4727	if (act_arg->expr == NULL)
4728	{
4729	act_arg = act_arg->next;
4730	continue;
4731	}
4732	}
4733	formal_arg = gfc_get_formal_arglist ();
4734	gfc_get_symbol (name: curr_arg->name, ns: gfc_current_ns, result: &(formal_arg->sym));
4735
4736	/* May need to copy more info for the symbol. */
4737	if (copy_type && act_arg->expr != NULL)
4738	{
4739	formal_arg->sym->ts = act_arg->expr->ts;
4740	if (act_arg->expr->rank > 0)
4741	{
4742	formal_arg->sym->attr.dimension = 1;
4743	formal_arg->sym->as = gfc_get_array_spec();
4744	formal_arg->sym->as->rank = -1;
4745	formal_arg->sym->as->type = AS_ASSUMED_RANK;
4746	}
4747	if (act_arg->name && strcmp (s1: act_arg->name, s2: "%VAL") == 0)
4748	formal_arg->sym->pass_as_value = 1;
4749	}
4750	else
4751	formal_arg->sym->ts = curr_arg->ts;
4752
4753	formal_arg->sym->attr.optional = curr_arg->optional;
4754	formal_arg->sym->attr.value = curr_arg->value;
4755	formal_arg->sym->attr.intent = curr_arg->intent;
4756	formal_arg->sym->attr.flavor = FL_VARIABLE;
4757	formal_arg->sym->attr.dummy = 1;
4758
4759	/* Do not treat an actual deferred-length character argument wrongly
4760	as template for the formal argument. */
4761	if (formal_arg->sym->ts.type == BT_CHARACTER
4762	&& !(formal_arg->sym->attr.allocatable
4763	|| formal_arg->sym->attr.pointer))
4764	formal_arg->sym->ts.deferred = false;
4765
4766	if (formal_arg->sym->ts.type == BT_CHARACTER)
4767	formal_arg->sym->ts.u.cl = gfc_new_charlen (ns: gfc_current_ns, NULL);
4768
4769	/* If this isn't the first arg, set up the next ptr. For the
4770	last arg built, the formal_arg->next will never get set to
4771	anything other than NULL. */
4772	if (formal_prev != NULL)
4773	formal_prev->next = formal_arg;
4774	else
4775	formal_arg->next = NULL;
4776
4777	formal_prev = formal_arg;
4778
4779	/* Add arg to list of formal args. */
4780	add_formal_arg (head: &head, tail: &tail, formal_arg, param_sym: formal_arg->sym);
4781
4782	/* Validate changes. */
4783	gfc_commit_symbol (sym: formal_arg->sym);
4784	if (actual)
4785	act_arg = act_arg->next;
4786	}
4787
4788	/* Add the interface to the symbol. */
4789	add_proc_interface (sym: dest, source: IFSRC_DECL, formal: head);
4790
4791	/* Store the formal namespace information. */
4792	if (dest->formal != NULL)
4793	/* The current ns should be that for the dest proc. */
4794	dest->formal_ns = gfc_current_ns;
4795	/* Restore the current namespace to what it was on entry. */
4796	gfc_current_ns = parent_ns;
4797	}
4798
4799
4800	static int
4801	std_for_isocbinding_symbol (int id)
4802	{
4803	switch (id)
4804	{
4805	#define NAMED_INTCST(a,b,c,d) \
4806	case a:\
4807	return d;
4808	#include "iso-c-binding.def"
4809	#undef NAMED_INTCST
4810
4811	#define NAMED_FUNCTION(a,b,c,d) \
4812	case a:\
4813	return d;
4814	#define NAMED_SUBROUTINE(a,b,c,d) \
4815	case a:\
4816	return d;
4817	#include "iso-c-binding.def"
4818	#undef NAMED_FUNCTION
4819	#undef NAMED_SUBROUTINE
4820
4821	default:
4822	return GFC_STD_F2003;
4823	}
4824	}
4825
4826	/* Generate the given set of C interoperable kind objects, or all
4827	interoperable kinds. This function will only be given kind objects
4828	for valid iso_c_binding defined types because this is verified when
4829	the 'use' statement is parsed. If the user gives an 'only' clause,
4830	the specific kinds are looked up; if they don't exist, an error is
4831	reported. If the user does not give an 'only' clause, all
4832	iso_c_binding symbols are generated. If a list of specific kinds
4833	is given, it must have a NULL in the first empty spot to mark the
4834	end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
4835	point to the symtree for c_(fun)ptr. */
4836
4837	gfc_symtree *
4838	generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
4839	const char *local_name, gfc_symtree *dt_symtree,
4840	bool hidden)
4841	{
4842	const char *const name = (local_name && local_name[0])
4843	? local_name : c_interop_kinds_table[s].name;
4844	gfc_symtree *tmp_symtree;
4845	gfc_symbol *tmp_sym = NULL;
4846	int index;
4847
4848	if (gfc_notification_std (std_for_isocbinding_symbol (id: s)) == ERROR)
4849	return NULL;
4850
4851	tmp_symtree = gfc_find_symtree (st: gfc_current_ns->sym_root, name);
4852	if (hidden
4853	&& (!tmp_symtree || !tmp_symtree->n.sym
4854	|| tmp_symtree->n.sym->from_intmod != INTMOD_ISO_C_BINDING
4855	|| tmp_symtree->n.sym->intmod_sym_id != s))
4856	tmp_symtree = NULL;
4857
4858	/* Already exists in this scope so don't re-add it. */
4859	if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
4860	&& (!tmp_sym->attr.generic
4861	|| (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL)
4862	&& tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
4863	{
4864	if (tmp_sym->attr.flavor == FL_DERIVED
4865	&& !get_iso_c_binding_dt (sym_id: tmp_sym->intmod_sym_id))
4866	{
4867	if (gfc_derived_types)
4868	{
4869	tmp_sym->dt_next = gfc_derived_types->dt_next;
4870	gfc_derived_types->dt_next = tmp_sym;
4871	}
4872	else
4873	{
4874	tmp_sym->dt_next = tmp_sym;
4875	}
4876	gfc_derived_types = tmp_sym;
4877	}
4878
4879	return tmp_symtree;
4880	}
4881
4882	/* Create the sym tree in the current ns. */
4883	if (hidden)
4884	{
4885	tmp_symtree = gfc_get_unique_symtree (ns: gfc_current_ns);
4886	tmp_sym = gfc_new_symbol (name, ns: gfc_current_ns);
4887
4888	/* Add to the list of tentative symbols. */
4889	latest_undo_chgset->syms.safe_push (obj: tmp_sym);
4890	tmp_sym->old_symbol = NULL;
4891	tmp_sym->mark = 1;
4892	tmp_sym->gfc_new = 1;
4893
4894	tmp_symtree->n.sym = tmp_sym;
4895	tmp_sym->refs++;
4896	}
4897	else
4898	{
4899	gfc_get_sym_tree (name, ns: gfc_current_ns, result: &tmp_symtree, allow_subroutine: false);
4900	gcc_assert (tmp_symtree);
4901	tmp_sym = tmp_symtree->n.sym;
4902	}
4903
4904	/* Say what module this symbol belongs to. */
4905	tmp_sym->module = gfc_get_string ("%s", mod_name);
4906	tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4907	tmp_sym->intmod_sym_id = s;
4908	tmp_sym->attr.is_iso_c = 1;
4909	tmp_sym->attr.use_assoc = 1;
4910
4911	gcc_assert (dt_symtree == NULL || s == ISOCBINDING_NULL_FUNPTR
4912	|| s == ISOCBINDING_NULL_PTR);
4913
4914	switch (s)
4915	{
4916
4917	#define NAMED_INTCST(a,b,c,d) case a :
4918	#define NAMED_REALCST(a,b,c,d) case a :
4919	#define NAMED_CMPXCST(a,b,c,d) case a :
4920	#define NAMED_LOGCST(a,b,c) case a :
4921	#define NAMED_CHARKNDCST(a,b,c) case a :
4922	#include "iso-c-binding.def"
4923
4924	tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4925	c_interop_kinds_table[s].value);
4926
4927	/* Initialize an integer constant expression node. */
4928	tmp_sym->attr.flavor = FL_PARAMETER;
4929	tmp_sym->ts.type = BT_INTEGER;
4930	tmp_sym->ts.kind = gfc_default_integer_kind;
4931
4932	/* Mark this type as a C interoperable one. */
4933	tmp_sym->ts.is_c_interop = 1;
4934	tmp_sym->ts.is_iso_c = 1;
4935	tmp_sym->value->ts.is_c_interop = 1;
4936	tmp_sym->value->ts.is_iso_c = 1;
4937	tmp_sym->attr.is_c_interop = 1;
4938
4939	/* Tell what f90 type this c interop kind is valid. */
4940	tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
4941
4942	break;
4943
4944
4945	#define NAMED_CHARCST(a,b,c) case a :
4946	#include "iso-c-binding.def"
4947
4948	/* Initialize an integer constant expression node for the
4949	length of the character. */
4950	tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
4951	&gfc_current_locus, NULL, len: 1);
4952	tmp_sym->value->ts.is_c_interop = 1;
4953	tmp_sym->value->ts.is_iso_c = 1;
4954	tmp_sym->value->value.character.length = 1;
4955	tmp_sym->value->value.character.string[0]
4956	= (gfc_char_t) c_interop_kinds_table[s].value;
4957	tmp_sym->ts.u.cl = gfc_new_charlen (ns: gfc_current_ns, NULL);
4958	tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
4959	NULL, 1);
4960
4961	/* May not need this in both attr and ts, but do need in
4962	attr for writing module file. */
4963	tmp_sym->attr.is_c_interop = 1;
4964
4965	tmp_sym->attr.flavor = FL_PARAMETER;
4966	tmp_sym->ts.type = BT_CHARACTER;
4967
4968	/* Need to set it to the C_CHAR kind. */
4969	tmp_sym->ts.kind = gfc_default_character_kind;
4970
4971	/* Mark this type as a C interoperable one. */
4972	tmp_sym->ts.is_c_interop = 1;
4973	tmp_sym->ts.is_iso_c = 1;
4974
4975	/* Tell what f90 type this c interop kind is valid. */
4976	tmp_sym->ts.f90_type = BT_CHARACTER;
4977
4978	break;
4979
4980	case ISOCBINDING_PTR:
4981	case ISOCBINDING_FUNPTR:
4982	{
4983	gfc_symbol *dt_sym;
4984	gfc_component *tmp_comp = NULL;
4985
4986	/* Generate real derived type. */
4987	if (hidden)
4988	dt_sym = tmp_sym;
4989	else
4990	{
4991	const char *hidden_name;
4992	gfc_interface *intr, *head;
4993
4994	hidden_name = gfc_dt_upper_string (tmp_sym->name);
4995	tmp_symtree = gfc_find_symtree (st: gfc_current_ns->sym_root,
4996	name: hidden_name);
4997	gcc_assert (tmp_symtree == NULL);
4998	gfc_get_sym_tree (name: hidden_name, ns: gfc_current_ns, result: &tmp_symtree, allow_subroutine: false);
4999	dt_sym = tmp_symtree->n.sym;
5000	dt_sym->name = gfc_get_string (s == ISOCBINDING_PTR
5001	? "c_ptr" : "c_funptr");
5002
5003	/* Generate an artificial generic function. */
5004	head = tmp_sym->generic;
5005	intr = gfc_get_interface ();
5006	intr->sym = dt_sym;
5007	intr->where = gfc_current_locus;
5008	intr->next = head;
5009	tmp_sym->generic = intr;
5010
5011	if (!tmp_sym->attr.generic
5012	&& !gfc_add_generic (attr: &tmp_sym->attr, name: tmp_sym->name, NULL))
5013	return NULL;
5014
5015	if (!tmp_sym->attr.function
5016	&& !gfc_add_function (attr: &tmp_sym->attr, name: tmp_sym->name, NULL))
5017	return NULL;
5018	}
5019
5020	/* Say what module this symbol belongs to. */
5021	dt_sym->module = gfc_get_string ("%s", mod_name);
5022	dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
5023	dt_sym->intmod_sym_id = s;
5024	dt_sym->attr.use_assoc = 1;
5025
5026	/* Initialize an integer constant expression node. */
5027	dt_sym->attr.flavor = FL_DERIVED;
5028	dt_sym->ts.is_c_interop = 1;
5029	dt_sym->attr.is_c_interop = 1;
5030	dt_sym->attr.private_comp = 1;
5031	dt_sym->component_access = ACCESS_PRIVATE;
5032	dt_sym->ts.is_iso_c = 1;
5033	dt_sym->ts.type = BT_DERIVED;
5034	dt_sym->ts.f90_type = BT_VOID;
5035
5036	/* A derived type must have the bind attribute to be
5037	interoperable (J3/04-007, Section 15.2.3), even though
5038	the binding label is not used. */
5039	dt_sym->attr.is_bind_c = 1;
5040
5041	dt_sym->attr.referenced = 1;
5042	dt_sym->ts.u.derived = dt_sym;
5043
5044	/* Add the symbol created for the derived type to the current ns. */
5045	if (gfc_derived_types)
5046	{
5047	dt_sym->dt_next = gfc_derived_types->dt_next;
5048	gfc_derived_types->dt_next = dt_sym;
5049	}
5050	else
5051	{
5052	dt_sym->dt_next = dt_sym;
5053	}
5054	gfc_derived_types = dt_sym;
5055
5056	gfc_add_component (sym: dt_sym, name: "c_address", component: &tmp_comp);
5057	if (tmp_comp == NULL)
5058	gcc_unreachable ();
5059
5060	tmp_comp->ts.type = BT_INTEGER;
5061
5062	/* Set this because the module will need to read/write this field. */
5063	tmp_comp->ts.f90_type = BT_INTEGER;
5064
5065	/* The kinds for c_ptr and c_funptr are the same. */
5066	index = get_c_kind ("c_ptr", c_interop_kinds_table);
5067	tmp_comp->ts.kind = c_interop_kinds_table[index].value;
5068	tmp_comp->attr.access = ACCESS_PRIVATE;
5069
5070	/* Mark the component as C interoperable. */
5071	tmp_comp->ts.is_c_interop = 1;
5072	}
5073
5074	break;
5075
5076	case ISOCBINDING_NULL_PTR:
5077	case ISOCBINDING_NULL_FUNPTR:
5078	gen_special_c_interop_ptr (tmp_sym, dt_symtree);
5079	break;
5080
5081	default:
5082	gcc_unreachable ();
5083	}
5084	gfc_commit_symbol (sym: tmp_sym);
5085	return tmp_symtree;
5086	}
5087
5088
5089	/* Check that a symbol is already typed. If strict is not set, an untyped
5090	symbol is acceptable for non-standard-conforming mode. */
5091
5092	bool
5093	gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
5094	bool strict, locus where)
5095	{
5096	gcc_assert (sym);
5097
5098	if (gfc_matching_prefix)
5099	return true;
5100
5101	/* Check for the type and try to give it an implicit one. */
5102	if (sym->ts.type == BT_UNKNOWN
5103	&& !gfc_set_default_type (sym, error_flag: 0, ns))
5104	{
5105	if (strict)
5106	{
5107	gfc_error ("Symbol %qs is used before it is typed at %L",
5108	sym->name, &where);
5109	return false;
5110	}
5111
5112	if (!gfc_notify_std (GFC_STD_GNU, "Symbol %qs is used before"
5113	" it is typed at %L", sym->name, &where))
5114	return false;
5115	}
5116
5117	/* Everything is ok. */
5118	return true;
5119	}
5120
5121
5122	/* Construct a typebound-procedure structure. Those are stored in a tentative
5123	list and marked `error' until symbols are committed. */
5124
5125	gfc_typebound_proc*
5126	gfc_get_typebound_proc (gfc_typebound_proc *tb0)
5127	{
5128	gfc_typebound_proc *result;
5129
5130	result = XCNEW (gfc_typebound_proc);
5131	if (tb0)
5132	*result = *tb0;
5133	result->error = 1;
5134
5135	latest_undo_chgset->tbps.safe_push (obj: result);
5136
5137	return result;
5138	}
5139
5140
5141	/* Get the super-type of a given derived type. */
5142
5143	gfc_symbol*
5144	gfc_get_derived_super_type (gfc_symbol* derived)
5145	{
5146	gcc_assert (derived);
5147
5148	if (derived->attr.generic)
5149	derived = gfc_find_dt_in_generic (derived);
5150
5151	if (!derived->attr.extension)
5152	return NULL;
5153
5154	gcc_assert (derived->components);
5155	gcc_assert (derived->components->ts.type == BT_DERIVED);
5156	gcc_assert (derived->components->ts.u.derived);
5157
5158	if (derived->components->ts.u.derived->attr.generic)
5159	return gfc_find_dt_in_generic (derived->components->ts.u.derived);
5160
5161	return derived->components->ts.u.derived;
5162	}
5163
5164
5165	/* Check if a derived type t2 is an extension of (or equal to) a type t1. */
5166
5167	bool
5168	gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
5169	{
5170	while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
5171	t2 = gfc_get_derived_super_type (derived: t2);
5172	return gfc_compare_derived_types (t1, t2);
5173	}
5174
5175
5176	/* Check if two typespecs are type compatible (F03:5.1.1.2):
5177	If ts1 is nonpolymorphic, ts2 must be the same type.
5178	If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
5179
5180	bool
5181	gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
5182	{
5183	bool is_class1 = (ts1->type == BT_CLASS);
5184	bool is_class2 = (ts2->type == BT_CLASS);
5185	bool is_derived1 = (ts1->type == BT_DERIVED);
5186	bool is_derived2 = (ts2->type == BT_DERIVED);
5187	bool is_union1 = (ts1->type == BT_UNION);
5188	bool is_union2 = (ts2->type == BT_UNION);
5189
5190	/* A boz-literal-constant has no type. */
5191	if (ts1->type == BT_BOZ || ts2->type == BT_BOZ)
5192	return false;
5193
5194	if (is_class1
5195	&& ts1->u.derived->components
5196	&& ((ts1->u.derived->attr.is_class
5197	&& ts1->u.derived->components->ts.u.derived->attr
5198	.unlimited_polymorphic)
5199	|| ts1->u.derived->attr.unlimited_polymorphic))
5200	return 1;
5201
5202	if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2
5203	&& !is_union1 && !is_union2)
5204	return (ts1->type == ts2->type);
5205
5206	if ((is_derived1 && is_derived2) || (is_union1 && is_union2))
5207	return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
5208
5209	if (is_derived1 && is_class2)
5210	return gfc_compare_derived_types (ts1->u.derived,
5211	ts2->u.derived->attr.is_class ?
5212	ts2->u.derived->components->ts.u.derived
5213	: ts2->u.derived);
5214	if (is_class1 && is_derived2)
5215	return gfc_type_is_extension_of (t1: ts1->u.derived->attr.is_class ?
5216	ts1->u.derived->components->ts.u.derived
5217	: ts1->u.derived,
5218	t2: ts2->u.derived);
5219	else if (is_class1 && is_class2)
5220	return gfc_type_is_extension_of (t1: ts1->u.derived->attr.is_class ?
5221	ts1->u.derived->components->ts.u.derived
5222	: ts1->u.derived,
5223	t2: ts2->u.derived->attr.is_class ?
5224	ts2->u.derived->components->ts.u.derived
5225	: ts2->u.derived);
5226	else
5227	return 0;
5228	}
5229
5230
5231	/* Find the parent-namespace of the current function. If we're inside
5232	BLOCK constructs, it may not be the current one. */
5233
5234	gfc_namespace*
5235	gfc_find_proc_namespace (gfc_namespace* ns)
5236	{
5237	while (ns->construct_entities)
5238	{
5239	ns = ns->parent;
5240	gcc_assert (ns);
5241	}
5242
5243	return ns;
5244	}
5245
5246
5247	/* Check if an associate-variable should be translated as an `implicit' pointer
5248	internally (if it is associated to a variable and not an array with
5249	descriptor). */
5250
5251	bool
5252	gfc_is_associate_pointer (gfc_symbol* sym)
5253	{
5254	if (!sym->assoc)
5255	return false;
5256
5257	if (sym->ts.type == BT_CLASS)
5258	return true;
5259
5260	if (sym->ts.type == BT_CHARACTER
5261	&& sym->ts.deferred
5262	&& sym->assoc->target
5263	&& sym->assoc->target->expr_type == EXPR_FUNCTION)
5264	return true;
5265
5266	if (!sym->assoc->variable)
5267	return false;
5268
5269	if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
5270	return false;
5271
5272	return true;
5273	}
5274
5275
5276	gfc_symbol *
5277	gfc_find_dt_in_generic (gfc_symbol *sym)
5278	{
5279	gfc_interface *intr = NULL;
5280
5281	if (!sym || gfc_fl_struct (sym->attr.flavor))
5282	return sym;
5283
5284	if (sym->attr.generic)
5285	for (intr = sym->generic; intr; intr = intr->next)
5286	if (gfc_fl_struct (intr->sym->attr.flavor))
5287	break;
5288	return intr ? intr->sym : NULL;
5289	}
5290
5291
5292	/* Get the dummy arguments from a procedure symbol. If it has been declared
5293	via a PROCEDURE statement with a named interface, ts.interface will be set
5294	and the arguments need to be taken from there. */
5295
5296	gfc_formal_arglist *
5297	gfc_sym_get_dummy_args (gfc_symbol *sym)
5298	{
5299	gfc_formal_arglist *dummies;
5300
5301	if (sym == NULL)
5302	return NULL;
5303
5304	dummies = sym->formal;
5305	if (dummies == NULL && sym->ts.interface != NULL)
5306	dummies = sym->ts.interface->formal;
5307
5308	return dummies;
5309	}
5310