1	/* Backend function setup
2	Copyright (C) 2002-2024 Free Software Foundation, Inc.
3	Contributed by Paul Brook
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	/* trans-decl.cc -- Handling of backend function and variable decls, etc */
22
23	#include "config.h"
24	#include "system.h"
25	#include "coretypes.h"
26	#include "target.h"
27	#include "function.h"
28	#include "tree.h"
29	#include "gfortran.h"
30	#include "gimple-expr.h" /* For create_tmp_var_raw. */
31	#include "trans.h"
32	#include "stringpool.h"
33	#include "cgraph.h"
34	#include "fold-const.h"
35	#include "stor-layout.h"
36	#include "varasm.h"
37	#include "attribs.h"
38	#include "dumpfile.h"
39	#include "toplev.h" /* For announce_function. */
40	#include "debug.h"
41	#include "constructor.h"
42	#include "trans-types.h"
43	#include "trans-array.h"
44	#include "trans-const.h"
45	/* Only for gfc_trans_code. Shouldn't need to include this. */
46	#include "trans-stmt.h"
47	#include "gomp-constants.h"
48	#include "gimplify.h"
49	#include "omp-general.h"
50	#include "attr-fnspec.h"
51	#include "tree-iterator.h"
52
53	#define MAX_LABEL_VALUE 99999
54
55
56	/* Holds the result of the function if no result variable specified. */
57
58	static GTY(()) tree current_fake_result_decl;
59	static GTY(()) tree parent_fake_result_decl;
60
61
62	/* Holds the variable DECLs for the current function. */
63
64	static GTY(()) tree saved_function_decls;
65	static GTY(()) tree saved_parent_function_decls;
66
67	/* Holds the variable DECLs that are locals. */
68
69	static GTY(()) tree saved_local_decls;
70
71	/* The namespace of the module we're currently generating. Only used while
72	outputting decls for module variables. Do not rely on this being set. */
73
74	static gfc_namespace *module_namespace;
75
76	/* The currently processed procedure symbol. */
77	static gfc_symbol* current_procedure_symbol = NULL;
78
79	/* The currently processed module. */
80	static struct module_htab_entry *cur_module;
81
82	/* With -fcoarray=lib: For generating the registering call
83	of static coarrays. */
84	static bool has_coarray_vars;
85	static stmtblock_t caf_init_block;
86
87
88	/* List of static constructor functions. */
89
90	tree gfc_static_ctors;
91
92
93	/* Whether we've seen a symbol from an IEEE module in the namespace. */
94	static int seen_ieee_symbol;
95
96	/* Function declarations for builtin library functions. */
97
98	tree gfor_fndecl_pause_numeric;
99	tree gfor_fndecl_pause_string;
100	tree gfor_fndecl_stop_numeric;
101	tree gfor_fndecl_stop_string;
102	tree gfor_fndecl_error_stop_numeric;
103	tree gfor_fndecl_error_stop_string;
104	tree gfor_fndecl_runtime_error;
105	tree gfor_fndecl_runtime_error_at;
106	tree gfor_fndecl_runtime_warning_at;
107	tree gfor_fndecl_os_error_at;
108	tree gfor_fndecl_generate_error;
109	tree gfor_fndecl_set_args;
110	tree gfor_fndecl_set_fpe;
111	tree gfor_fndecl_set_options;
112	tree gfor_fndecl_set_convert;
113	tree gfor_fndecl_set_record_marker;
114	tree gfor_fndecl_set_max_subrecord_length;
115	tree gfor_fndecl_ctime;
116	tree gfor_fndecl_fdate;
117	tree gfor_fndecl_ttynam;
118	tree gfor_fndecl_in_pack;
119	tree gfor_fndecl_in_unpack;
120	tree gfor_fndecl_associated;
121	tree gfor_fndecl_system_clock4;
122	tree gfor_fndecl_system_clock8;
123	tree gfor_fndecl_ieee_procedure_entry;
124	tree gfor_fndecl_ieee_procedure_exit;
125
126	/* Coarray run-time library function decls. */
127	tree gfor_fndecl_caf_init;
128	tree gfor_fndecl_caf_finalize;
129	tree gfor_fndecl_caf_this_image;
130	tree gfor_fndecl_caf_num_images;
131	tree gfor_fndecl_caf_register;
132	tree gfor_fndecl_caf_deregister;
133	tree gfor_fndecl_caf_get;
134	tree gfor_fndecl_caf_send;
135	tree gfor_fndecl_caf_sendget;
136	tree gfor_fndecl_caf_get_by_ref;
137	tree gfor_fndecl_caf_send_by_ref;
138	tree gfor_fndecl_caf_sendget_by_ref;
139	tree gfor_fndecl_caf_sync_all;
140	tree gfor_fndecl_caf_sync_memory;
141	tree gfor_fndecl_caf_sync_images;
142	tree gfor_fndecl_caf_stop_str;
143	tree gfor_fndecl_caf_stop_numeric;
144	tree gfor_fndecl_caf_error_stop;
145	tree gfor_fndecl_caf_error_stop_str;
146	tree gfor_fndecl_caf_atomic_def;
147	tree gfor_fndecl_caf_atomic_ref;
148	tree gfor_fndecl_caf_atomic_cas;
149	tree gfor_fndecl_caf_atomic_op;
150	tree gfor_fndecl_caf_lock;
151	tree gfor_fndecl_caf_unlock;
152	tree gfor_fndecl_caf_event_post;
153	tree gfor_fndecl_caf_event_wait;
154	tree gfor_fndecl_caf_event_query;
155	tree gfor_fndecl_caf_fail_image;
156	tree gfor_fndecl_caf_failed_images;
157	tree gfor_fndecl_caf_image_status;
158	tree gfor_fndecl_caf_stopped_images;
159	tree gfor_fndecl_caf_form_team;
160	tree gfor_fndecl_caf_change_team;
161	tree gfor_fndecl_caf_end_team;
162	tree gfor_fndecl_caf_sync_team;
163	tree gfor_fndecl_caf_get_team;
164	tree gfor_fndecl_caf_team_number;
165	tree gfor_fndecl_co_broadcast;
166	tree gfor_fndecl_co_max;
167	tree gfor_fndecl_co_min;
168	tree gfor_fndecl_co_reduce;
169	tree gfor_fndecl_co_sum;
170	tree gfor_fndecl_caf_is_present;
171	tree gfor_fndecl_caf_random_init;
172
173
174	/* Math functions. Many other math functions are handled in
175	trans-intrinsic.cc. */
176
177	gfc_powdecl_list gfor_fndecl_math_powi[4][3];
178	tree gfor_fndecl_math_ishftc4;
179	tree gfor_fndecl_math_ishftc8;
180	tree gfor_fndecl_math_ishftc16;
181
182
183	/* String functions. */
184
185	tree gfor_fndecl_compare_string;
186	tree gfor_fndecl_concat_string;
187	tree gfor_fndecl_string_len_trim;
188	tree gfor_fndecl_string_index;
189	tree gfor_fndecl_string_scan;
190	tree gfor_fndecl_string_verify;
191	tree gfor_fndecl_string_trim;
192	tree gfor_fndecl_string_minmax;
193	tree gfor_fndecl_adjustl;
194	tree gfor_fndecl_adjustr;
195	tree gfor_fndecl_select_string;
196	tree gfor_fndecl_compare_string_char4;
197	tree gfor_fndecl_concat_string_char4;
198	tree gfor_fndecl_string_len_trim_char4;
199	tree gfor_fndecl_string_index_char4;
200	tree gfor_fndecl_string_scan_char4;
201	tree gfor_fndecl_string_verify_char4;
202	tree gfor_fndecl_string_trim_char4;
203	tree gfor_fndecl_string_minmax_char4;
204	tree gfor_fndecl_adjustl_char4;
205	tree gfor_fndecl_adjustr_char4;
206	tree gfor_fndecl_select_string_char4;
207
208
209	/* Conversion between character kinds. */
210	tree gfor_fndecl_convert_char1_to_char4;
211	tree gfor_fndecl_convert_char4_to_char1;
212
213
214	/* Other misc. runtime library functions. */
215	tree gfor_fndecl_iargc;
216	tree gfor_fndecl_kill;
217	tree gfor_fndecl_kill_sub;
218	tree gfor_fndecl_is_contiguous0;
219
220
221	/* Intrinsic functions implemented in Fortran. */
222	tree gfor_fndecl_sc_kind;
223	tree gfor_fndecl_si_kind;
224	tree gfor_fndecl_sr_kind;
225
226	/* BLAS gemm functions. */
227	tree gfor_fndecl_sgemm;
228	tree gfor_fndecl_dgemm;
229	tree gfor_fndecl_cgemm;
230	tree gfor_fndecl_zgemm;
231
232	/* RANDOM_INIT function. */
233	tree gfor_fndecl_random_init; /* libgfortran, 1 image only. */
234
235	static void
236	gfc_add_decl_to_parent_function (tree decl)
237	{
238	gcc_assert (decl);
239	DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
240	DECL_NONLOCAL (decl) = 1;
241	DECL_CHAIN (decl) = saved_parent_function_decls;
242	saved_parent_function_decls = decl;
243	}
244
245	void
246	gfc_add_decl_to_function (tree decl)
247	{
248	gcc_assert (decl);
249	TREE_USED (decl) = 1;
250	DECL_CONTEXT (decl) = current_function_decl;
251	DECL_CHAIN (decl) = saved_function_decls;
252	saved_function_decls = decl;
253	}
254
255	static void
256	add_decl_as_local (tree decl)
257	{
258	gcc_assert (decl);
259	TREE_USED (decl) = 1;
260	DECL_CONTEXT (decl) = current_function_decl;
261	DECL_CHAIN (decl) = saved_local_decls;
262	saved_local_decls = decl;
263	}
264
265
266	/* Build a backend label declaration. Set TREE_USED for named labels.
267	The context of the label is always the current_function_decl. All
268	labels are marked artificial. */
269
270	tree
271	gfc_build_label_decl (tree label_id)
272	{
273	/* 2^32 temporaries should be enough. */
274	static unsigned int tmp_num = 1;
275	tree label_decl;
276	char *label_name;
277
278	if (label_id == NULL_TREE)
279	{
280	/* Build an internal label name. */
281	ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
282	label_id = get_identifier (label_name);
283	}
284	else
285	label_name = NULL;
286
287	/* Build the LABEL_DECL node. Labels have no type. */
288	label_decl = build_decl (input_location,
289	LABEL_DECL, label_id, void_type_node);
290	DECL_CONTEXT (label_decl) = current_function_decl;
291	SET_DECL_MODE (label_decl, VOIDmode);
292
293	/* We always define the label as used, even if the original source
294	file never references the label. We don't want all kinds of
295	spurious warnings for old-style Fortran code with too many
296	labels. */
297	TREE_USED (label_decl) = 1;
298
299	DECL_ARTIFICIAL (label_decl) = 1;
300	return label_decl;
301	}
302
303
304	/* Set the backend source location of a decl. */
305
306	void
307	gfc_set_decl_location (tree decl, locus * loc)
308	{
309	DECL_SOURCE_LOCATION (decl) = gfc_get_location (loc);
310	}
311
312
313	/* Return the backend label declaration for a given label structure,
314	or create it if it doesn't exist yet. */
315
316	tree
317	gfc_get_label_decl (gfc_st_label * lp)
318	{
319	if (lp->backend_decl)
320	return lp->backend_decl;
321	else
322	{
323	char label_name[GFC_MAX_SYMBOL_LEN + 1];
324	tree label_decl;
325
326	/* Validate the label declaration from the front end. */
327	gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
328
329	/* Build a mangled name for the label. */
330	sprintf (s: label_name, format: "__label_%.6d", lp->value);
331
332	/* Build the LABEL_DECL node. */
333	label_decl = gfc_build_label_decl (get_identifier (label_name));
334
335	/* Tell the debugger where the label came from. */
336	if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
337	gfc_set_decl_location (decl: label_decl, loc: &lp->where);
338	else
339	DECL_ARTIFICIAL (label_decl) = 1;
340
341	/* Store the label in the label list and return the LABEL_DECL. */
342	lp->backend_decl = label_decl;
343	return label_decl;
344	}
345	}
346
347	/* Return the name of an identifier. */
348
349	static const char *
350	sym_identifier (gfc_symbol *sym)
351	{
352	if (sym->attr.is_main_program && strcmp (s1: sym->name, s2: "main") == 0)
353	return "MAIN__";
354	else
355	return sym->name;
356	}
357
358	/* Convert a gfc_symbol to an identifier of the same name. */
359
360	static tree
361	gfc_sym_identifier (gfc_symbol * sym)
362	{
363	return get_identifier (sym_identifier (sym));
364	}
365
366	/* Construct mangled name from symbol name. */
367
368	static const char *
369	mangled_identifier (gfc_symbol *sym)
370	{
371	gfc_symbol *proc = sym->ns->proc_name;
372	static char name[3*GFC_MAX_MANGLED_SYMBOL_LEN + 14];
373	/* Prevent the mangling of identifiers that have an assigned
374	binding label (mainly those that are bind(c)). */
375
376	if (sym->attr.is_bind_c == 1 && sym->binding_label)
377	return sym->binding_label;
378
379	if (!sym->fn_result_spec
380	|| (sym->module && !(proc && proc->attr.flavor == FL_PROCEDURE)))
381	{
382	if (sym->module == NULL)
383	return sym_identifier (sym);
384	else
385	snprintf (s: name, maxlen: sizeof name, format: "__%s_MOD_%s", sym->module, sym->name);
386	}
387	else
388	{
389	/* This is an entity that is actually local to a module procedure
390	that appears in the result specification expression. Since
391	sym->module will be a zero length string, we use ns->proc_name
392	to provide the module name instead. */
393	if (proc && proc->module)
394	snprintf (s: name, maxlen: sizeof name, format: "__%s_MOD__%s_PROC_%s",
395	proc->module, proc->name, sym->name);
396	else
397	snprintf (s: name, maxlen: sizeof name, format: "__%s_PROC_%s",
398	proc->name, sym->name);
399	}
400
401	return name;
402	}
403
404	/* Get mangled identifier, adding the symbol to the global table if
405	it is not yet already there. */
406
407	static tree
408	gfc_sym_mangled_identifier (gfc_symbol * sym)
409	{
410	tree result;
411	gfc_gsymbol *gsym;
412	const char *name;
413
414	name = mangled_identifier (sym);
415	result = get_identifier (name);
416
417	gsym = gfc_find_gsymbol (gfc_gsym_root, name);
418	if (gsym == NULL)
419	{
420	gsym = gfc_get_gsymbol (name, bind_c: false);
421	gsym->ns = sym->ns;
422	gsym->sym_name = sym->name;
423	}
424
425	return result;
426	}
427
428	/* Construct mangled function name from symbol name. */
429
430	static tree
431	gfc_sym_mangled_function_id (gfc_symbol * sym)
432	{
433	int has_underscore;
434	char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
435
436	/* It may be possible to simply use the binding label if it's
437	provided, and remove the other checks. Then we could use it
438	for other things if we wished. */
439	if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
440	sym->binding_label)
441	/* use the binding label rather than the mangled name */
442	return get_identifier (sym->binding_label);
443
444	if ((sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
445	|| (sym->module != NULL && (sym->attr.external
446	|| sym->attr.if_source == IFSRC_IFBODY)))
447	&& !sym->attr.module_procedure)
448	{
449	/* Main program is mangled into MAIN__. */
450	if (sym->attr.is_main_program)
451	return get_identifier ("MAIN__");
452
453	/* Intrinsic procedures are never mangled. */
454	if (sym->attr.proc == PROC_INTRINSIC)
455	return get_identifier (sym->name);
456
457	if (flag_underscoring)
458	{
459	has_underscore = strchr (s: sym->name, c: '_') != 0;
460	if (flag_second_underscore && has_underscore)
461	snprintf (s: name, maxlen: sizeof name, format: "%s__", sym->name);
462	else
463	snprintf (s: name, maxlen: sizeof name, format: "%s_", sym->name);
464	return get_identifier (name);
465	}
466	else
467	return get_identifier (sym->name);
468	}
469	else
470	{
471	snprintf (s: name, maxlen: sizeof name, format: "__%s_MOD_%s", sym->module, sym->name);
472	return get_identifier (name);
473	}
474	}
475
476
477	void
478	gfc_set_decl_assembler_name (tree decl, tree name)
479	{
480	tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
481	SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
482	}
483
484
485	/* Returns true if a variable of specified size should go on the stack. */
486
487	bool
488	gfc_can_put_var_on_stack (tree size)
489	{
490	unsigned HOST_WIDE_INT low;
491
492	if (!INTEGER_CST_P (size))
493	return 0;
494
495	if (flag_max_stack_var_size < 0)
496	return 1;
497
498	if (!tree_fits_uhwi_p (size))
499	return 0;
500
501	low = TREE_INT_CST_LOW (size);
502	if (low > (unsigned HOST_WIDE_INT) flag_max_stack_var_size)
503	return 0;
504
505	/* TODO: Set a per-function stack size limit. */
506
507	return 1;
508	}
509
510
511	/* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
512	an expression involving its corresponding pointer. There are
513	2 cases; one for variable size arrays, and one for everything else,
514	because variable-sized arrays require one fewer level of
515	indirection. */
516
517	static void
518	gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
519	{
520	tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
521	tree value;
522
523	/* Parameters need to be dereferenced. */
524	if (sym->cp_pointer->attr.dummy)
525	ptr_decl = build_fold_indirect_ref_loc (input_location,
526	ptr_decl);
527
528	/* Check to see if we're dealing with a variable-sized array. */
529	if (sym->attr.dimension
530	&& TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
531	{
532	/* These decls will be dereferenced later, so we don't dereference
533	them here. */
534	value = convert (TREE_TYPE (decl), ptr_decl);
535	}
536	else
537	{
538	ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
539	ptr_decl);
540	value = build_fold_indirect_ref_loc (input_location,
541	ptr_decl);
542	}
543
544	SET_DECL_VALUE_EXPR (decl, value);
545	DECL_HAS_VALUE_EXPR_P (decl) = 1;
546	GFC_DECL_CRAY_POINTEE (decl) = 1;
547	}
548
549
550	/* Finish processing of a declaration without an initial value. */
551
552	static void
553	gfc_finish_decl (tree decl)
554	{
555	gcc_assert (TREE_CODE (decl) == PARM_DECL
556	|| DECL_INITIAL (decl) == NULL_TREE);
557
558	if (!VAR_P (decl))
559	return;
560
561	if (DECL_SIZE (decl) == NULL_TREE
562	&& COMPLETE_TYPE_P (TREE_TYPE (decl)))
563	layout_decl (decl, 0);
564
565	/* A few consistency checks. */
566	/* A static variable with an incomplete type is an error if it is
567	initialized. Also if it is not file scope. Otherwise, let it
568	through, but if it is not `extern' then it may cause an error
569	message later. */
570	/* An automatic variable with an incomplete type is an error. */
571
572	/* We should know the storage size. */
573	gcc_assert (DECL_SIZE (decl) != NULL_TREE
574	|| (TREE_STATIC (decl)
575	? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
576	: DECL_EXTERNAL (decl)));
577
578	/* The storage size should be constant. */
579	gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
580	|| !DECL_SIZE (decl)
581	|| TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
582	}
583
584
585	/* Handle setting of GFC_DECL_SCALAR* on DECL. */
586
587	void
588	gfc_finish_decl_attrs (tree decl, symbol_attribute *attr)
589	{
590	if (!attr->dimension && !attr->codimension)
591	{
592	/* Handle scalar allocatable variables. */
593	if (attr->allocatable)
594	{
595	gfc_allocate_lang_decl (decl);
596	GFC_DECL_SCALAR_ALLOCATABLE (decl) = 1;
597	}
598	/* Handle scalar pointer variables. */
599	if (attr->pointer)
600	{
601	gfc_allocate_lang_decl (decl);
602	GFC_DECL_SCALAR_POINTER (decl) = 1;
603	}
604	if (attr->target)
605	{
606	gfc_allocate_lang_decl (decl);
607	GFC_DECL_SCALAR_TARGET (decl) = 1;
608	}
609	}
610	}
611
612
613	/* Apply symbol attributes to a variable, and add it to the function scope. */
614
615	static void
616	gfc_finish_var_decl (tree decl, gfc_symbol * sym)
617	{
618	tree new_type;
619
620	/* Set DECL_VALUE_EXPR for Cray Pointees. */
621	if (sym->attr.cray_pointee)
622	gfc_finish_cray_pointee (decl, sym);
623
624	/* TREE_ADDRESSABLE means the address of this variable is actually needed.
625	This is the equivalent of the TARGET variables.
626	We also need to set this if the variable is passed by reference in a
627	CALL statement. */
628	if (sym->attr.target)
629	TREE_ADDRESSABLE (decl) = 1;
630
631	/* If it wasn't used we wouldn't be getting it. */
632	TREE_USED (decl) = 1;
633
634	if (sym->attr.flavor == FL_PARAMETER
635	&& (sym->attr.dimension || sym->ts.type == BT_DERIVED))
636	TREE_READONLY (decl) = 1;
637
638	/* Chain this decl to the pending declarations. Don't do pushdecl()
639	because this would add them to the current scope rather than the
640	function scope. */
641	if (current_function_decl != NULL_TREE)
642	{
643	if (sym->ns->proc_name
644	&& (sym->ns->proc_name->backend_decl == current_function_decl
645	|| sym->result == sym))
646	gfc_add_decl_to_function (decl);
647	else if (sym->ns->proc_name
648	&& sym->ns->proc_name->attr.flavor == FL_LABEL)
649	/* This is a BLOCK construct. */
650	add_decl_as_local (decl);
651	else if (sym->ns->omp_affinity_iterators)
652	/* This is a block-local iterator. */
653	add_decl_as_local (decl);
654	else
655	gfc_add_decl_to_parent_function (decl);
656	}
657
658	if (sym->attr.cray_pointee)
659	return;
660
661	if(sym->attr.is_bind_c == 1 && sym->binding_label)
662	{
663	/* We need to put variables that are bind(c) into the common
664	segment of the object file, because this is what C would do.
665	gfortran would typically put them in either the BSS or
666	initialized data segments, and only mark them as common if
667	they were part of common blocks. However, if they are not put
668	into common space, then C cannot initialize global Fortran
669	variables that it interoperates with and the draft says that
670	either Fortran or C should be able to initialize it (but not
671	both, of course.) (J3/04-007, section 15.3). */
672	TREE_PUBLIC(decl) = 1;
673	DECL_COMMON(decl) = 1;
674	if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
675	{
676	DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
677	DECL_VISIBILITY_SPECIFIED (decl) = true;
678	}
679	}
680
681	/* If a variable is USE associated, it's always external. */
682	if (sym->attr.use_assoc || sym->attr.used_in_submodule)
683	{
684	DECL_EXTERNAL (decl) = 1;
685	TREE_PUBLIC (decl) = 1;
686	}
687	else if (sym->fn_result_spec && !sym->ns->proc_name->module)
688	{
689
690	if (sym->ns->proc_name->attr.if_source != IFSRC_DECL)
691	DECL_EXTERNAL (decl) = 1;
692	else
693	TREE_STATIC (decl) = 1;
694
695	TREE_PUBLIC (decl) = 1;
696	}
697	else if (sym->module && !sym->attr.result && !sym->attr.dummy)
698	{
699	/* TODO: Don't set sym->module for result or dummy variables. */
700	gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
701
702	TREE_PUBLIC (decl) = 1;
703	TREE_STATIC (decl) = 1;
704	if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
705	{
706	DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
707	DECL_VISIBILITY_SPECIFIED (decl) = true;
708	}
709	}
710
711	/* Derived types are a bit peculiar because of the possibility of
712	a default initializer; this must be applied each time the variable
713	comes into scope it therefore need not be static. These variables
714	are SAVE_NONE but have an initializer. Otherwise explicitly
715	initialized variables are SAVE_IMPLICIT and explicitly saved are
716	SAVE_EXPLICIT. */
717	if (!sym->attr.use_assoc
718	&& (sym->attr.save != SAVE_NONE || sym->attr.data
719	|| (sym->value && sym->ns->proc_name->attr.is_main_program)
720	|| (flag_coarray == GFC_FCOARRAY_LIB
721	&& sym->attr.codimension && !sym->attr.allocatable)))
722	TREE_STATIC (decl) = 1;
723
724	/* If derived-type variables with DTIO procedures are not made static
725	some bits of code referencing them get optimized away.
726	TODO Understand why this is so and fix it. */
727	if (!sym->attr.use_assoc
728	&& ((sym->ts.type == BT_DERIVED
729	&& sym->ts.u.derived->attr.has_dtio_procs)
730	|| (sym->ts.type == BT_CLASS
731	&& CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs)))
732	TREE_STATIC (decl) = 1;
733
734	/* Treat asynchronous variables the same as volatile, for now. */
735	if (sym->attr.volatile_ || sym->attr.asynchronous)
736	{
737	TREE_THIS_VOLATILE (decl) = 1;
738	TREE_SIDE_EFFECTS (decl) = 1;
739	new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
740	TREE_TYPE (decl) = new_type;
741	}
742
743	/* Keep variables larger than max-stack-var-size off stack. */
744	if (!(sym->ns->proc_name && sym->ns->proc_name->attr.recursive)
745	&& !sym->attr.automatic
746	&& !sym->attr.associate_var
747	&& sym->attr.save != SAVE_EXPLICIT
748	&& sym->attr.save != SAVE_IMPLICIT
749	&& INTEGER_CST_P (DECL_SIZE_UNIT (decl))
750	&& !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
751	/* Put variable length auto array pointers always into stack. */
752	&& (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
753	|| sym->attr.dimension == 0
754	|| sym->as->type != AS_EXPLICIT
755	|| sym->attr.pointer
756	|| sym->attr.allocatable)
757	&& !DECL_ARTIFICIAL (decl))
758	{
759	if (flag_max_stack_var_size > 0
760	&& !(sym->ns->proc_name
761	&& sym->ns->proc_name->attr.is_main_program))
762	gfc_warning (opt: OPT_Wsurprising,
763	"Array %qs at %L is larger than limit set by "
764	"%<-fmax-stack-var-size=%>, moved from stack to static "
765	"storage. This makes the procedure unsafe when called "
766	"recursively, or concurrently from multiple threads. "
767	"Consider increasing the %<-fmax-stack-var-size=%> "
768	"limit (or use %<-frecursive%>, which implies "
769	"unlimited %<-fmax-stack-var-size%>) - or change the "
770	"code to use an ALLOCATABLE array. If the variable is "
771	"never accessed concurrently, this warning can be "
772	"ignored, and the variable could also be declared with "
773	"the SAVE attribute.",
774	sym->name, &sym->declared_at);
775
776	TREE_STATIC (decl) = 1;
777
778	/* Because the size of this variable isn't known until now, we may have
779	greedily added an initializer to this variable (in build_init_assign)
780	even though the max-stack-var-size indicates the variable should be
781	static. Therefore we rip out the automatic initializer here and
782	replace it with a static one. */
783	gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name);
784	gfc_code *prev = NULL;
785	gfc_code *code = sym->ns->code;
786	while (code && code->op == EXEC_INIT_ASSIGN)
787	{
788	/* Look for an initializer meant for this symbol. */
789	if (code->expr1->symtree == st)
790	{
791	if (prev)
792	prev->next = code->next;
793	else
794	sym->ns->code = code->next;
795
796	break;
797	}
798
799	prev = code;
800	code = code->next;
801	}
802	if (code && code->op == EXEC_INIT_ASSIGN)
803	{
804	/* Keep the init expression for a static initializer. */
805	sym->value = code->expr2;
806	/* Cleanup the defunct code object, without freeing the init expr. */
807	code->expr2 = NULL;
808	gfc_free_statement (code);
809	free (ptr: code);
810	}
811	}
812
813	/* Handle threadprivate variables. */
814	if (sym->attr.threadprivate
815	&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
816	set_decl_tls_model (decl, decl_default_tls_model (decl));
817
818	/* Mark weak variables. */
819	if (sym->attr.ext_attr & (1 << EXT_ATTR_WEAK))
820	declare_weak (decl);
821
822	gfc_finish_decl_attrs (decl, attr: &sym->attr);
823	}
824
825
826	/* Allocate the lang-specific part of a decl. */
827
828	void
829	gfc_allocate_lang_decl (tree decl)
830	{
831	if (DECL_LANG_SPECIFIC (decl) == NULL)
832	DECL_LANG_SPECIFIC (decl) = ggc_cleared_alloc<struct lang_decl> ();
833	}
834
835	/* Remember a symbol to generate initialization/cleanup code at function
836	entry/exit. */
837
838	static void
839	gfc_defer_symbol_init (gfc_symbol * sym)
840	{
841	gfc_symbol *p;
842	gfc_symbol *last;
843	gfc_symbol *head;
844
845	/* Don't add a symbol twice. */
846	if (sym->tlink)
847	return;
848
849	last = head = sym->ns->proc_name;
850	p = last->tlink;
851
852	/* Make sure that setup code for dummy variables which are used in the
853	setup of other variables is generated first. */
854	if (sym->attr.dummy)
855	{
856	/* Find the first dummy arg seen after us, or the first non-dummy arg.
857	This is a circular list, so don't go past the head. */
858	while (p != head
859	&& (!p->attr.dummy || p->dummy_order > sym->dummy_order))
860	{
861	last = p;
862	p = p->tlink;
863	}
864	}
865	/* Insert in between last and p. */
866	last->tlink = sym;
867	sym->tlink = p;
868	}
869
870
871	/* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the
872	backend_decl for a module symbol, if it all ready exists. If the
873	module gsymbol does not exist, it is created. If the symbol does
874	not exist, it is added to the gsymbol namespace. Returns true if
875	an existing backend_decl is found. */
876
877	bool
878	gfc_get_module_backend_decl (gfc_symbol *sym)
879	{
880	gfc_gsymbol *gsym;
881	gfc_symbol *s;
882	gfc_symtree *st;
883
884	gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
885
886	if (!gsym || (gsym->ns && gsym->type == GSYM_MODULE))
887	{
888	st = NULL;
889	s = NULL;
890
891	/* Check for a symbol with the same name. */
892	if (gsym)
893	gfc_find_symbol (sym->name, gsym->ns, 0, &s);
894
895	if (!s)
896	{
897	if (!gsym)
898	{
899	gsym = gfc_get_gsymbol (sym->module, bind_c: false);
900	gsym->type = GSYM_MODULE;
901	gsym->ns = gfc_get_namespace (NULL, 0);
902	}
903
904	st = gfc_new_symtree (&gsym->ns->sym_root, sym->name);
905	st->n.sym = sym;
906	sym->refs++;
907	}
908	else if (gfc_fl_struct (sym->attr.flavor))
909	{
910	if (s && s->attr.flavor == FL_PROCEDURE)
911	{
912	gfc_interface *intr;
913	gcc_assert (s->attr.generic);
914	for (intr = s->generic; intr; intr = intr->next)
915	if (gfc_fl_struct (intr->sym->attr.flavor))
916	{
917	s = intr->sym;
918	break;
919	}
920	}
921
922	/* Normally we can assume that s is a derived-type symbol since it
923	shares a name with the derived-type sym. However if sym is a
924	STRUCTURE, it may in fact share a name with any other basic type
925	variable. If s is in fact of derived type then we can continue
926	looking for a duplicate type declaration. */
927	if (sym->attr.flavor == FL_STRUCT && s->ts.type == BT_DERIVED)
928	{
929	s = s->ts.u.derived;
930	}
931
932	if (gfc_fl_struct (s->attr.flavor) && !s->backend_decl)
933	{
934	if (s->attr.flavor == FL_UNION)
935	s->backend_decl = gfc_get_union_type (s);
936	else
937	s->backend_decl = gfc_get_derived_type (derived: s);
938	}
939	gfc_copy_dt_decls_ifequal (s, sym, true);
940	return true;
941	}
942	else if (s->backend_decl)
943	{
944	if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
945	gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
946	true);
947	else if (sym->ts.type == BT_CHARACTER)
948	sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
949	sym->backend_decl = s->backend_decl;
950	return true;
951	}
952	}
953	return false;
954	}
955
956
957	/* Create an array index type variable with function scope. */
958
959	static tree
960	create_index_var (const char * pfx, int nest)
961	{
962	tree decl;
963
964	decl = gfc_create_var_np (gfc_array_index_type, pfx);
965	if (nest)
966	gfc_add_decl_to_parent_function (decl);
967	else
968	gfc_add_decl_to_function (decl);
969	return decl;
970	}
971
972
973	/* Create variables to hold all the non-constant bits of info for a
974	descriptorless array. Remember these in the lang-specific part of the
975	type. */
976
977	static void
978	gfc_build_qualified_array (tree decl, gfc_symbol * sym)
979	{
980	tree type;
981	int dim;
982	int nest;
983	gfc_namespace* procns;
984	symbol_attribute *array_attr;
985	gfc_array_spec *as;
986	bool is_classarray = IS_CLASS_ARRAY (sym);
987
988	type = TREE_TYPE (decl);
989	array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
990	as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
991
992	/* We just use the descriptor, if there is one. */
993	if (GFC_DESCRIPTOR_TYPE_P (type))
994	return;
995
996	gcc_assert (GFC_ARRAY_TYPE_P (type));
997	procns = gfc_find_proc_namespace (sym->ns);
998	nest = (procns->proc_name->backend_decl != current_function_decl)
999	&& !sym->attr.contained;
1000
1001	if (array_attr->codimension && flag_coarray == GFC_FCOARRAY_LIB
1002	&& as->type != AS_ASSUMED_SHAPE
1003	&& GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE)
1004	{
1005	tree token;
1006	tree token_type = build_qualified_type (pvoid_type_node,
1007	TYPE_QUAL_RESTRICT);
1008
1009	if (sym->module && (sym->attr.use_assoc
1010	|| sym->ns->proc_name->attr.flavor == FL_MODULE))
1011	{
1012	tree token_name
1013	= get_identifier (gfc_get_string (GFC_PREFIX ("caf_token%s"),
1014	IDENTIFIER_POINTER (gfc_sym_mangled_identifier (sym))));
1015	token = build_decl (DECL_SOURCE_LOCATION (decl), VAR_DECL, token_name,
1016	token_type);
1017	if (sym->attr.use_assoc)
1018	DECL_EXTERNAL (token) = 1;
1019	else
1020	TREE_STATIC (token) = 1;
1021
1022	TREE_PUBLIC (token) = 1;
1023
1024	if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
1025	{
1026	DECL_VISIBILITY (token) = VISIBILITY_HIDDEN;
1027	DECL_VISIBILITY_SPECIFIED (token) = true;
1028	}
1029	}
1030	else
1031	{
1032	token = gfc_create_var_np (token_type, "caf_token");
1033	TREE_STATIC (token) = 1;
1034	}
1035
1036	GFC_TYPE_ARRAY_CAF_TOKEN (type) = token;
1037	DECL_ARTIFICIAL (token) = 1;
1038	DECL_NONALIASED (token) = 1;
1039
1040	if (sym->module && !sym->attr.use_assoc)
1041	{
1042	pushdecl (token);
1043	DECL_CONTEXT (token) = sym->ns->proc_name->backend_decl;
1044	gfc_module_add_decl (cur_module, token);
1045	}
1046	else if (sym->attr.host_assoc
1047	&& TREE_CODE (DECL_CONTEXT (current_function_decl))
1048	!= TRANSLATION_UNIT_DECL)
1049	gfc_add_decl_to_parent_function (decl: token);
1050	else
1051	gfc_add_decl_to_function (decl: token);
1052	}
1053
1054	for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
1055	{
1056	if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
1057	{
1058	GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var (pfx: "lbound", nest);
1059	suppress_warning (GFC_TYPE_ARRAY_LBOUND (type, dim));
1060	}
1061	/* Don't try to use the unknown bound for assumed shape arrays. */
1062	if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
1063	&& (as->type != AS_ASSUMED_SIZE
1064	|| dim < GFC_TYPE_ARRAY_RANK (type) - 1))
1065	{
1066	GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var (pfx: "ubound", nest);
1067	suppress_warning (GFC_TYPE_ARRAY_UBOUND (type, dim));
1068	}
1069
1070	if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
1071	{
1072	GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var (pfx: "stride", nest);
1073	suppress_warning (GFC_TYPE_ARRAY_STRIDE (type, dim));
1074	}
1075	}
1076	for (dim = GFC_TYPE_ARRAY_RANK (type);
1077	dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++)
1078	{
1079	if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
1080	{
1081	GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var (pfx: "lbound", nest);
1082	suppress_warning (GFC_TYPE_ARRAY_LBOUND (type, dim));
1083	}
1084	/* Don't try to use the unknown ubound for the last coarray dimension. */
1085	if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
1086	&& dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1)
1087	{
1088	GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var (pfx: "ubound", nest);
1089	suppress_warning (GFC_TYPE_ARRAY_UBOUND (type, dim));
1090	}
1091	}
1092	if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
1093	{
1094	GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
1095	"offset");
1096	suppress_warning (GFC_TYPE_ARRAY_OFFSET (type));
1097
1098	if (nest)
1099	gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
1100	else
1101	gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
1102	}
1103
1104	if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
1105	&& as->type != AS_ASSUMED_SIZE)
1106	{
1107	GFC_TYPE_ARRAY_SIZE (type) = create_index_var (pfx: "size", nest);
1108	suppress_warning (GFC_TYPE_ARRAY_SIZE (type));
1109	}
1110
1111	if (POINTER_TYPE_P (type))
1112	{
1113	gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
1114	gcc_assert (TYPE_LANG_SPECIFIC (type)
1115	== TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
1116	type = TREE_TYPE (type);
1117	}
1118
1119	if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
1120	{
1121	tree size, range;
1122
1123	size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
1124	GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
1125	range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1126	size);
1127	TYPE_DOMAIN (type) = range;
1128	layout_type (type);
1129	}
1130
1131	if (TYPE_NAME (type) != NULL_TREE && as->rank > 0
1132	&& GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1) != NULL_TREE
1133	&& VAR_P (GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1)))
1134	{
1135	tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
1136
1137	for (dim = 0; dim < as->rank - 1; dim++)
1138	{
1139	gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
1140	gtype = TREE_TYPE (gtype);
1141	}
1142	gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
1143	if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
1144	TYPE_NAME (type) = NULL_TREE;
1145	}
1146
1147	if (TYPE_NAME (type) == NULL_TREE)
1148	{
1149	tree gtype = TREE_TYPE (type), rtype, type_decl;
1150
1151	for (dim = as->rank - 1; dim >= 0; dim--)
1152	{
1153	tree lbound, ubound;
1154	lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
1155	ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
1156	rtype = build_range_type (gfc_array_index_type, lbound, ubound);
1157	gtype = build_array_type (gtype, rtype);
1158	/* Ensure the bound variables aren't optimized out at -O0.
1159	For -O1 and above they often will be optimized out, but
1160	can be tracked by VTA. Also set DECL_NAMELESS, so that
1161	the artificial lbound.N or ubound.N DECL_NAME doesn't
1162	end up in debug info. */
1163	if (lbound
1164	&& VAR_P (lbound)
1165	&& DECL_ARTIFICIAL (lbound)
1166	&& DECL_IGNORED_P (lbound))
1167	{
1168	if (DECL_NAME (lbound)
1169	&& strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
1170	needle: "lbound") != 0)
1171	DECL_NAMELESS (lbound) = 1;
1172	DECL_IGNORED_P (lbound) = 0;
1173	}
1174	if (ubound
1175	&& VAR_P (ubound)
1176	&& DECL_ARTIFICIAL (ubound)
1177	&& DECL_IGNORED_P (ubound))
1178	{
1179	if (DECL_NAME (ubound)
1180	&& strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
1181	needle: "ubound") != 0)
1182	DECL_NAMELESS (ubound) = 1;
1183	DECL_IGNORED_P (ubound) = 0;
1184	}
1185	}
1186	TYPE_NAME (type) = type_decl = build_decl (input_location,
1187	TYPE_DECL, NULL, gtype);
1188	DECL_ORIGINAL_TYPE (type_decl) = gtype;
1189	}
1190	}
1191
1192
1193	/* For some dummy arguments we don't use the actual argument directly.
1194	Instead we create a local decl and use that. This allows us to perform
1195	initialization, and construct full type information. */
1196
1197	static tree
1198	gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
1199	{
1200	tree decl;
1201	tree type;
1202	gfc_array_spec *as;
1203	symbol_attribute *array_attr;
1204	char *name;
1205	gfc_packed packed;
1206	int n;
1207	bool known_size;
1208	bool is_classarray = IS_CLASS_ARRAY (sym);
1209
1210	/* Use the array as and attr. */
1211	as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
1212	array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
1213
1214	/* The dummy is returned for pointer, allocatable or assumed rank arrays.
1215	For class arrays the information if sym is an allocatable or pointer
1216	object needs to be checked explicitly (IS_CLASS_ARRAY can be false for
1217	too many reasons to be of use here). */
1218	if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
1219	|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
1220	|| array_attr->allocatable
1221	|| (as && as->type == AS_ASSUMED_RANK))
1222	return dummy;
1223
1224	/* Add to list of variables if not a fake result variable.
1225	These symbols are set on the symbol only, not on the class component. */
1226	if (sym->attr.result || sym->attr.dummy)
1227	gfc_defer_symbol_init (sym);
1228
1229	/* For a class array the array descriptor is in the _data component, while
1230	for a regular array the TREE_TYPE of the dummy is a pointer to the
1231	descriptor. */
1232	type = TREE_TYPE (is_classarray ? gfc_class_data_get (dummy)
1233	: TREE_TYPE (dummy));
1234	/* type now is the array descriptor w/o any indirection. */
1235	gcc_assert (TREE_CODE (dummy) == PARM_DECL
1236	&& POINTER_TYPE_P (TREE_TYPE (dummy)));
1237
1238	/* Do we know the element size? */
1239	known_size = sym->ts.type != BT_CHARACTER
1240	|| INTEGER_CST_P (sym->ts.u.cl->backend_decl);
1241
1242	if (known_size && !GFC_DESCRIPTOR_TYPE_P (type))
1243	{
1244	/* For descriptorless arrays with known element size the actual
1245	argument is sufficient. */
1246	gfc_build_qualified_array (decl: dummy, sym);
1247	return dummy;
1248	}
1249
1250	if (GFC_DESCRIPTOR_TYPE_P (type))
1251	{
1252	/* Create a descriptorless array pointer. */
1253	packed = PACKED_NO;
1254
1255	/* Even when -frepack-arrays is used, symbols with TARGET attribute
1256	are not repacked. */
1257	if (!flag_repack_arrays || sym->attr.target)
1258	{
1259	if (as->type == AS_ASSUMED_SIZE)
1260	packed = PACKED_FULL;
1261	}
1262	else
1263	{
1264	if (as->type == AS_EXPLICIT)
1265	{
1266	packed = PACKED_FULL;
1267	for (n = 0; n < as->rank; n++)
1268	{
1269	if (!(as->upper[n]
1270	&& as->lower[n]
1271	&& as->upper[n]->expr_type == EXPR_CONSTANT
1272	&& as->lower[n]->expr_type == EXPR_CONSTANT))
1273	{
1274	packed = PACKED_PARTIAL;
1275	break;
1276	}
1277	}
1278	}
1279	else
1280	packed = PACKED_PARTIAL;
1281	}
1282
1283	/* For classarrays the element type is required, but
1284	gfc_typenode_for_spec () returns the array descriptor. */
1285	type = is_classarray ? gfc_get_element_type (type)
1286	: gfc_typenode_for_spec (&sym->ts);
1287	type = gfc_get_nodesc_array_type (type, as, packed,
1288	!sym->attr.target);
1289	}
1290	else
1291	{
1292	/* We now have an expression for the element size, so create a fully
1293	qualified type. Reset sym->backend decl or this will just return the
1294	old type. */
1295	DECL_ARTIFICIAL (sym->backend_decl) = 1;
1296	sym->backend_decl = NULL_TREE;
1297	type = gfc_sym_type (sym);
1298	packed = PACKED_FULL;
1299	}
1300
1301	ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
1302	decl = build_decl (input_location,
1303	VAR_DECL, get_identifier (name), type);
1304
1305	DECL_ARTIFICIAL (decl) = 1;
1306	DECL_NAMELESS (decl) = 1;
1307	TREE_PUBLIC (decl) = 0;
1308	TREE_STATIC (decl) = 0;
1309	DECL_EXTERNAL (decl) = 0;
1310
1311	/* Avoid uninitialized warnings for optional dummy arguments. */
1312	if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
1313	|| sym->attr.optional)
1314	suppress_warning (decl);
1315
1316	/* We should never get deferred shape arrays here. We used to because of
1317	frontend bugs. */
1318	gcc_assert (as->type != AS_DEFERRED);
1319
1320	if (packed == PACKED_PARTIAL)
1321	GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
1322	else if (packed == PACKED_FULL)
1323	GFC_DECL_PACKED_ARRAY (decl) = 1;
1324
1325	gfc_build_qualified_array (decl, sym);
1326
1327	if (DECL_LANG_SPECIFIC (dummy))
1328	DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
1329	else
1330	gfc_allocate_lang_decl (decl);
1331
1332	GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
1333
1334	if (sym->ns->proc_name->backend_decl == current_function_decl
1335	|| sym->attr.contained)
1336	gfc_add_decl_to_function (decl);
1337	else
1338	gfc_add_decl_to_parent_function (decl);
1339
1340	return decl;
1341	}
1342
1343	/* Return a constant or a variable to use as a string length. Does not
1344	add the decl to the current scope. */
1345
1346	static tree
1347	gfc_create_string_length (gfc_symbol * sym)
1348	{
1349	gcc_assert (sym->ts.u.cl);
1350	gfc_conv_const_charlen (sym->ts.u.cl);
1351
1352	if (sym->ts.u.cl->backend_decl == NULL_TREE)
1353	{
1354	tree length;
1355	const char *name;
1356
1357	/* The string length variable shall be in static memory if it is either
1358	explicitly SAVED, a module variable or with -fno-automatic. Only
1359	relevant is "len=:" - otherwise, it is either a constant length or
1360	it is an automatic variable. */
1361	bool static_length = sym->attr.save
1362	|| sym->ns->proc_name->attr.flavor == FL_MODULE
1363	|| (flag_max_stack_var_size == 0
1364	&& sym->ts.deferred && !sym->attr.dummy
1365	&& !sym->attr.result && !sym->attr.function);
1366
1367	/* Also prefix the mangled name. We need to call GFC_PREFIX for static
1368	variables as some systems do not support the "." in the assembler name.
1369	For nonstatic variables, the "." does not appear in assembler. */
1370	if (static_length)
1371	{
1372	if (sym->module)
1373	name = gfc_get_string (GFC_PREFIX ("%s_MOD_%s"), sym->module,
1374	sym->name);
1375	else
1376	name = gfc_get_string (GFC_PREFIX ("%s"), sym->name);
1377	}
1378	else if (sym->module)
1379	name = gfc_get_string (".__%s_MOD_%s", sym->module, sym->name);
1380	else
1381	name = gfc_get_string (".%s", sym->name);
1382
1383	length = build_decl (input_location,
1384	VAR_DECL, get_identifier (name),
1385	gfc_charlen_type_node);
1386	DECL_ARTIFICIAL (length) = 1;
1387	TREE_USED (length) = 1;
1388	if (sym->ns->proc_name->tlink != NULL)
1389	gfc_defer_symbol_init (sym);
1390
1391	sym->ts.u.cl->backend_decl = length;
1392
1393	if (static_length)
1394	TREE_STATIC (length) = 1;
1395
1396	if (sym->ns->proc_name->attr.flavor == FL_MODULE
1397	&& (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used))
1398	TREE_PUBLIC (length) = 1;
1399	}
1400
1401	gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
1402	return sym->ts.u.cl->backend_decl;
1403	}
1404
1405	/* If a variable is assigned a label, we add another two auxiliary
1406	variables. */
1407
1408	static void
1409	gfc_add_assign_aux_vars (gfc_symbol * sym)
1410	{
1411	tree addr;
1412	tree length;
1413	tree decl;
1414
1415	gcc_assert (sym->backend_decl);
1416
1417	decl = sym->backend_decl;
1418	gfc_allocate_lang_decl (decl);
1419	GFC_DECL_ASSIGN (decl) = 1;
1420	length = build_decl (input_location,
1421	VAR_DECL, create_tmp_var_name (sym->name),
1422	gfc_charlen_type_node);
1423	addr = build_decl (input_location,
1424	VAR_DECL, create_tmp_var_name (sym->name),
1425	pvoid_type_node);
1426	gfc_finish_var_decl (decl: length, sym);
1427	gfc_finish_var_decl (decl: addr, sym);
1428	/* STRING_LENGTH is also used as flag. Less than -1 means that
1429	ASSIGN_ADDR cannot be used. Equal -1 means that ASSIGN_ADDR is the
1430	target label's address. Otherwise, value is the length of a format string
1431	and ASSIGN_ADDR is its address. */
1432	if (TREE_STATIC (length))
1433	DECL_INITIAL (length) = build_int_cst (gfc_charlen_type_node, -2);
1434	else
1435	gfc_defer_symbol_init (sym);
1436
1437	GFC_DECL_STRING_LEN (decl) = length;
1438	GFC_DECL_ASSIGN_ADDR (decl) = addr;
1439	}
1440
1441
1442	static tree
1443	add_attributes_to_decl (symbol_attribute sym_attr, tree list)
1444	{
1445	unsigned id;
1446	tree attr;
1447
1448	for (id = 0; id < EXT_ATTR_NUM; id++)
1449	if (sym_attr.ext_attr & (1 << id) && ext_attr_list[id].middle_end_name)
1450	{
1451	attr = build_tree_list (
1452	get_identifier (ext_attr_list[id].middle_end_name),
1453	NULL_TREE);
1454	list = chainon (list, attr);
1455	}
1456
1457	tree clauses = NULL_TREE;
1458
1459	if (sym_attr.oacc_routine_lop != OACC_ROUTINE_LOP_NONE)
1460	{
1461	omp_clause_code code;
1462	switch (sym_attr.oacc_routine_lop)
1463	{
1464	case OACC_ROUTINE_LOP_GANG:
1465	code = OMP_CLAUSE_GANG;
1466	break;
1467	case OACC_ROUTINE_LOP_WORKER:
1468	code = OMP_CLAUSE_WORKER;
1469	break;
1470	case OACC_ROUTINE_LOP_VECTOR:
1471	code = OMP_CLAUSE_VECTOR;
1472	break;
1473	case OACC_ROUTINE_LOP_SEQ:
1474	code = OMP_CLAUSE_SEQ;
1475	break;
1476	case OACC_ROUTINE_LOP_NONE:
1477	case OACC_ROUTINE_LOP_ERROR:
1478	default:
1479	gcc_unreachable ();
1480	}
1481	tree c = build_omp_clause (UNKNOWN_LOCATION, code);
1482	OMP_CLAUSE_CHAIN (c) = clauses;
1483	clauses = c;
1484
1485	tree dims = oacc_build_routine_dims (clauses);
1486	list = oacc_replace_fn_attrib_attr (attribs: list, dims);
1487	}
1488
1489	if (sym_attr.oacc_routine_nohost)
1490	{
1491	tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_NOHOST);
1492	OMP_CLAUSE_CHAIN (c) = clauses;
1493	clauses = c;
1494	}
1495
1496	if (sym_attr.omp_device_type != OMP_DEVICE_TYPE_UNSET)
1497	{
1498	tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE);
1499	switch (sym_attr.omp_device_type)
1500	{
1501	case OMP_DEVICE_TYPE_HOST:
1502	OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_HOST;
1503	break;
1504	case OMP_DEVICE_TYPE_NOHOST:
1505	OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_NOHOST;
1506	break;
1507	case OMP_DEVICE_TYPE_ANY:
1508	OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_ANY;
1509	break;
1510	default:
1511	gcc_unreachable ();
1512	}
1513	OMP_CLAUSE_CHAIN (c) = clauses;
1514	clauses = c;
1515	}
1516
1517	if (sym_attr.omp_declare_target_link
1518	|| sym_attr.oacc_declare_link)
1519	list = tree_cons (get_identifier ("omp declare target link"),
1520	clauses, list);
1521	else if (sym_attr.omp_declare_target
1522	|| sym_attr.oacc_declare_create
1523	|| sym_attr.oacc_declare_copyin
1524	|| sym_attr.oacc_declare_deviceptr
1525	|| sym_attr.oacc_declare_device_resident)
1526	list = tree_cons (get_identifier ("omp declare target"),
1527	clauses, list);
1528
1529	if (sym_attr.omp_declare_target_indirect)
1530	list = tree_cons (get_identifier ("omp declare target indirect"),
1531	clauses, list);
1532
1533	return list;
1534	}
1535
1536
1537	static void build_function_decl (gfc_symbol * sym, bool global);
1538
1539
1540	/* Return the decl for a gfc_symbol, create it if it doesn't already
1541	exist. */
1542
1543	tree
1544	gfc_get_symbol_decl (gfc_symbol * sym)
1545	{
1546	tree decl;
1547	tree length = NULL_TREE;
1548	tree attributes;
1549	int byref;
1550	bool intrinsic_array_parameter = false;
1551	bool fun_or_res;
1552
1553	gcc_assert (sym->attr.referenced
1554	|| sym->attr.flavor == FL_PROCEDURE
1555	|| sym->attr.use_assoc
1556	|| sym->attr.used_in_submodule
1557	|| sym->ns->proc_name->attr.if_source == IFSRC_IFBODY
1558	|| (sym->module && sym->attr.if_source != IFSRC_DECL
1559	&& sym->backend_decl));
1560
1561	if (sym->attr.dummy && sym->ns->proc_name->attr.is_bind_c
1562	&& is_CFI_desc (sym, NULL))
1563	{
1564	gcc_assert (sym->backend_decl && (sym->ts.type != BT_CHARACTER
1565	|| sym->ts.u.cl->backend_decl));
1566	return sym->backend_decl;
1567	}
1568
1569	if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
1570	byref = gfc_return_by_reference (sym->ns->proc_name);
1571	else
1572	byref = 0;
1573
1574	/* Make sure that the vtab for the declared type is completed. */
1575	if (sym->ts.type == BT_CLASS)
1576	{
1577	gfc_component *c = CLASS_DATA (sym);
1578	if (!c->ts.u.derived->backend_decl)
1579	{
1580	gfc_find_derived_vtab (c->ts.u.derived);
1581	gfc_get_derived_type (derived: sym->ts.u.derived);
1582	}
1583	}
1584
1585	/* PDT parameterized array components and string_lengths must have the
1586	'len' parameters substituted for the expressions appearing in the
1587	declaration of the entity and memory allocated/deallocated. */
1588	if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1589	&& sym->param_list != NULL
1590	&& gfc_current_ns == sym->ns
1591	&& !(sym->attr.use_assoc || sym->attr.dummy))
1592	gfc_defer_symbol_init (sym);
1593
1594	/* Dummy PDT 'len' parameters should be checked when they are explicit. */
1595	if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1596	&& (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1597	&& sym->param_list != NULL
1598	&& sym->attr.dummy)
1599	gfc_defer_symbol_init (sym);
1600
1601	/* All deferred character length procedures need to retain the backend
1602	decl, which is a pointer to the character length in the caller's
1603	namespace and to declare a local character length. */
1604	if (!byref && sym->attr.function
1605	&& sym->ts.type == BT_CHARACTER
1606	&& sym->ts.deferred
1607	&& sym->ts.u.cl->passed_length == NULL
1608	&& sym->ts.u.cl->backend_decl
1609	&& TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
1610	{
1611	sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1612	gcc_assert (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length)));
1613	sym->ts.u.cl->backend_decl = build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
1614	}
1615
1616	fun_or_res = byref && (sym->attr.result
1617	|| (sym->attr.function && sym->ts.deferred));
1618	if ((sym->attr.dummy && ! sym->attr.function) || fun_or_res)
1619	{
1620	/* Return via extra parameter. */
1621	if (sym->attr.result && byref
1622	&& !sym->backend_decl)
1623	{
1624	sym->backend_decl =
1625	DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1626	/* For entry master function skip over the __entry
1627	argument. */
1628	if (sym->ns->proc_name->attr.entry_master)
1629	sym->backend_decl = DECL_CHAIN (sym->backend_decl);
1630	}
1631
1632	/* Dummy variables should already have been created. */
1633	gcc_assert (sym->backend_decl);
1634
1635	/* However, the string length of deferred arrays must be set. */
1636	if (sym->ts.type == BT_CHARACTER
1637	&& sym->ts.deferred
1638	&& sym->attr.dimension
1639	&& sym->attr.allocatable)
1640	gfc_defer_symbol_init (sym);
1641
1642	if (sym->attr.pointer && sym->attr.dimension && sym->ts.type != BT_CLASS)
1643	GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1;
1644
1645	/* Create a character length variable. */
1646	if (sym->ts.type == BT_CHARACTER)
1647	{
1648	/* For a deferred dummy, make a new string length variable. */
1649	if (sym->ts.deferred
1650	&&
1651	(sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl))
1652	sym->ts.u.cl->backend_decl = NULL_TREE;
1653
1654	if (sym->ts.deferred && byref)
1655	{
1656	/* The string length of a deferred char array is stored in the
1657	parameter at sym->ts.u.cl->backend_decl as a reference and
1658	marked as a result. Exempt this variable from generating a
1659	temporary for it. */
1660	if (sym->attr.result)
1661	{
1662	/* We need to insert a indirect ref for param decls. */
1663	if (sym->ts.u.cl->backend_decl
1664	&& TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
1665	{
1666	sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1667	sym->ts.u.cl->backend_decl =
1668	build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
1669	}
1670	}
1671	/* For all other parameters make sure, that they are copied so
1672	that the value and any modifications are local to the routine
1673	by generating a temporary variable. */
1674	else if (sym->attr.function
1675	&& sym->ts.u.cl->passed_length == NULL
1676	&& sym->ts.u.cl->backend_decl)
1677	{
1678	sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1679	if (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length)))
1680	sym->ts.u.cl->backend_decl
1681	= build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
1682	else
1683	sym->ts.u.cl->backend_decl = NULL_TREE;
1684	}
1685	}
1686
1687	if (sym->ts.u.cl->backend_decl == NULL_TREE)
1688	length = gfc_create_string_length (sym);
1689	else
1690	length = sym->ts.u.cl->backend_decl;
1691	if (VAR_P (length) && DECL_FILE_SCOPE_P (length))
1692	{
1693	/* Add the string length to the same context as the symbol. */
1694	if (DECL_CONTEXT (length) == NULL_TREE)
1695	{
1696	if (sym->backend_decl == current_function_decl
1697	|| (DECL_CONTEXT (sym->backend_decl)
1698	== current_function_decl))
1699	gfc_add_decl_to_function (decl: length);
1700	else
1701	gfc_add_decl_to_parent_function (decl: length);
1702	}
1703
1704	gcc_assert (sym->backend_decl == current_function_decl
1705	? DECL_CONTEXT (length) == current_function_decl
1706	: (DECL_CONTEXT (sym->backend_decl)
1707	== DECL_CONTEXT (length)));
1708
1709	gfc_defer_symbol_init (sym);
1710	}
1711	}
1712
1713	/* Use a copy of the descriptor for dummy arrays. */
1714	if ((sym->attr.dimension || sym->attr.codimension)
1715	&& !TREE_USED (sym->backend_decl))
1716	{
1717	decl = gfc_build_dummy_array_decl (sym, dummy: sym->backend_decl);
1718	/* Prevent the dummy from being detected as unused if it is copied. */
1719	if (sym->backend_decl != NULL && decl != sym->backend_decl)
1720	DECL_ARTIFICIAL (sym->backend_decl) = 1;
1721	sym->backend_decl = decl;
1722	}
1723
1724	/* Returning the descriptor for dummy class arrays is hazardous, because
1725	some caller is expecting an expression to apply the component refs to.
1726	Therefore the descriptor is only created and stored in
1727	sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR. The caller is then
1728	responsible to extract it from there, when the descriptor is
1729	desired. */
1730	if (IS_CLASS_ARRAY (sym)
1731	&& (!DECL_LANG_SPECIFIC (sym->backend_decl)
1732	|| !GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)))
1733	{
1734	decl = gfc_build_dummy_array_decl (sym, dummy: sym->backend_decl);
1735	/* Prevent the dummy from being detected as unused if it is copied. */
1736	if (sym->backend_decl != NULL && decl != sym->backend_decl)
1737	DECL_ARTIFICIAL (sym->backend_decl) = 1;
1738	sym->backend_decl = decl;
1739	}
1740
1741	TREE_USED (sym->backend_decl) = 1;
1742	if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1743	gfc_add_assign_aux_vars (sym);
1744
1745	if (sym->ts.type == BT_CLASS && sym->backend_decl)
1746	GFC_DECL_CLASS(sym->backend_decl) = 1;
1747
1748	return sym->backend_decl;
1749	}
1750
1751	if (sym->result == sym && sym->attr.assign
1752	&& GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1753	gfc_add_assign_aux_vars (sym);
1754
1755	if (sym->backend_decl)
1756	return sym->backend_decl;
1757
1758	/* Special case for array-valued named constants from intrinsic
1759	procedures; those are inlined. */
1760	if (sym->attr.use_assoc && sym->attr.flavor == FL_PARAMETER
1761	&& (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
1762	|| sym->from_intmod == INTMOD_ISO_C_BINDING))
1763	intrinsic_array_parameter = true;
1764
1765	/* If use associated compilation, use the module
1766	declaration. */
1767	if ((sym->attr.flavor == FL_VARIABLE
1768	|| sym->attr.flavor == FL_PARAMETER)
1769	&& (sym->attr.use_assoc || sym->attr.used_in_submodule)
1770	&& !intrinsic_array_parameter
1771	&& sym->module
1772	&& gfc_get_module_backend_decl (sym))
1773	{
1774	if (sym->ts.type == BT_CLASS && sym->backend_decl)
1775	GFC_DECL_CLASS(sym->backend_decl) = 1;
1776	return sym->backend_decl;
1777	}
1778
1779	if (sym->attr.flavor == FL_PROCEDURE)
1780	{
1781	/* Catch functions. Only used for actual parameters,
1782	procedure pointers and procptr initialization targets. */
1783	if (sym->attr.use_assoc
1784	|| sym->attr.used_in_submodule
1785	|| sym->attr.intrinsic
1786	|| sym->attr.if_source != IFSRC_DECL)
1787	{
1788	decl = gfc_get_extern_function_decl (sym);
1789	}
1790	else
1791	{
1792	if (!sym->backend_decl)
1793	build_function_decl (sym, global: false);
1794	decl = sym->backend_decl;
1795	}
1796	return decl;
1797	}
1798
1799	if (sym->ts.type == BT_UNKNOWN)
1800	gfc_fatal_error ("%s at %L has no default type", sym->name,
1801	&sym->declared_at);
1802
1803	if (sym->attr.intrinsic)
1804	gfc_internal_error ("intrinsic variable which isn't a procedure");
1805
1806	/* Create string length decl first so that they can be used in the
1807	type declaration. For associate names, the target character
1808	length is used. Set 'length' to a constant so that if the
1809	string length is a variable, it is not finished a second time. */
1810	if (sym->ts.type == BT_CHARACTER)
1811	{
1812	if (sym->attr.associate_var
1813	&& sym->ts.deferred
1814	&& sym->assoc && sym->assoc->target
1815	&& ((sym->assoc->target->expr_type == EXPR_VARIABLE
1816	&& sym->assoc->target->symtree->n.sym->ts.type != BT_CHARACTER)
1817	|| sym->assoc->target->expr_type != EXPR_VARIABLE))
1818	sym->ts.u.cl->backend_decl = NULL_TREE;
1819
1820	if (sym->attr.associate_var
1821	&& sym->ts.u.cl->backend_decl
1822	&& (VAR_P (sym->ts.u.cl->backend_decl)
1823	|| TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL))
1824	length = gfc_index_zero_node;
1825	else
1826	length = gfc_create_string_length (sym);
1827	}
1828
1829	/* Create the decl for the variable. */
1830	decl = build_decl (gfc_get_location (&sym->declared_at),
1831	VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1832
1833	/* Add attributes to variables. Functions are handled elsewhere. */
1834	attributes = add_attributes_to_decl (sym_attr: sym->attr, NULL_TREE);
1835	decl_attributes (&decl, attributes, 0);
1836	if (sym->ts.deferred && VAR_P (length))
1837	decl_attributes (&length, attributes, 0);
1838
1839	/* Symbols from modules should have their assembler names mangled.
1840	This is done here rather than in gfc_finish_var_decl because it
1841	is different for string length variables. */
1842	if (sym->module || sym->fn_result_spec)
1843	{
1844	gfc_set_decl_assembler_name (decl, name: gfc_sym_mangled_identifier (sym));
1845	if (sym->attr.use_assoc && !intrinsic_array_parameter)
1846	DECL_IGNORED_P (decl) = 1;
1847	}
1848
1849	if (sym->attr.select_type_temporary)
1850	{
1851	DECL_ARTIFICIAL (decl) = 1;
1852	DECL_IGNORED_P (decl) = 1;
1853	}
1854
1855	if (sym->attr.dimension || sym->attr.codimension)
1856	{
1857	/* Create variables to hold the non-constant bits of array info. */
1858	gfc_build_qualified_array (decl, sym);
1859
1860	if (sym->attr.contiguous
1861	|| ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer))
1862	GFC_DECL_PACKED_ARRAY (decl) = 1;
1863	}
1864
1865	/* Remember this variable for allocation/cleanup. */
1866	if (sym->attr.dimension || sym->attr.allocatable || sym->attr.codimension
1867	|| (sym->ts.type == BT_CLASS &&
1868	(CLASS_DATA (sym)->attr.dimension
1869	|| CLASS_DATA (sym)->attr.allocatable))
1870	|| (sym->ts.type == BT_DERIVED
1871	&& (sym->ts.u.derived->attr.alloc_comp
1872	|| (!sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
1873	&& !sym->ns->proc_name->attr.is_main_program
1874	&& gfc_is_finalizable (sym->ts.u.derived, NULL))))
1875	/* This applies a derived type default initializer. */
1876	|| (sym->ts.type == BT_DERIVED
1877	&& sym->attr.save == SAVE_NONE
1878	&& !sym->attr.data
1879	&& !sym->attr.allocatable
1880	&& (sym->value && !sym->ns->proc_name->attr.is_main_program)
1881	&& !(sym->attr.use_assoc && !intrinsic_array_parameter)))
1882	gfc_defer_symbol_init (sym);
1883
1884	/* Set the vptr of unlimited polymorphic pointer variables so that
1885	they do not cause segfaults in select type, when the selector
1886	is an intrinsic type. Arrays are captured above. */
1887	if (sym->ts.type == BT_CLASS && UNLIMITED_POLY (sym)
1888	&& CLASS_DATA (sym)->attr.class_pointer
1889	&& !CLASS_DATA (sym)->attr.dimension && !sym->attr.dummy
1890	&& sym->attr.flavor == FL_VARIABLE && !sym->assoc)
1891	gfc_defer_symbol_init (sym);
1892
1893	if (sym->ts.type == BT_CHARACTER
1894	&& sym->attr.allocatable
1895	&& !sym->attr.dimension
1896	&& sym->ts.u.cl && sym->ts.u.cl->length
1897	&& sym->ts.u.cl->length->expr_type == EXPR_VARIABLE)
1898	gfc_defer_symbol_init (sym);
1899
1900	/* Associate names can use the hidden string length variable
1901	of their associated target. */
1902	if (sym->ts.type == BT_CHARACTER
1903	&& TREE_CODE (length) != INTEGER_CST
1904	&& TREE_CODE (sym->ts.u.cl->backend_decl) != INDIRECT_REF)
1905	{
1906	length = fold_convert (gfc_charlen_type_node, length);
1907	gfc_finish_var_decl (decl: length, sym);
1908	if (!sym->attr.associate_var
1909	&& VAR_P (length)
1910	&& sym->value && sym->value->expr_type != EXPR_NULL
1911	&& sym->value->ts.u.cl->length)
1912	{
1913	gfc_expr *len = sym->value->ts.u.cl->length;
1914	DECL_INITIAL (length) = gfc_conv_initializer (len, &len->ts,
1915	TREE_TYPE (length),
1916	false, false, false);
1917	DECL_INITIAL (length) = fold_convert (gfc_charlen_type_node,
1918	DECL_INITIAL (length));
1919	}
1920	else
1921	gcc_assert (!sym->value || sym->value->expr_type == EXPR_NULL);
1922	}
1923
1924	gfc_finish_var_decl (decl, sym);
1925
1926	if (sym->ts.type == BT_CHARACTER)
1927	/* Character variables need special handling. */
1928	gfc_allocate_lang_decl (decl);
1929
1930	if (sym->assoc && sym->attr.subref_array_pointer)
1931	sym->attr.pointer = 1;
1932
1933	if (sym->attr.pointer && sym->attr.dimension
1934	&& !sym->ts.deferred
1935	&& !(sym->attr.select_type_temporary
1936	&& !sym->attr.subref_array_pointer))
1937	GFC_DECL_PTR_ARRAY_P (decl) = 1;
1938
1939	if (sym->ts.type == BT_CLASS)
1940	GFC_DECL_CLASS(decl) = 1;
1941
1942	sym->backend_decl = decl;
1943
1944	if (sym->attr.assign)
1945	gfc_add_assign_aux_vars (sym);
1946
1947	if (intrinsic_array_parameter)
1948	{
1949	TREE_STATIC (decl) = 1;
1950	DECL_EXTERNAL (decl) = 0;
1951	}
1952
1953	if (TREE_STATIC (decl)
1954	&& !(sym->attr.use_assoc && !intrinsic_array_parameter)
1955	&& (sym->attr.save || sym->ns->proc_name->attr.is_main_program
1956	|| !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
1957	|| sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE)
1958	&& (flag_coarray != GFC_FCOARRAY_LIB
1959	|| !sym->attr.codimension || sym->attr.allocatable)
1960	&& !(sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type)
1961	&& !(sym->ts.type == BT_CLASS
1962	&& CLASS_DATA (sym)->ts.u.derived->attr.pdt_type))
1963	{
1964	/* Add static initializer. For procedures, it is only needed if
1965	SAVE is specified otherwise they need to be reinitialized
1966	every time the procedure is entered. The TREE_STATIC is
1967	in this case due to -fmax-stack-var-size=. */
1968
1969	DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1970	TREE_TYPE (decl), sym->attr.dimension
1971	|| (sym->attr.codimension
1972	&& sym->attr.allocatable),
1973	sym->attr.pointer || sym->attr.allocatable
1974	|| sym->ts.type == BT_CLASS,
1975	sym->attr.proc_pointer);
1976	}
1977
1978	if (!TREE_STATIC (decl)
1979	&& POINTER_TYPE_P (TREE_TYPE (decl))
1980	&& !sym->attr.pointer
1981	&& !sym->attr.allocatable
1982	&& !sym->attr.proc_pointer
1983	&& !sym->attr.select_type_temporary)
1984	DECL_BY_REFERENCE (decl) = 1;
1985
1986	if (sym->attr.associate_var)
1987	GFC_DECL_ASSOCIATE_VAR_P (decl) = 1;
1988
1989	/* We only longer mark __def_init as read-only if it actually has an
1990	initializer, it does not needlessly take up space in the
1991	read-only section and can go into the BSS instead, see PR 84487.
1992	Marking this as artificial means that OpenMP will treat this as
1993	predetermined shared. */
1994
1995	bool def_init = startswith (str: sym->name, prefix: "__def_init");
1996
1997	if (sym->attr.vtab || def_init)
1998	{
1999	DECL_ARTIFICIAL (decl) = 1;
2000	if (def_init && sym->value)
2001	TREE_READONLY (decl) = 1;
2002	}
2003
2004	return decl;
2005	}
2006
2007
2008	/* Substitute a temporary variable in place of the real one. */
2009
2010	void
2011	gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
2012	{
2013	save->attr = sym->attr;
2014	save->decl = sym->backend_decl;
2015
2016	gfc_clear_attr (&sym->attr);
2017	sym->attr.referenced = 1;
2018	sym->attr.flavor = FL_VARIABLE;
2019
2020	sym->backend_decl = decl;
2021	}
2022
2023
2024	/* Restore the original variable. */
2025
2026	void
2027	gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
2028	{
2029	sym->attr = save->attr;
2030	sym->backend_decl = save->decl;
2031	}
2032
2033
2034	/* Declare a procedure pointer. */
2035
2036	static tree
2037	get_proc_pointer_decl (gfc_symbol *sym)
2038	{
2039	tree decl;
2040	tree attributes;
2041
2042	if (sym->module || sym->fn_result_spec)
2043	{
2044	const char *name;
2045	gfc_gsymbol *gsym;
2046
2047	name = mangled_identifier (sym);
2048	gsym = gfc_find_gsymbol (gfc_gsym_root, name);
2049	if (gsym != NULL)
2050	{
2051	gfc_symbol *s;
2052	gfc_find_symbol (sym->name, gsym->ns, 0, &s);
2053	if (s && s->backend_decl)
2054	return s->backend_decl;
2055	}
2056	}
2057
2058	decl = sym->backend_decl;
2059	if (decl)
2060	return decl;
2061
2062	decl = build_decl (input_location,
2063	VAR_DECL, get_identifier (sym->name),
2064	build_pointer_type (gfc_get_function_type (sym)));
2065
2066	if (sym->module)
2067	{
2068	/* Apply name mangling. */
2069	gfc_set_decl_assembler_name (decl, name: gfc_sym_mangled_identifier (sym));
2070	if (sym->attr.use_assoc)
2071	DECL_IGNORED_P (decl) = 1;
2072	}
2073
2074	if ((sym->ns->proc_name
2075	&& sym->ns->proc_name->backend_decl == current_function_decl)
2076	|| sym->attr.contained)
2077	gfc_add_decl_to_function (decl);
2078	else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
2079	gfc_add_decl_to_parent_function (decl);
2080
2081	sym->backend_decl = decl;
2082
2083	/* If a variable is USE associated, it's always external. */
2084	if (sym->attr.use_assoc)
2085	{
2086	DECL_EXTERNAL (decl) = 1;
2087	TREE_PUBLIC (decl) = 1;
2088	}
2089	else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
2090	{
2091	/* This is the declaration of a module variable. */
2092	TREE_PUBLIC (decl) = 1;
2093	if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
2094	{
2095	DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
2096	DECL_VISIBILITY_SPECIFIED (decl) = true;
2097	}
2098	TREE_STATIC (decl) = 1;
2099	}
2100
2101	if (!sym->attr.use_assoc
2102	&& (sym->attr.save != SAVE_NONE || sym->attr.data
2103	|| (sym->value && sym->ns->proc_name->attr.is_main_program)))
2104	TREE_STATIC (decl) = 1;
2105
2106	if (TREE_STATIC (decl) && sym->value)
2107	{
2108	/* Add static initializer. */
2109	DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
2110	TREE_TYPE (decl),
2111	sym->attr.dimension,
2112	false, true);
2113	}
2114
2115	/* Handle threadprivate procedure pointers. */
2116	if (sym->attr.threadprivate
2117	&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
2118	set_decl_tls_model (decl, decl_default_tls_model (decl));
2119
2120	attributes = add_attributes_to_decl (sym_attr: sym->attr, NULL_TREE);
2121	decl_attributes (&decl, attributes, 0);
2122
2123	return decl;
2124	}
2125
2126
2127	/* Get a basic decl for an external function. */
2128
2129	tree
2130	gfc_get_extern_function_decl (gfc_symbol * sym, gfc_actual_arglist *actual_args,
2131	const char *fnspec)
2132	{
2133	tree type;
2134	tree fndecl;
2135	tree attributes;
2136	gfc_expr e;
2137	gfc_intrinsic_sym *isym;
2138	gfc_expr argexpr;
2139	char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
2140	tree name;
2141	tree mangled_name;
2142	gfc_gsymbol *gsym;
2143
2144	if (sym->backend_decl)
2145	return sym->backend_decl;
2146
2147	/* We should never be creating external decls for alternate entry points.
2148	The procedure may be an alternate entry point, but we don't want/need
2149	to know that. */
2150	gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
2151
2152	if (sym->attr.proc_pointer)
2153	return get_proc_pointer_decl (sym);
2154
2155	/* See if this is an external procedure from the same file. If so,
2156	return the backend_decl. If we are looking at a BIND(C)
2157	procedure and the symbol is not BIND(C), or vice versa, we
2158	haven't found the right procedure. */
2159
2160	if (sym->binding_label)
2161	{
2162	gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
2163	if (gsym && !gsym->bind_c)
2164	gsym = NULL;
2165	}
2166	else if (sym->module == NULL)
2167	{
2168	gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
2169	if (gsym && gsym->bind_c)
2170	gsym = NULL;
2171	}
2172	else
2173	{
2174	/* Procedure from a different module. */
2175	gsym = NULL;
2176	}
2177
2178	if (gsym && !gsym->defined)
2179	gsym = NULL;
2180
2181	/* This can happen because of C binding. */
2182	if (gsym && gsym->ns && gsym->ns->proc_name
2183	&& gsym->ns->proc_name->attr.flavor == FL_MODULE)
2184	goto module_sym;
2185
2186	if ((!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
2187	&& !sym->backend_decl
2188	&& gsym && gsym->ns
2189	&& ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
2190	&& (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
2191	{
2192	if (!gsym->ns->proc_name->backend_decl)
2193	{
2194	/* By construction, the external function cannot be
2195	a contained procedure. */
2196	locus old_loc;
2197
2198	gfc_save_backend_locus (&old_loc);
2199	push_cfun (NULL);
2200
2201	gfc_create_function_decl (gsym->ns, true);
2202
2203	pop_cfun ();
2204	gfc_restore_backend_locus (&old_loc);
2205	}
2206
2207	/* If the namespace has entries, the proc_name is the
2208	entry master. Find the entry and use its backend_decl.
2209	otherwise, use the proc_name backend_decl. */
2210	if (gsym->ns->entries)
2211	{
2212	gfc_entry_list *entry = gsym->ns->entries;
2213
2214	for (; entry; entry = entry->next)
2215	{
2216	if (strcmp (s1: gsym->name, s2: entry->sym->name) == 0)
2217	{
2218	sym->backend_decl = entry->sym->backend_decl;
2219	break;
2220	}
2221	}
2222	}
2223	else
2224	sym->backend_decl = gsym->ns->proc_name->backend_decl;
2225
2226	if (sym->backend_decl)
2227	{
2228	/* Avoid problems of double deallocation of the backend declaration
2229	later in gfc_trans_use_stmts; cf. PR 45087. */
2230	if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc)
2231	sym->attr.use_assoc = 0;
2232
2233	return sym->backend_decl;
2234	}
2235	}
2236
2237	/* See if this is a module procedure from the same file. If so,
2238	return the backend_decl. */
2239	if (sym->module)
2240	gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
2241
2242	module_sym:
2243	if (gsym && gsym->ns
2244	&& (gsym->type == GSYM_MODULE
2245	|| (gsym->ns->proc_name && gsym->ns->proc_name->attr.flavor == FL_MODULE)))
2246	{
2247	gfc_symbol *s;
2248
2249	s = NULL;
2250	if (gsym->type == GSYM_MODULE)
2251	gfc_find_symbol (sym->name, gsym->ns, 0, &s);
2252	else
2253	gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &s);
2254
2255	if (s && s->backend_decl)
2256	{
2257	if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
2258	gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
2259	true);
2260	else if (sym->ts.type == BT_CHARACTER)
2261	sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
2262	sym->backend_decl = s->backend_decl;
2263	return sym->backend_decl;
2264	}
2265	}
2266
2267	if (sym->attr.intrinsic)
2268	{
2269	/* Call the resolution function to get the actual name. This is
2270	a nasty hack which relies on the resolution functions only looking
2271	at the first argument. We pass NULL for the second argument
2272	otherwise things like AINT get confused. */
2273	isym = gfc_find_function (sym->name);
2274	gcc_assert (isym->resolve.f0 != NULL);
2275
2276	memset (s: &e, c: 0, n: sizeof (e));
2277	e.expr_type = EXPR_FUNCTION;
2278
2279	memset (s: &argexpr, c: 0, n: sizeof (argexpr));
2280	gcc_assert (isym->formal);
2281	argexpr.ts = isym->formal->ts;
2282
2283	if (isym->formal->next == NULL)
2284	isym->resolve.f1 (&e, &argexpr);
2285	else
2286	{
2287	if (isym->formal->next->next == NULL)
2288	isym->resolve.f2 (&e, &argexpr, NULL);
2289	else
2290	{
2291	if (isym->formal->next->next->next == NULL)
2292	isym->resolve.f3 (&e, &argexpr, NULL, NULL);
2293	else
2294	{
2295	/* All specific intrinsics take less than 5 arguments. */
2296	gcc_assert (isym->formal->next->next->next->next == NULL);
2297	isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
2298	}
2299	}
2300	}
2301
2302	if (flag_f2c
2303	&& ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
2304	|| e.ts.type == BT_COMPLEX))
2305	{
2306	/* Specific which needs a different implementation if f2c
2307	calling conventions are used. */
2308	sprintf (s: s, format: "_gfortran_f2c_specific%s", e.value.function.name);
2309	}
2310	else
2311	sprintf (s: s, format: "_gfortran_specific%s", e.value.function.name);
2312
2313	name = get_identifier (s);
2314	mangled_name = name;
2315	}
2316	else
2317	{
2318	name = gfc_sym_identifier (sym);
2319	mangled_name = gfc_sym_mangled_function_id (sym);
2320	}
2321
2322	type = gfc_get_function_type (sym, args: actual_args, fnspec);
2323
2324	fndecl = build_decl (input_location,
2325	FUNCTION_DECL, name, type);
2326
2327	/* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
2328	TREE_PUBLIC specifies whether a function is globally addressable (i.e.
2329	the opposite of declaring a function as static in C). */
2330	DECL_EXTERNAL (fndecl) = 1;
2331	TREE_PUBLIC (fndecl) = 1;
2332
2333	attributes = add_attributes_to_decl (sym_attr: sym->attr, NULL_TREE);
2334	decl_attributes (&fndecl, attributes, 0);
2335
2336	gfc_set_decl_assembler_name (decl: fndecl, name: mangled_name);
2337
2338	/* Set the context of this decl. */
2339	if (0 && sym->ns && sym->ns->proc_name)
2340	{
2341	/* TODO: Add external decls to the appropriate scope. */
2342	DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
2343	}
2344	else
2345	{
2346	/* Global declaration, e.g. intrinsic subroutine. */
2347	DECL_CONTEXT (fndecl) = NULL_TREE;
2348	}
2349
2350	/* Set attributes for PURE functions. A call to PURE function in the
2351	Fortran 95 sense is both pure and without side effects in the C
2352	sense. */
2353	if (sym->attr.pure || sym->attr.implicit_pure)
2354	{
2355	if (sym->attr.function && !gfc_return_by_reference (sym))
2356	DECL_PURE_P (fndecl) = 1;
2357	/* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
2358	parameters and don't use alternate returns (is this
2359	allowed?). In that case, calls to them are meaningless, and
2360	can be optimized away. See also in build_function_decl(). */
2361	TREE_SIDE_EFFECTS (fndecl) = 0;
2362	}
2363
2364	/* Mark non-returning functions. */
2365	if (sym->attr.noreturn || sym->attr.ext_attr & (1 << EXT_ATTR_NORETURN))
2366	TREE_THIS_VOLATILE(fndecl) = 1;
2367
2368	sym->backend_decl = fndecl;
2369
2370	if (DECL_CONTEXT (fndecl) == NULL_TREE)
2371	pushdecl_top_level (fndecl);
2372
2373	if (sym->formal_ns
2374	&& sym->formal_ns->proc_name == sym)
2375	{
2376	if (sym->formal_ns->omp_declare_simd)
2377	gfc_trans_omp_declare_simd (sym->formal_ns);
2378	if (flag_openmp)
2379	gfc_trans_omp_declare_variant (sym->formal_ns);
2380	}
2381
2382	return fndecl;
2383	}
2384
2385
2386	/* Create a declaration for a procedure. For external functions (in the C
2387	sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
2388	a master function with alternate entry points. */
2389
2390	static void
2391	build_function_decl (gfc_symbol * sym, bool global)
2392	{
2393	tree fndecl, type, attributes;
2394	symbol_attribute attr;
2395	tree result_decl;
2396	gfc_formal_arglist *f;
2397
2398	bool module_procedure = sym->attr.module_procedure
2399	&& sym->ns
2400	&& sym->ns->proc_name
2401	&& sym->ns->proc_name->attr.flavor == FL_MODULE;
2402
2403	gcc_assert (!sym->attr.external || module_procedure);
2404
2405	if (sym->backend_decl)
2406	return;
2407
2408	/* Set the line and filename. sym->declared_at seems to point to the
2409	last statement for subroutines, but it'll do for now. */
2410	gfc_set_backend_locus (&sym->declared_at);
2411
2412	/* Allow only one nesting level. Allow public declarations. */
2413	gcc_assert (current_function_decl == NULL_TREE
2414	|| DECL_FILE_SCOPE_P (current_function_decl)
2415	|| (TREE_CODE (DECL_CONTEXT (current_function_decl))
2416	== NAMESPACE_DECL));
2417
2418	type = gfc_get_function_type (sym);
2419	fndecl = build_decl (input_location,
2420	FUNCTION_DECL, gfc_sym_identifier (sym), type);
2421
2422	attr = sym->attr;
2423
2424	/* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
2425	TREE_PUBLIC specifies whether a function is globally addressable (i.e.
2426	the opposite of declaring a function as static in C). */
2427	DECL_EXTERNAL (fndecl) = 0;
2428
2429	if (sym->attr.access == ACCESS_UNKNOWN && sym->module
2430	&& (sym->ns->default_access == ACCESS_PRIVATE
2431	|| (sym->ns->default_access == ACCESS_UNKNOWN
2432	&& flag_module_private)))
2433	sym->attr.access = ACCESS_PRIVATE;
2434
2435	if (!current_function_decl
2436	&& !sym->attr.entry_master && !sym->attr.is_main_program
2437	&& (sym->attr.access != ACCESS_PRIVATE || sym->binding_label
2438	|| sym->attr.public_used))
2439	TREE_PUBLIC (fndecl) = 1;
2440
2441	if (sym->attr.referenced || sym->attr.entry_master)
2442	TREE_USED (fndecl) = 1;
2443
2444	attributes = add_attributes_to_decl (sym_attr: attr, NULL_TREE);
2445	decl_attributes (&fndecl, attributes, 0);
2446
2447	/* Figure out the return type of the declared function, and build a
2448	RESULT_DECL for it. If this is a subroutine with alternate
2449	returns, build a RESULT_DECL for it. */
2450	result_decl = NULL_TREE;
2451	/* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
2452	if (attr.function)
2453	{
2454	if (gfc_return_by_reference (sym))
2455	type = void_type_node;
2456	else
2457	{
2458	if (sym->result != sym)
2459	result_decl = gfc_sym_identifier (sym: sym->result);
2460
2461	type = TREE_TYPE (TREE_TYPE (fndecl));
2462	}
2463	}
2464	else
2465	{
2466	/* Look for alternate return placeholders. */
2467	int has_alternate_returns = 0;
2468	for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
2469	{
2470	if (f->sym == NULL)
2471	{
2472	has_alternate_returns = 1;
2473	break;
2474	}
2475	}
2476
2477	if (has_alternate_returns)
2478	type = integer_type_node;
2479	else
2480	type = void_type_node;
2481	}
2482
2483	result_decl = build_decl (input_location,
2484	RESULT_DECL, result_decl, type);
2485	DECL_ARTIFICIAL (result_decl) = 1;
2486	DECL_IGNORED_P (result_decl) = 1;
2487	DECL_CONTEXT (result_decl) = fndecl;
2488	DECL_RESULT (fndecl) = result_decl;
2489
2490	/* Don't call layout_decl for a RESULT_DECL.
2491	layout_decl (result_decl, 0); */
2492
2493	/* TREE_STATIC means the function body is defined here. */
2494	TREE_STATIC (fndecl) = 1;
2495
2496	/* Set attributes for PURE functions. A call to a PURE function in the
2497	Fortran 95 sense is both pure and without side effects in the C
2498	sense. */
2499	if (attr.pure || attr.implicit_pure)
2500	{
2501	/* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
2502	including an alternate return. In that case it can also be
2503	marked as PURE. See also in gfc_get_extern_function_decl(). */
2504	if (attr.function && !gfc_return_by_reference (sym))
2505	DECL_PURE_P (fndecl) = 1;
2506	TREE_SIDE_EFFECTS (fndecl) = 0;
2507	}
2508
2509	/* Mark noinline functions. */
2510	if (attr.ext_attr & (1 << EXT_ATTR_NOINLINE))
2511	DECL_UNINLINABLE (fndecl) = 1;
2512
2513	/* Mark noreturn functions. */
2514	if (attr.ext_attr & (1 << EXT_ATTR_NORETURN))
2515	TREE_THIS_VOLATILE (fndecl) = 1;
2516
2517	/* Mark weak functions. */
2518	if (attr.ext_attr & (1 << EXT_ATTR_WEAK))
2519	declare_weak (fndecl);
2520
2521	/* Layout the function declaration and put it in the binding level
2522	of the current function. */
2523
2524	if (global)
2525	pushdecl_top_level (fndecl);
2526	else
2527	pushdecl (fndecl);
2528
2529	/* Perform name mangling if this is a top level or module procedure. */
2530	if (current_function_decl == NULL_TREE)
2531	gfc_set_decl_assembler_name (decl: fndecl, name: gfc_sym_mangled_function_id (sym));
2532
2533	sym->backend_decl = fndecl;
2534	}
2535
2536
2537	/* Create the DECL_ARGUMENTS for a procedure.
2538	NOTE: The arguments added here must match the argument type created by
2539	gfc_get_function_type (). */
2540
2541	static void
2542	create_function_arglist (gfc_symbol * sym)
2543	{
2544	tree fndecl;
2545	gfc_formal_arglist *f;
2546	tree typelist, hidden_typelist, optval_typelist;
2547	tree arglist, hidden_arglist, optval_arglist;
2548	tree type;
2549	tree parm;
2550
2551	fndecl = sym->backend_decl;
2552
2553	/* Build formal argument list. Make sure that their TREE_CONTEXT is
2554	the new FUNCTION_DECL node. */
2555	arglist = NULL_TREE;
2556	hidden_arglist = NULL_TREE;
2557	optval_arglist = NULL_TREE;
2558	typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
2559
2560	if (sym->attr.entry_master)
2561	{
2562	type = TREE_VALUE (typelist);
2563	parm = build_decl (input_location,
2564	PARM_DECL, get_identifier ("__entry"), type);
2565
2566	DECL_CONTEXT (parm) = fndecl;
2567	DECL_ARG_TYPE (parm) = type;
2568	TREE_READONLY (parm) = 1;
2569	gfc_finish_decl (decl: parm);
2570	DECL_ARTIFICIAL (parm) = 1;
2571
2572	arglist = chainon (arglist, parm);
2573	typelist = TREE_CHAIN (typelist);
2574	}
2575
2576	if (gfc_return_by_reference (sym))
2577	{
2578	tree type = TREE_VALUE (typelist), length = NULL;
2579
2580	if (sym->ts.type == BT_CHARACTER)
2581	{
2582	/* Length of character result. */
2583	tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
2584
2585	length = build_decl (input_location,
2586	PARM_DECL,
2587	get_identifier (".__result"),
2588	len_type);
2589	if (POINTER_TYPE_P (len_type))
2590	{
2591	sym->ts.u.cl->passed_length = length;
2592	TREE_USED (length) = 1;
2593	}
2594	else if (!sym->ts.u.cl->length)
2595	{
2596	sym->ts.u.cl->backend_decl = length;
2597	TREE_USED (length) = 1;
2598	}
2599	gcc_assert (TREE_CODE (length) == PARM_DECL);
2600	DECL_CONTEXT (length) = fndecl;
2601	DECL_ARG_TYPE (length) = len_type;
2602	TREE_READONLY (length) = 1;
2603	DECL_ARTIFICIAL (length) = 1;
2604	gfc_finish_decl (decl: length);
2605	if (sym->ts.u.cl->backend_decl == NULL
2606	|| sym->ts.u.cl->backend_decl == length)
2607	{
2608	gfc_symbol *arg;
2609	tree backend_decl;
2610
2611	if (sym->ts.u.cl->backend_decl == NULL)
2612	{
2613	tree len = build_decl (input_location,
2614	VAR_DECL,
2615	get_identifier ("..__result"),
2616	gfc_charlen_type_node);
2617	DECL_ARTIFICIAL (len) = 1;
2618	TREE_USED (len) = 1;
2619	sym->ts.u.cl->backend_decl = len;
2620	}
2621
2622	/* Make sure PARM_DECL type doesn't point to incomplete type. */
2623	arg = sym->result ? sym->result : sym;
2624	backend_decl = arg->backend_decl;
2625	/* Temporary clear it, so that gfc_sym_type creates complete
2626	type. */
2627	arg->backend_decl = NULL;
2628	type = gfc_sym_type (arg);
2629	arg->backend_decl = backend_decl;
2630	type = build_reference_type (type);
2631	}
2632	}
2633
2634	parm = build_decl (input_location,
2635	PARM_DECL, get_identifier ("__result"), type);
2636
2637	DECL_CONTEXT (parm) = fndecl;
2638	DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2639	TREE_READONLY (parm) = 1;
2640	DECL_ARTIFICIAL (parm) = 1;
2641	gfc_finish_decl (decl: parm);
2642
2643	arglist = chainon (arglist, parm);
2644	typelist = TREE_CHAIN (typelist);
2645
2646	if (sym->ts.type == BT_CHARACTER)
2647	{
2648	gfc_allocate_lang_decl (decl: parm);
2649	arglist = chainon (arglist, length);
2650	typelist = TREE_CHAIN (typelist);
2651	}
2652	}
2653
2654	hidden_typelist = typelist;
2655	for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
2656	if (f->sym != NULL) /* Ignore alternate returns. */
2657	hidden_typelist = TREE_CHAIN (hidden_typelist);
2658
2659	/* Advance hidden_typelist over optional+value argument presence flags. */
2660	optval_typelist = hidden_typelist;
2661	for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
2662	if (f->sym != NULL
2663	&& f->sym->attr.optional && f->sym->attr.value
2664	&& !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS
2665	&& !gfc_bt_struct (f->sym->ts.type))
2666	hidden_typelist = TREE_CHAIN (hidden_typelist);
2667
2668	for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
2669	{
2670	char name[GFC_MAX_SYMBOL_LEN + 2];
2671
2672	/* Ignore alternate returns. */
2673	if (f->sym == NULL)
2674	continue;
2675
2676	type = TREE_VALUE (typelist);
2677
2678	if (f->sym->ts.type == BT_CHARACTER
2679	&& (!sym->attr.is_bind_c || sym->attr.entry_master))
2680	{
2681	tree len_type = TREE_VALUE (hidden_typelist);
2682	tree length = NULL_TREE;
2683	if (!f->sym->ts.deferred)
2684	gcc_assert (len_type == gfc_charlen_type_node);
2685	else
2686	gcc_assert (POINTER_TYPE_P (len_type));
2687
2688	strcpy (dest: &name[1], src: f->sym->name);
2689	name[0] = '_';
2690	length = build_decl (input_location,
2691	PARM_DECL, get_identifier (name), len_type);
2692
2693	hidden_arglist = chainon (hidden_arglist, length);
2694	DECL_CONTEXT (length) = fndecl;
2695	DECL_ARTIFICIAL (length) = 1;
2696	DECL_ARG_TYPE (length) = len_type;
2697	TREE_READONLY (length) = 1;
2698	gfc_finish_decl (decl: length);
2699
2700	/* Marking the length DECL_HIDDEN_STRING_LENGTH will lead
2701	to tail calls being disabled. Only do that if we
2702	potentially have broken callers. */
2703	if (flag_tail_call_workaround
2704	&& f->sym->ts.u.cl
2705	&& f->sym->ts.u.cl->length
2706	&& f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2707	&& (flag_tail_call_workaround == 2
2708	|| f->sym->ns->implicit_interface_calls))
2709	DECL_HIDDEN_STRING_LENGTH (length) = 1;
2710
2711	/* Remember the passed value. */
2712	if (!f->sym->ts.u.cl || f->sym->ts.u.cl->passed_length)
2713	{
2714	/* This can happen if the same type is used for multiple
2715	arguments. We need to copy cl as otherwise
2716	cl->passed_length gets overwritten. */
2717	f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
2718	}
2719	f->sym->ts.u.cl->passed_length = length;
2720
2721	/* Use the passed value for assumed length variables. */
2722	if (!f->sym->ts.u.cl->length)
2723	{
2724	TREE_USED (length) = 1;
2725	gcc_assert (!f->sym->ts.u.cl->backend_decl);
2726	f->sym->ts.u.cl->backend_decl = length;
2727	}
2728
2729	hidden_typelist = TREE_CHAIN (hidden_typelist);
2730
2731	if (f->sym->ts.u.cl->backend_decl == NULL
2732	|| f->sym->ts.u.cl->backend_decl == length)
2733	{
2734	if (POINTER_TYPE_P (len_type))
2735	f->sym->ts.u.cl->backend_decl
2736	= build_fold_indirect_ref_loc (input_location, length);
2737	else if (f->sym->ts.u.cl->backend_decl == NULL)
2738	gfc_create_string_length (sym: f->sym);
2739
2740	/* Make sure PARM_DECL type doesn't point to incomplete type. */
2741	if (f->sym->attr.flavor == FL_PROCEDURE)
2742	type = build_pointer_type (gfc_get_function_type (f->sym));
2743	else
2744	type = gfc_sym_type (f->sym);
2745	}
2746	}
2747	/* For scalar intrinsic types, VALUE passes the value,
2748	hence, the optional status cannot be transferred via a NULL pointer.
2749	Thus, we will use a hidden argument in that case. */
2750	if (f->sym->attr.optional && f->sym->attr.value
2751	&& !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS
2752	&& !gfc_bt_struct (f->sym->ts.type))
2753	{
2754	tree tmp;
2755	strcpy (dest: &name[1], src: f->sym->name);
2756	name[0] = '.';
2757	tmp = build_decl (input_location,
2758	PARM_DECL, get_identifier (name),
2759	boolean_type_node);
2760
2761	optval_arglist = chainon (optval_arglist, tmp);
2762	DECL_CONTEXT (tmp) = fndecl;
2763	DECL_ARTIFICIAL (tmp) = 1;
2764	DECL_ARG_TYPE (tmp) = boolean_type_node;
2765	TREE_READONLY (tmp) = 1;
2766	gfc_finish_decl (decl: tmp);
2767
2768	/* The presence flag must be boolean. */
2769	gcc_assert (TREE_VALUE (optval_typelist) == boolean_type_node);
2770	optval_typelist = TREE_CHAIN (optval_typelist);
2771	}
2772
2773	/* For non-constant length array arguments, make sure they use
2774	a different type node from TYPE_ARG_TYPES type. */
2775	if (f->sym->attr.dimension
2776	&& type == TREE_VALUE (typelist)
2777	&& TREE_CODE (type) == POINTER_TYPE
2778	&& GFC_ARRAY_TYPE_P (type)
2779	&& f->sym->as->type != AS_ASSUMED_SIZE
2780	&& ! COMPLETE_TYPE_P (TREE_TYPE (type)))
2781	{
2782	if (f->sym->attr.flavor == FL_PROCEDURE)
2783	type = build_pointer_type (gfc_get_function_type (f->sym));
2784	else
2785	type = gfc_sym_type (f->sym);
2786	}
2787
2788	if (f->sym->attr.proc_pointer)
2789	type = build_pointer_type (type);
2790
2791	if (f->sym->attr.volatile_)
2792	type = build_qualified_type (type, TYPE_QUAL_VOLATILE);
2793
2794	/* Build the argument declaration. For C descriptors, we use a
2795	'_'-prefixed name for the parm_decl and inside the proc the
2796	sym->name. */
2797	tree parm_name;
2798	if (sym->attr.is_bind_c && is_CFI_desc (f->sym, NULL))
2799	{
2800	strcpy (dest: &name[1], src: f->sym->name);
2801	name[0] = '_';
2802	parm_name = get_identifier (name);
2803	}
2804	else
2805	parm_name = gfc_sym_identifier (sym: f->sym);
2806	parm = build_decl (input_location, PARM_DECL, parm_name, type);
2807
2808	if (f->sym->attr.volatile_)
2809	{
2810	TREE_THIS_VOLATILE (parm) = 1;
2811	TREE_SIDE_EFFECTS (parm) = 1;
2812	}
2813
2814	/* Fill in arg stuff. */
2815	DECL_CONTEXT (parm) = fndecl;
2816	DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2817	/* All implementation args except for VALUE are read-only. */
2818	if (!f->sym->attr.value)
2819	TREE_READONLY (parm) = 1;
2820	if (POINTER_TYPE_P (type)
2821	&& (!f->sym->attr.proc_pointer
2822	&& f->sym->attr.flavor != FL_PROCEDURE))
2823	DECL_BY_REFERENCE (parm) = 1;
2824	if (f->sym->attr.optional)
2825	{
2826	gfc_allocate_lang_decl (decl: parm);
2827	GFC_DECL_OPTIONAL_ARGUMENT (parm) = 1;
2828	}
2829
2830	gfc_finish_decl (decl: parm);
2831	gfc_finish_decl_attrs (decl: parm, attr: &f->sym->attr);
2832
2833	f->sym->backend_decl = parm;
2834
2835	/* Coarrays which are descriptorless or assumed-shape pass with
2836	-fcoarray=lib the token and the offset as hidden arguments. */
2837	if (flag_coarray == GFC_FCOARRAY_LIB
2838	&& ((f->sym->ts.type != BT_CLASS && f->sym->attr.codimension
2839	&& !f->sym->attr.allocatable)
2840	|| (f->sym->ts.type == BT_CLASS
2841	&& CLASS_DATA (f->sym)->attr.codimension
2842	&& !CLASS_DATA (f->sym)->attr.allocatable)))
2843	{
2844	tree caf_type;
2845	tree token;
2846	tree offset;
2847
2848	gcc_assert (f->sym->backend_decl != NULL_TREE
2849	&& !sym->attr.is_bind_c);
2850	caf_type = f->sym->ts.type == BT_CLASS
2851	? TREE_TYPE (CLASS_DATA (f->sym)->backend_decl)
2852	: TREE_TYPE (f->sym->backend_decl);
2853
2854	token = build_decl (input_location, PARM_DECL,
2855	create_tmp_var_name ("caf_token"),
2856	build_qualified_type (pvoid_type_node,
2857	TYPE_QUAL_RESTRICT));
2858	if ((f->sym->ts.type != BT_CLASS
2859	&& f->sym->as->type != AS_DEFERRED)
2860	|| (f->sym->ts.type == BT_CLASS
2861	&& CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
2862	{
2863	gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL
2864	|| GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE);
2865	if (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL)
2866	gfc_allocate_lang_decl (decl: f->sym->backend_decl);
2867	GFC_DECL_TOKEN (f->sym->backend_decl) = token;
2868	}
2869	else
2870	{
2871	gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
2872	GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
2873	}
2874
2875	DECL_CONTEXT (token) = fndecl;
2876	DECL_ARTIFICIAL (token) = 1;
2877	DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
2878	TREE_READONLY (token) = 1;
2879	hidden_arglist = chainon (hidden_arglist, token);
2880	hidden_typelist = TREE_CHAIN (hidden_typelist);
2881	gfc_finish_decl (decl: token);
2882
2883	offset = build_decl (input_location, PARM_DECL,
2884	create_tmp_var_name ("caf_offset"),
2885	gfc_array_index_type);
2886
2887	if ((f->sym->ts.type != BT_CLASS
2888	&& f->sym->as->type != AS_DEFERRED)
2889	|| (f->sym->ts.type == BT_CLASS
2890	&& CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
2891	{
2892	gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl)
2893	== NULL_TREE);
2894	GFC_DECL_CAF_OFFSET (f->sym->backend_decl) = offset;
2895	}
2896	else
2897	{
2898	gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE);
2899	GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset;
2900	}
2901	DECL_CONTEXT (offset) = fndecl;
2902	DECL_ARTIFICIAL (offset) = 1;
2903	DECL_ARG_TYPE (offset) = TREE_VALUE (typelist);
2904	TREE_READONLY (offset) = 1;
2905	hidden_arglist = chainon (hidden_arglist, offset);
2906	hidden_typelist = TREE_CHAIN (hidden_typelist);
2907	gfc_finish_decl (decl: offset);
2908	}
2909
2910	arglist = chainon (arglist, parm);
2911	typelist = TREE_CHAIN (typelist);
2912	}
2913
2914	/* Add hidden present status for optional+value arguments. */
2915	arglist = chainon (arglist, optval_arglist);
2916
2917	/* Add the hidden string length parameters, unless the procedure
2918	is bind(C). */
2919	if (!sym->attr.is_bind_c)
2920	arglist = chainon (arglist, hidden_arglist);
2921
2922	gcc_assert (hidden_typelist == NULL_TREE
2923	|| TREE_VALUE (hidden_typelist) == void_type_node);
2924	DECL_ARGUMENTS (fndecl) = arglist;
2925	}
2926
2927	/* Do the setup necessary before generating the body of a function. */
2928
2929	static void
2930	trans_function_start (gfc_symbol * sym)
2931	{
2932	tree fndecl;
2933
2934	fndecl = sym->backend_decl;
2935
2936	/* Let GCC know the current scope is this function. */
2937	current_function_decl = fndecl;
2938
2939	/* Let the world know what we're about to do. */
2940	announce_function (fndecl);
2941
2942	if (DECL_FILE_SCOPE_P (fndecl))
2943	{
2944	/* Create RTL for function declaration. */
2945	rest_of_decl_compilation (fndecl, 1, 0);
2946	}
2947
2948	/* Create RTL for function definition. */
2949	make_decl_rtl (fndecl);
2950
2951	allocate_struct_function (fndecl, false);
2952
2953	/* function.cc requires a push at the start of the function. */
2954	pushlevel ();
2955	}
2956
2957	/* Create thunks for alternate entry points. */
2958
2959	static void
2960	build_entry_thunks (gfc_namespace * ns, bool global)
2961	{
2962	gfc_formal_arglist *formal;
2963	gfc_formal_arglist *thunk_formal;
2964	gfc_entry_list *el;
2965	gfc_symbol *thunk_sym;
2966	stmtblock_t body;
2967	tree thunk_fndecl;
2968	tree tmp;
2969	locus old_loc;
2970
2971	/* This should always be a toplevel function. */
2972	gcc_assert (current_function_decl == NULL_TREE);
2973
2974	gfc_save_backend_locus (&old_loc);
2975	for (el = ns->entries; el; el = el->next)
2976	{
2977	vec<tree, va_gc> *args = NULL;
2978	vec<tree, va_gc> *string_args = NULL;
2979
2980	thunk_sym = el->sym;
2981
2982	build_function_decl (sym: thunk_sym, global);
2983	create_function_arglist (sym: thunk_sym);
2984
2985	trans_function_start (sym: thunk_sym);
2986
2987	thunk_fndecl = thunk_sym->backend_decl;
2988
2989	gfc_init_block (&body);
2990
2991	/* Pass extra parameter identifying this entry point. */
2992	tmp = build_int_cst (gfc_array_index_type, el->id);
2993	vec_safe_push (v&: args, obj: tmp);
2994
2995	if (thunk_sym->attr.function)
2996	{
2997	if (gfc_return_by_reference (ns->proc_name))
2998	{
2999	tree ref = DECL_ARGUMENTS (current_function_decl);
3000	vec_safe_push (v&: args, obj: ref);
3001	if (ns->proc_name->ts.type == BT_CHARACTER)
3002	vec_safe_push (v&: args, DECL_CHAIN (ref));
3003	}
3004	}
3005
3006	for (formal = gfc_sym_get_dummy_args (ns->proc_name); formal;
3007	formal = formal->next)
3008	{
3009	/* Ignore alternate returns. */
3010	if (formal->sym == NULL)
3011	continue;
3012
3013	/* We don't have a clever way of identifying arguments, so resort to
3014	a brute-force search. */
3015	for (thunk_formal = gfc_sym_get_dummy_args (thunk_sym);
3016	thunk_formal;
3017	thunk_formal = thunk_formal->next)
3018	{
3019	if (thunk_formal->sym == formal->sym)
3020	break;
3021	}
3022
3023	if (thunk_formal)
3024	{
3025	/* Pass the argument. */
3026	DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
3027	vec_safe_push (v&: args, obj: thunk_formal->sym->backend_decl);
3028	if (formal->sym->ts.type == BT_CHARACTER)
3029	{
3030	tmp = thunk_formal->sym->ts.u.cl->backend_decl;
3031	vec_safe_push (v&: string_args, obj: tmp);
3032	}
3033	}
3034	else
3035	{
3036	/* Pass NULL for a missing argument. */
3037	vec_safe_push (v&: args, null_pointer_node);
3038	if (formal->sym->ts.type == BT_CHARACTER)
3039	{
3040	tmp = build_int_cst (gfc_charlen_type_node, 0);
3041	vec_safe_push (v&: string_args, obj: tmp);
3042	}
3043	}
3044	}
3045
3046	/* Call the master function. */
3047	vec_safe_splice (dst&: args, src: string_args);
3048	tmp = ns->proc_name->backend_decl;
3049	tmp = build_call_expr_loc_vec (input_location, tmp, args);
3050	if (ns->proc_name->attr.mixed_entry_master)
3051	{
3052	tree union_decl, field;
3053	tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
3054
3055	union_decl = build_decl (input_location,
3056	VAR_DECL, get_identifier ("__result"),
3057	TREE_TYPE (master_type));
3058	DECL_ARTIFICIAL (union_decl) = 1;
3059	DECL_EXTERNAL (union_decl) = 0;
3060	TREE_PUBLIC (union_decl) = 0;
3061	TREE_USED (union_decl) = 1;
3062	layout_decl (union_decl, 0);
3063	pushdecl (union_decl);
3064
3065	DECL_CONTEXT (union_decl) = current_function_decl;
3066	tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3067	TREE_TYPE (union_decl), union_decl, tmp);
3068	gfc_add_expr_to_block (&body, tmp);
3069
3070	for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
3071	field; field = DECL_CHAIN (field))
3072	if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
3073	s2: thunk_sym->result->name) == 0)
3074	break;
3075	gcc_assert (field != NULL_TREE);
3076	tmp = fold_build3_loc (input_location, COMPONENT_REF,
3077	TREE_TYPE (field), union_decl, field,
3078	NULL_TREE);
3079	tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3080	TREE_TYPE (DECL_RESULT (current_function_decl)),
3081	DECL_RESULT (current_function_decl), tmp);
3082	tmp = build1_v (RETURN_EXPR, tmp);
3083	}
3084	else if (TREE_TYPE (DECL_RESULT (current_function_decl))
3085	!= void_type_node)
3086	{
3087	tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3088	TREE_TYPE (DECL_RESULT (current_function_decl)),
3089	DECL_RESULT (current_function_decl), tmp);
3090	tmp = build1_v (RETURN_EXPR, tmp);
3091	}
3092	gfc_add_expr_to_block (&body, tmp);
3093
3094	/* Finish off this function and send it for code generation. */
3095	DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
3096	tmp = getdecls ();
3097	poplevel (1, 1);
3098	BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
3099	DECL_SAVED_TREE (thunk_fndecl)
3100	= fold_build3_loc (DECL_SOURCE_LOCATION (thunk_fndecl), BIND_EXPR,
3101	void_type_node, tmp, DECL_SAVED_TREE (thunk_fndecl),
3102	DECL_INITIAL (thunk_fndecl));
3103
3104	/* Output the GENERIC tree. */
3105	dump_function (phase: TDI_original, fn: thunk_fndecl);
3106
3107	/* Store the end of the function, so that we get good line number
3108	info for the epilogue. */
3109	cfun->function_end_locus = input_location;
3110
3111	/* We're leaving the context of this function, so zap cfun.
3112	It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
3113	tree_rest_of_compilation. */
3114	set_cfun (NULL);
3115
3116	current_function_decl = NULL_TREE;
3117
3118	cgraph_node::finalize_function (thunk_fndecl, true);
3119
3120	/* We share the symbols in the formal argument list with other entry
3121	points and the master function. Clear them so that they are
3122	recreated for each function. */
3123	for (formal = gfc_sym_get_dummy_args (thunk_sym); formal;
3124	formal = formal->next)
3125	if (formal->sym != NULL) /* Ignore alternate returns. */
3126	{
3127	formal->sym->backend_decl = NULL_TREE;
3128	if (formal->sym->ts.type == BT_CHARACTER)
3129	formal->sym->ts.u.cl->backend_decl = NULL_TREE;
3130	}
3131
3132	if (thunk_sym->attr.function)
3133	{
3134	if (thunk_sym->ts.type == BT_CHARACTER)
3135	thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
3136	if (thunk_sym->result->ts.type == BT_CHARACTER)
3137	thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
3138	}
3139	}
3140
3141	gfc_restore_backend_locus (&old_loc);
3142	}
3143
3144
3145	/* Create a decl for a function, and create any thunks for alternate entry
3146	points. If global is true, generate the function in the global binding
3147	level, otherwise in the current binding level (which can be global). */
3148
3149	void
3150	gfc_create_function_decl (gfc_namespace * ns, bool global)
3151	{
3152	/* Create a declaration for the master function. */
3153	build_function_decl (sym: ns->proc_name, global);
3154
3155	/* Compile the entry thunks. */
3156	if (ns->entries)
3157	build_entry_thunks (ns, global);
3158
3159	/* Now create the read argument list. */
3160	create_function_arglist (sym: ns->proc_name);
3161
3162	if (ns->omp_declare_simd)
3163	gfc_trans_omp_declare_simd (ns);
3164
3165	/* Handle 'declare variant' directives. The applicable directives might
3166	be declared in a parent namespace, so this needs to be called even if
3167	there are no local directives. */
3168	if (flag_openmp)
3169	gfc_trans_omp_declare_variant (ns);
3170	}
3171
3172	/* Return the decl used to hold the function return value. If
3173	parent_flag is set, the context is the parent_scope. */
3174
3175	tree
3176	gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
3177	{
3178	tree decl;
3179	tree length;
3180	tree this_fake_result_decl;
3181	tree this_function_decl;
3182
3183	char name[GFC_MAX_SYMBOL_LEN + 10];
3184
3185	if (parent_flag)
3186	{
3187	this_fake_result_decl = parent_fake_result_decl;
3188	this_function_decl = DECL_CONTEXT (current_function_decl);
3189	}
3190	else
3191	{
3192	this_fake_result_decl = current_fake_result_decl;
3193	this_function_decl = current_function_decl;
3194	}
3195
3196	if (sym
3197	&& sym->ns->proc_name->backend_decl == this_function_decl
3198	&& sym->ns->proc_name->attr.entry_master
3199	&& sym != sym->ns->proc_name)
3200	{
3201	tree t = NULL, var;
3202	if (this_fake_result_decl != NULL)
3203	for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
3204	if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), s2: sym->name) == 0)
3205	break;
3206	if (t)
3207	return TREE_VALUE (t);
3208	decl = gfc_get_fake_result_decl (sym: sym->ns->proc_name, parent_flag);
3209
3210	if (parent_flag)
3211	this_fake_result_decl = parent_fake_result_decl;
3212	else
3213	this_fake_result_decl = current_fake_result_decl;
3214
3215	if (decl && sym->ns->proc_name->attr.mixed_entry_master)
3216	{
3217	tree field;
3218
3219	for (field = TYPE_FIELDS (TREE_TYPE (decl));
3220	field; field = DECL_CHAIN (field))
3221	if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
3222	s2: sym->name) == 0)
3223	break;
3224
3225	gcc_assert (field != NULL_TREE);
3226	decl = fold_build3_loc (input_location, COMPONENT_REF,
3227	TREE_TYPE (field), decl, field, NULL_TREE);
3228	}
3229
3230	var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
3231	if (parent_flag)
3232	gfc_add_decl_to_parent_function (decl: var);
3233	else
3234	gfc_add_decl_to_function (decl: var);
3235
3236	SET_DECL_VALUE_EXPR (var, decl);
3237	DECL_HAS_VALUE_EXPR_P (var) = 1;
3238	GFC_DECL_RESULT (var) = 1;
3239
3240	TREE_CHAIN (this_fake_result_decl)
3241	= tree_cons (get_identifier (sym->name), var,
3242	TREE_CHAIN (this_fake_result_decl));
3243	return var;
3244	}
3245
3246	if (this_fake_result_decl != NULL_TREE)
3247	return TREE_VALUE (this_fake_result_decl);
3248
3249	/* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
3250	sym is NULL. */
3251	if (!sym)
3252	return NULL_TREE;
3253
3254	if (sym->ts.type == BT_CHARACTER)
3255	{
3256	if (sym->ts.u.cl->backend_decl == NULL_TREE)
3257	length = gfc_create_string_length (sym);
3258	else
3259	length = sym->ts.u.cl->backend_decl;
3260	if (VAR_P (length) && DECL_CONTEXT (length) == NULL_TREE)
3261	gfc_add_decl_to_function (decl: length);
3262	}
3263
3264	if (gfc_return_by_reference (sym))
3265	{
3266	decl = DECL_ARGUMENTS (this_function_decl);
3267
3268	if (sym->ns->proc_name->backend_decl == this_function_decl
3269	&& sym->ns->proc_name->attr.entry_master)
3270	decl = DECL_CHAIN (decl);
3271
3272	TREE_USED (decl) = 1;
3273	if (sym->as)
3274	decl = gfc_build_dummy_array_decl (sym, dummy: decl);
3275	}
3276	else
3277	{
3278	sprintf (s: name, format: "__result_%.20s",
3279	IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
3280
3281	if (!sym->attr.mixed_entry_master && sym->attr.function)
3282	decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
3283	VAR_DECL, get_identifier (name),
3284	gfc_sym_type (sym));
3285	else
3286	decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
3287	VAR_DECL, get_identifier (name),
3288	TREE_TYPE (TREE_TYPE (this_function_decl)));
3289	DECL_ARTIFICIAL (decl) = 1;
3290	DECL_EXTERNAL (decl) = 0;
3291	TREE_PUBLIC (decl) = 0;
3292	TREE_USED (decl) = 1;
3293	GFC_DECL_RESULT (decl) = 1;
3294	TREE_ADDRESSABLE (decl) = 1;
3295
3296	layout_decl (decl, 0);
3297	gfc_finish_decl_attrs (decl, attr: &sym->attr);
3298
3299	if (parent_flag)
3300	gfc_add_decl_to_parent_function (decl);
3301	else
3302	gfc_add_decl_to_function (decl);
3303	}
3304
3305	if (parent_flag)
3306	parent_fake_result_decl = build_tree_list (NULL, decl);
3307	else
3308	current_fake_result_decl = build_tree_list (NULL, decl);
3309
3310	if (sym->attr.assign)
3311	DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
3312
3313	return decl;
3314	}
3315
3316
3317	/* Builds a function decl. The remaining parameters are the types of the
3318	function arguments. Negative nargs indicates a varargs function. */
3319
3320	static tree
3321	build_library_function_decl_1 (tree name, const char *spec,
3322	tree rettype, int nargs, va_list p)
3323	{
3324	vec<tree, va_gc> *arglist;
3325	tree fntype;
3326	tree fndecl;
3327	int n;
3328
3329	/* Library functions must be declared with global scope. */
3330	gcc_assert (current_function_decl == NULL_TREE);
3331
3332	/* Create a list of the argument types. */
3333	vec_alloc (v&: arglist, nelems: abs (x: nargs));
3334	for (n = abs (x: nargs); n > 0; n--)
3335	{
3336	tree argtype = va_arg (p, tree);
3337	arglist->quick_push (obj: argtype);
3338	}
3339
3340	/* Build the function type and decl. */
3341	if (nargs >= 0)
3342	fntype = build_function_type_vec (rettype, arglist);
3343	else
3344	fntype = build_varargs_function_type_vec (rettype, arglist);
3345	if (spec)
3346	{
3347	tree attr_args = build_tree_list (NULL_TREE,
3348	build_string (strlen (s: spec), spec));
3349	tree attrs = tree_cons (get_identifier ("fn spec"),
3350	attr_args, TYPE_ATTRIBUTES (fntype));
3351	fntype = build_type_attribute_variant (fntype, attrs);
3352	}
3353	fndecl = build_decl (input_location,
3354	FUNCTION_DECL, name, fntype);
3355
3356	/* Mark this decl as external. */
3357	DECL_EXTERNAL (fndecl) = 1;
3358	TREE_PUBLIC (fndecl) = 1;
3359
3360	pushdecl (fndecl);
3361
3362	rest_of_decl_compilation (fndecl, 1, 0);
3363
3364	return fndecl;
3365	}
3366
3367	/* Builds a function decl. The remaining parameters are the types of the
3368	function arguments. Negative nargs indicates a varargs function. */
3369
3370	tree
3371	gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
3372	{
3373	tree ret;
3374	va_list args;
3375	va_start (args, nargs);
3376	ret = build_library_function_decl_1 (name, NULL, rettype, nargs, p: args);
3377	va_end (args);
3378	return ret;
3379	}
3380
3381	/* Builds a function decl. The remaining parameters are the types of the
3382	function arguments. Negative nargs indicates a varargs function.
3383	The SPEC parameter specifies the function argument and return type
3384	specification according to the fnspec function type attribute. */
3385
3386	tree
3387	gfc_build_library_function_decl_with_spec (tree name, const char *spec,
3388	tree rettype, int nargs, ...)
3389	{
3390	tree ret;
3391	va_list args;
3392	va_start (args, nargs);
3393	if (flag_checking)
3394	{
3395	attr_fnspec fnspec (spec, strlen (s: spec));
3396	fnspec.verify ();
3397	}
3398	ret = build_library_function_decl_1 (name, spec, rettype, nargs, p: args);
3399	va_end (args);
3400	return ret;
3401	}
3402
3403	static void
3404	gfc_build_intrinsic_function_decls (void)
3405	{
3406	tree gfc_int4_type_node = gfc_get_int_type (4);
3407	tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
3408	tree gfc_int8_type_node = gfc_get_int_type (8);
3409	tree gfc_pint8_type_node = build_pointer_type (gfc_int8_type_node);
3410	tree gfc_int16_type_node = gfc_get_int_type (16);
3411	tree gfc_logical4_type_node = gfc_get_logical_type (4);
3412	tree pchar1_type_node = gfc_get_pchar_type (1);
3413	tree pchar4_type_node = gfc_get_pchar_type (4);
3414
3415	/* String functions. */
3416	gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec (
3417	get_identifier (PREFIX("compare_string")), spec: ". . R . R ",
3418	integer_type_node, nargs: 4, gfc_charlen_type_node, pchar1_type_node,
3419	gfc_charlen_type_node, pchar1_type_node);
3420	DECL_PURE_P (gfor_fndecl_compare_string) = 1;
3421	TREE_NOTHROW (gfor_fndecl_compare_string) = 1;
3422
3423	gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec (
3424	get_identifier (PREFIX("concat_string")), spec: ". . W . R . R ",
3425	void_type_node, nargs: 6, gfc_charlen_type_node, pchar1_type_node,
3426	gfc_charlen_type_node, pchar1_type_node,
3427	gfc_charlen_type_node, pchar1_type_node);
3428	TREE_NOTHROW (gfor_fndecl_concat_string) = 1;
3429
3430	gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec (
3431	get_identifier (PREFIX("string_len_trim")), spec: ". . R ",
3432	rettype: gfc_charlen_type_node, nargs: 2, gfc_charlen_type_node, pchar1_type_node);
3433	DECL_PURE_P (gfor_fndecl_string_len_trim) = 1;
3434	TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1;
3435
3436	gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec (
3437	get_identifier (PREFIX("string_index")), spec: ". . R . R . ",
3438	rettype: gfc_charlen_type_node, nargs: 5, gfc_charlen_type_node, pchar1_type_node,
3439	gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
3440	DECL_PURE_P (gfor_fndecl_string_index) = 1;
3441	TREE_NOTHROW (gfor_fndecl_string_index) = 1;
3442
3443	gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec (
3444	get_identifier (PREFIX("string_scan")), spec: ". . R . R . ",
3445	rettype: gfc_charlen_type_node, nargs: 5, gfc_charlen_type_node, pchar1_type_node,
3446	gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
3447	DECL_PURE_P (gfor_fndecl_string_scan) = 1;
3448	TREE_NOTHROW (gfor_fndecl_string_scan) = 1;
3449
3450	gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec (
3451	get_identifier (PREFIX("string_verify")), spec: ". . R . R . ",
3452	rettype: gfc_charlen_type_node, nargs: 5, gfc_charlen_type_node, pchar1_type_node,
3453	gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
3454	DECL_PURE_P (gfor_fndecl_string_verify) = 1;
3455	TREE_NOTHROW (gfor_fndecl_string_verify) = 1;
3456
3457	gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec (
3458	get_identifier (PREFIX("string_trim")), spec: ". W w . R ",
3459	void_type_node, nargs: 4, build_pointer_type (gfc_charlen_type_node),
3460	build_pointer_type (pchar1_type_node), gfc_charlen_type_node,
3461	pchar1_type_node);
3462
3463	gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec (
3464	get_identifier (PREFIX("string_minmax")), spec: ". W w . R ",
3465	void_type_node, nargs: -4, build_pointer_type (gfc_charlen_type_node),
3466	build_pointer_type (pchar1_type_node), integer_type_node,
3467	integer_type_node);
3468
3469	gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
3470	get_identifier (PREFIX("adjustl")), spec: ". W . R ",
3471	void_type_node, nargs: 3, pchar1_type_node, gfc_charlen_type_node,
3472	pchar1_type_node);
3473	TREE_NOTHROW (gfor_fndecl_adjustl) = 1;
3474
3475	gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec (
3476	get_identifier (PREFIX("adjustr")), spec: ". W . R ",
3477	void_type_node, nargs: 3, pchar1_type_node, gfc_charlen_type_node,
3478	pchar1_type_node);
3479	TREE_NOTHROW (gfor_fndecl_adjustr) = 1;
3480
3481	gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec (
3482	get_identifier (PREFIX("select_string")), spec: ". R . R . ",
3483	integer_type_node, nargs: 4, pvoid_type_node, integer_type_node,
3484	pchar1_type_node, gfc_charlen_type_node);
3485	DECL_PURE_P (gfor_fndecl_select_string) = 1;
3486	TREE_NOTHROW (gfor_fndecl_select_string) = 1;
3487
3488	gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec (
3489	get_identifier (PREFIX("compare_string_char4")), spec: ". . R . R ",
3490	integer_type_node, nargs: 4, gfc_charlen_type_node, pchar4_type_node,
3491	gfc_charlen_type_node, pchar4_type_node);
3492	DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1;
3493	TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1;
3494
3495	gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec (
3496	get_identifier (PREFIX("concat_string_char4")), spec: ". . W . R . R ",
3497	void_type_node, nargs: 6, gfc_charlen_type_node, pchar4_type_node,
3498	gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
3499	pchar4_type_node);
3500	TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1;
3501
3502	gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec (
3503	get_identifier (PREFIX("string_len_trim_char4")), spec: ". . R ",
3504	rettype: gfc_charlen_type_node, nargs: 2, gfc_charlen_type_node, pchar4_type_node);
3505	DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1;
3506	TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1;
3507
3508	gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec (
3509	get_identifier (PREFIX("string_index_char4")), spec: ". . R . R . ",
3510	rettype: gfc_charlen_type_node, nargs: 5, gfc_charlen_type_node, pchar4_type_node,
3511	gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
3512	DECL_PURE_P (gfor_fndecl_string_index_char4) = 1;
3513	TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1;
3514
3515	gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec (
3516	get_identifier (PREFIX("string_scan_char4")), spec: ". . R . R . ",
3517	rettype: gfc_charlen_type_node, nargs: 5, gfc_charlen_type_node, pchar4_type_node,
3518	gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
3519	DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1;
3520	TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1;
3521
3522	gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec (
3523	get_identifier (PREFIX("string_verify_char4")), spec: ". . R . R . ",
3524	rettype: gfc_charlen_type_node, nargs: 5, gfc_charlen_type_node, pchar4_type_node,
3525	gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
3526	DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1;
3527	TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1;
3528
3529	gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec (
3530	get_identifier (PREFIX("string_trim_char4")), spec: ". W w . R ",
3531	void_type_node, nargs: 4, build_pointer_type (gfc_charlen_type_node),
3532	build_pointer_type (pchar4_type_node), gfc_charlen_type_node,
3533	pchar4_type_node);
3534
3535	gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec (
3536	get_identifier (PREFIX("string_minmax_char4")), spec: ". W w . R ",
3537	void_type_node, nargs: -4, build_pointer_type (gfc_charlen_type_node),
3538	build_pointer_type (pchar4_type_node), integer_type_node,
3539	integer_type_node);
3540
3541	gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
3542	get_identifier (PREFIX("adjustl_char4")), spec: ". W . R ",
3543	void_type_node, nargs: 3, pchar4_type_node, gfc_charlen_type_node,
3544	pchar4_type_node);
3545	TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1;
3546
3547	gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec (
3548	get_identifier (PREFIX("adjustr_char4")), spec: ". W . R ",
3549	void_type_node, nargs: 3, pchar4_type_node, gfc_charlen_type_node,
3550	pchar4_type_node);
3551	TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1;
3552
3553	gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec (
3554	get_identifier (PREFIX("select_string_char4")), spec: ". R . R . ",
3555	integer_type_node, nargs: 4, pvoid_type_node, integer_type_node,
3556	pvoid_type_node, gfc_charlen_type_node);
3557	DECL_PURE_P (gfor_fndecl_select_string_char4) = 1;
3558	TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1;
3559
3560
3561	/* Conversion between character kinds. */
3562
3563	gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec (
3564	get_identifier (PREFIX("convert_char1_to_char4")), spec: ". w . R ",
3565	void_type_node, nargs: 3, build_pointer_type (pchar4_type_node),
3566	gfc_charlen_type_node, pchar1_type_node);
3567
3568	gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec (
3569	get_identifier (PREFIX("convert_char4_to_char1")), spec: ". w . R ",
3570	void_type_node, nargs: 3, build_pointer_type (pchar1_type_node),
3571	gfc_charlen_type_node, pchar4_type_node);
3572
3573	/* Misc. functions. */
3574
3575	gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec (
3576	get_identifier (PREFIX("ttynam")), spec: ". W . . ",
3577	void_type_node, nargs: 3, pchar_type_node, gfc_charlen_type_node,
3578	integer_type_node);
3579
3580	gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec (
3581	get_identifier (PREFIX("fdate")), spec: ". W . ",
3582	void_type_node, nargs: 2, pchar_type_node, gfc_charlen_type_node);
3583
3584	gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec (
3585	get_identifier (PREFIX("ctime")), spec: ". W . . ",
3586	void_type_node, nargs: 3, pchar_type_node, gfc_charlen_type_node,
3587	gfc_int8_type_node);
3588
3589	gfor_fndecl_random_init = gfc_build_library_function_decl (
3590	get_identifier (PREFIX("random_init")),
3591	void_type_node, nargs: 3, gfc_logical4_type_node, gfc_logical4_type_node,
3592	gfc_int4_type_node);
3593
3594	// gfor_fndecl_caf_rand_init is defined in the lib-coarray section below.
3595
3596	gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
3597	get_identifier (PREFIX("selected_char_kind")), spec: ". . R ",
3598	rettype: gfc_int4_type_node, nargs: 2, gfc_charlen_type_node, pchar_type_node);
3599	DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
3600	TREE_NOTHROW (gfor_fndecl_sc_kind) = 1;
3601
3602	gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec (
3603	get_identifier (PREFIX("selected_int_kind")), spec: ". R ",
3604	rettype: gfc_int4_type_node, nargs: 1, pvoid_type_node);
3605	DECL_PURE_P (gfor_fndecl_si_kind) = 1;
3606	TREE_NOTHROW (gfor_fndecl_si_kind) = 1;
3607
3608	gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec (
3609	get_identifier (PREFIX("selected_real_kind2008")), spec: ". R R ",
3610	rettype: gfc_int4_type_node, nargs: 3, pvoid_type_node, pvoid_type_node,
3611	pvoid_type_node);
3612	DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
3613	TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
3614
3615	gfor_fndecl_system_clock4 = gfc_build_library_function_decl (
3616	get_identifier (PREFIX("system_clock_4")),
3617	void_type_node, nargs: 3, gfc_pint4_type_node, gfc_pint4_type_node,
3618	gfc_pint4_type_node);
3619
3620	gfor_fndecl_system_clock8 = gfc_build_library_function_decl (
3621	get_identifier (PREFIX("system_clock_8")),
3622	void_type_node, nargs: 3, gfc_pint8_type_node, gfc_pint8_type_node,
3623	gfc_pint8_type_node);
3624
3625	/* Power functions. */
3626	{
3627	tree ctype, rtype, itype, jtype;
3628	int rkind, ikind, jkind;
3629	#define NIKINDS 3
3630	#define NRKINDS 4
3631	static int ikinds[NIKINDS] = {4, 8, 16};
3632	static int rkinds[NRKINDS] = {4, 8, 10, 16};
3633	char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
3634
3635	for (ikind=0; ikind < NIKINDS; ikind++)
3636	{
3637	itype = gfc_get_int_type (ikinds[ikind]);
3638
3639	for (jkind=0; jkind < NIKINDS; jkind++)
3640	{
3641	jtype = gfc_get_int_type (ikinds[jkind]);
3642	if (itype && jtype)
3643	{
3644	sprintf (s: name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
3645	ikinds[jkind]);
3646	gfor_fndecl_math_powi[jkind][ikind].integer =
3647	gfc_build_library_function_decl (get_identifier (name),
3648	rettype: jtype, nargs: 2, jtype, itype);
3649	TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
3650	TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
3651	}
3652	}
3653
3654	for (rkind = 0; rkind < NRKINDS; rkind ++)
3655	{
3656	rtype = gfc_get_real_type (rkinds[rkind]);
3657	if (rtype && itype)
3658	{
3659	sprintf (s: name, PREFIX("pow_r%d_i%d"),
3660	gfc_type_abi_kind (BT_REAL, rkinds[rkind]),
3661	ikinds[ikind]);
3662	gfor_fndecl_math_powi[rkind][ikind].real =
3663	gfc_build_library_function_decl (get_identifier (name),
3664	rettype: rtype, nargs: 2, rtype, itype);
3665	TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
3666	TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
3667	}
3668
3669	ctype = gfc_get_complex_type (rkinds[rkind]);
3670	if (ctype && itype)
3671	{
3672	sprintf (s: name, PREFIX("pow_c%d_i%d"),
3673	gfc_type_abi_kind (BT_REAL, rkinds[rkind]),
3674	ikinds[ikind]);
3675	gfor_fndecl_math_powi[rkind][ikind].cmplx =
3676	gfc_build_library_function_decl (get_identifier (name),
3677	rettype: ctype, nargs: 2,ctype, itype);
3678	TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
3679	TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
3680	}
3681	}
3682	}
3683	#undef NIKINDS
3684	#undef NRKINDS
3685	}
3686
3687	gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl (
3688	get_identifier (PREFIX("ishftc4")),
3689	rettype: gfc_int4_type_node, nargs: 3, gfc_int4_type_node, gfc_int4_type_node,
3690	gfc_int4_type_node);
3691	TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
3692	TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
3693
3694	gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
3695	get_identifier (PREFIX("ishftc8")),
3696	rettype: gfc_int8_type_node, nargs: 3, gfc_int8_type_node, gfc_int4_type_node,
3697	gfc_int4_type_node);
3698	TREE_READONLY (gfor_fndecl_math_ishftc8) = 1;
3699	TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1;
3700
3701	if (gfc_int16_type_node)
3702	{
3703	gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl (
3704	get_identifier (PREFIX("ishftc16")),
3705	rettype: gfc_int16_type_node, nargs: 3, gfc_int16_type_node, gfc_int4_type_node,
3706	gfc_int4_type_node);
3707	TREE_READONLY (gfor_fndecl_math_ishftc16) = 1;
3708	TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1;
3709	}
3710
3711	/* BLAS functions. */
3712	{
3713	tree pint = build_pointer_type (integer_type_node);
3714	tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
3715	tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
3716	tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
3717	tree pz = build_pointer_type
3718	(gfc_get_complex_type (gfc_default_double_kind));
3719
3720	gfor_fndecl_sgemm = gfc_build_library_function_decl
3721	(get_identifier
3722	(flag_underscoring ? "sgemm_" : "sgemm"),
3723	void_type_node, nargs: 15, pchar_type_node,
3724	pchar_type_node, pint, pint, pint, ps, ps, pint,
3725	ps, pint, ps, ps, pint, integer_type_node,
3726	integer_type_node);
3727	gfor_fndecl_dgemm = gfc_build_library_function_decl
3728	(get_identifier
3729	(flag_underscoring ? "dgemm_" : "dgemm"),
3730	void_type_node, nargs: 15, pchar_type_node,
3731	pchar_type_node, pint, pint, pint, pd, pd, pint,
3732	pd, pint, pd, pd, pint, integer_type_node,
3733	integer_type_node);
3734	gfor_fndecl_cgemm = gfc_build_library_function_decl
3735	(get_identifier
3736	(flag_underscoring ? "cgemm_" : "cgemm"),
3737	void_type_node, nargs: 15, pchar_type_node,
3738	pchar_type_node, pint, pint, pint, pc, pc, pint,
3739	pc, pint, pc, pc, pint, integer_type_node,
3740	integer_type_node);
3741	gfor_fndecl_zgemm = gfc_build_library_function_decl
3742	(get_identifier
3743	(flag_underscoring ? "zgemm_" : "zgemm"),
3744	void_type_node, nargs: 15, pchar_type_node,
3745	pchar_type_node, pint, pint, pint, pz, pz, pint,
3746	pz, pint, pz, pz, pint, integer_type_node,
3747	integer_type_node);
3748	}
3749
3750	/* Other functions. */
3751	gfor_fndecl_iargc = gfc_build_library_function_decl (
3752	get_identifier (PREFIX ("iargc")), rettype: gfc_int4_type_node, nargs: 0);
3753	TREE_NOTHROW (gfor_fndecl_iargc) = 1;
3754
3755	gfor_fndecl_kill_sub = gfc_build_library_function_decl (
3756	get_identifier (PREFIX ("kill_sub")), void_type_node,
3757	nargs: 3, gfc_int4_type_node, gfc_int4_type_node, gfc_pint4_type_node);
3758
3759	gfor_fndecl_kill = gfc_build_library_function_decl (
3760	get_identifier (PREFIX ("kill")), rettype: gfc_int4_type_node,
3761	nargs: 2, gfc_int4_type_node, gfc_int4_type_node);
3762
3763	gfor_fndecl_is_contiguous0 = gfc_build_library_function_decl_with_spec (
3764	get_identifier (PREFIX("is_contiguous0")), spec: ". R ",
3765	rettype: gfc_int4_type_node, nargs: 1, pvoid_type_node);
3766	DECL_PURE_P (gfor_fndecl_is_contiguous0) = 1;
3767	TREE_NOTHROW (gfor_fndecl_is_contiguous0) = 1;
3768	}
3769
3770
3771	/* Make prototypes for runtime library functions. */
3772
3773	void
3774	gfc_build_builtin_function_decls (void)
3775	{
3776	tree gfc_int8_type_node = gfc_get_int_type (8);
3777
3778	gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
3779	get_identifier (PREFIX("stop_numeric")),
3780	void_type_node, nargs: 2, integer_type_node, boolean_type_node);
3781	/* STOP doesn't return. */
3782	TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
3783
3784	gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
3785	get_identifier (PREFIX("stop_string")), spec: ". R . . ",
3786	void_type_node, nargs: 3, pchar_type_node, size_type_node,
3787	boolean_type_node);
3788	/* STOP doesn't return. */
3789	TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
3790
3791	gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl (
3792	get_identifier (PREFIX("error_stop_numeric")),
3793	void_type_node, nargs: 2, integer_type_node, boolean_type_node);
3794	/* ERROR STOP doesn't return. */
3795	TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
3796
3797	gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec (
3798	get_identifier (PREFIX("error_stop_string")), spec: ". R . . ",
3799	void_type_node, nargs: 3, pchar_type_node, size_type_node,
3800	boolean_type_node);
3801	/* ERROR STOP doesn't return. */
3802	TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
3803
3804	gfor_fndecl_pause_numeric = gfc_build_library_function_decl (
3805	get_identifier (PREFIX("pause_numeric")),
3806	void_type_node, nargs: 1, gfc_int8_type_node);
3807
3808	gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec (
3809	get_identifier (PREFIX("pause_string")), spec: ". R . ",
3810	void_type_node, nargs: 2, pchar_type_node, size_type_node);
3811
3812	gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec (
3813	get_identifier (PREFIX("runtime_error")), spec: ". R ",
3814	void_type_node, nargs: -1, pchar_type_node);
3815	/* The runtime_error function does not return. */
3816	TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
3817
3818	gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec (
3819	get_identifier (PREFIX("runtime_error_at")), spec: ". R R ",
3820	void_type_node, nargs: -2, pchar_type_node, pchar_type_node);
3821	/* The runtime_error_at function does not return. */
3822	TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
3823
3824	gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
3825	get_identifier (PREFIX("runtime_warning_at")), spec: ". R R ",
3826	void_type_node, nargs: -2, pchar_type_node, pchar_type_node);
3827
3828	gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec (
3829	get_identifier (PREFIX("generate_error")), spec: ". W . R ",
3830	void_type_node, nargs: 3, pvoid_type_node, integer_type_node,
3831	pchar_type_node);
3832
3833	gfor_fndecl_os_error_at = gfc_build_library_function_decl_with_spec (
3834	get_identifier (PREFIX("os_error_at")), spec: ". R R ",
3835	void_type_node, nargs: -2, pchar_type_node, pchar_type_node);
3836	/* The os_error_at function does not return. */
3837	TREE_THIS_VOLATILE (gfor_fndecl_os_error_at) = 1;
3838
3839	gfor_fndecl_set_args = gfc_build_library_function_decl (
3840	get_identifier (PREFIX("set_args")),
3841	void_type_node, nargs: 2, integer_type_node,
3842	build_pointer_type (pchar_type_node));
3843
3844	gfor_fndecl_set_fpe = gfc_build_library_function_decl (
3845	get_identifier (PREFIX("set_fpe")),
3846	void_type_node, nargs: 1, integer_type_node);
3847
3848	gfor_fndecl_ieee_procedure_entry = gfc_build_library_function_decl (
3849	get_identifier (PREFIX("ieee_procedure_entry")),
3850	void_type_node, nargs: 1, pvoid_type_node);
3851
3852	gfor_fndecl_ieee_procedure_exit = gfc_build_library_function_decl (
3853	get_identifier (PREFIX("ieee_procedure_exit")),
3854	void_type_node, nargs: 1, pvoid_type_node);
3855
3856	/* Keep the array dimension in sync with the call, later in this file. */
3857	gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
3858	get_identifier (PREFIX("set_options")), spec: ". . R ",
3859	void_type_node, nargs: 2, integer_type_node,
3860	build_pointer_type (integer_type_node));
3861
3862	gfor_fndecl_set_convert = gfc_build_library_function_decl (
3863	get_identifier (PREFIX("set_convert")),
3864	void_type_node, nargs: 1, integer_type_node);
3865
3866	gfor_fndecl_set_record_marker = gfc_build_library_function_decl (
3867	get_identifier (PREFIX("set_record_marker")),
3868	void_type_node, nargs: 1, integer_type_node);
3869
3870	gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl (
3871	get_identifier (PREFIX("set_max_subrecord_length")),
3872	void_type_node, nargs: 1, integer_type_node);
3873
3874	gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
3875	get_identifier (PREFIX("internal_pack")), spec: ". r ",
3876	rettype: pvoid_type_node, nargs: 1, pvoid_type_node);
3877
3878	gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
3879	get_identifier (PREFIX("internal_unpack")), spec: ". w R ",
3880	void_type_node, nargs: 2, pvoid_type_node, pvoid_type_node);
3881
3882	gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
3883	get_identifier (PREFIX("associated")), spec: ". R R ",
3884	integer_type_node, nargs: 2, ppvoid_type_node, ppvoid_type_node);
3885	DECL_PURE_P (gfor_fndecl_associated) = 1;
3886	TREE_NOTHROW (gfor_fndecl_associated) = 1;
3887
3888	/* Coarray library calls. */
3889	if (flag_coarray == GFC_FCOARRAY_LIB)
3890	{
3891	tree pint_type, pppchar_type;
3892
3893	pint_type = build_pointer_type (integer_type_node);
3894	pppchar_type
3895	= build_pointer_type (build_pointer_type (pchar_type_node));
3896
3897	gfor_fndecl_caf_init = gfc_build_library_function_decl_with_spec (
3898	get_identifier (PREFIX("caf_init")), spec: ". W W ",
3899	void_type_node, nargs: 2, pint_type, pppchar_type);
3900
3901	gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
3902	get_identifier (PREFIX("caf_finalize")), void_type_node, nargs: 0);
3903
3904	gfor_fndecl_caf_this_image = gfc_build_library_function_decl (
3905	get_identifier (PREFIX("caf_this_image")), integer_type_node,
3906	nargs: 1, integer_type_node);
3907
3908	gfor_fndecl_caf_num_images = gfc_build_library_function_decl (
3909	get_identifier (PREFIX("caf_num_images")), integer_type_node,
3910	nargs: 2, integer_type_node, integer_type_node);
3911
3912	gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec (
3913	get_identifier (PREFIX("caf_register")), spec: ". . . W w w w . ",
3914	void_type_node, nargs: 7,
3915	size_type_node, integer_type_node, ppvoid_type_node, pvoid_type_node,
3916	pint_type, pchar_type_node, size_type_node);
3917
3918	gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec (
3919	get_identifier (PREFIX("caf_deregister")), spec: ". W . w w . ",
3920	void_type_node, nargs: 5,
3921	ppvoid_type_node, integer_type_node, pint_type, pchar_type_node,
3922	size_type_node);
3923
3924	gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec (
3925	get_identifier (PREFIX("caf_get")), spec: ". r . . r r w . . . w ",
3926	void_type_node, nargs: 10,
3927	pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
3928	pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
3929	boolean_type_node, pint_type);
3930
3931	gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec (
3932	get_identifier (PREFIX("caf_send")), spec: ". r . . w r r . . . w ",
3933	void_type_node, nargs: 11,
3934	pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
3935	pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
3936	boolean_type_node, pint_type, pvoid_type_node);
3937
3938	gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec (
3939	get_identifier (PREFIX("caf_sendget")), spec: ". r . . w r r . . r r . . . w ",
3940	void_type_node, nargs: 14, pvoid_type_node, size_type_node, integer_type_node,
3941	pvoid_type_node, pvoid_type_node, pvoid_type_node, size_type_node,
3942	integer_type_node, pvoid_type_node, pvoid_type_node, integer_type_node,
3943	integer_type_node, boolean_type_node, integer_type_node);
3944
3945	gfor_fndecl_caf_get_by_ref = gfc_build_library_function_decl_with_spec (
3946	get_identifier (PREFIX("caf_get_by_ref")), spec: ". r . w r . . . . w . ",
3947	void_type_node,
3948	nargs: 10, pvoid_type_node, integer_type_node, pvoid_type_node,
3949	pvoid_type_node, integer_type_node, integer_type_node,
3950	boolean_type_node, boolean_type_node, pint_type, integer_type_node);
3951
3952	gfor_fndecl_caf_send_by_ref = gfc_build_library_function_decl_with_spec (
3953	get_identifier (PREFIX("caf_send_by_ref")), spec: ". r . r r . . . . w . ",
3954	void_type_node, nargs: 10, pvoid_type_node, integer_type_node, pvoid_type_node,
3955	pvoid_type_node, integer_type_node, integer_type_node,
3956	boolean_type_node, boolean_type_node, pint_type, integer_type_node);
3957
3958	gfor_fndecl_caf_sendget_by_ref
3959	= gfc_build_library_function_decl_with_spec (
3960	get_identifier (PREFIX("caf_sendget_by_ref")),
3961	spec: ". r . r r . r . . . w w . . ",
3962	void_type_node, nargs: 13, pvoid_type_node, integer_type_node,
3963	pvoid_type_node, pvoid_type_node, integer_type_node,
3964	pvoid_type_node, integer_type_node, integer_type_node,
3965	boolean_type_node, pint_type, pint_type, integer_type_node,
3966	integer_type_node);
3967
3968	gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
3969	get_identifier (PREFIX("caf_sync_all")), spec: ". w w . ", void_type_node,
3970	nargs: 3, pint_type, pchar_type_node, size_type_node);
3971
3972	gfor_fndecl_caf_sync_memory = gfc_build_library_function_decl_with_spec (
3973	get_identifier (PREFIX("caf_sync_memory")), spec: ". w w . ", void_type_node,
3974	nargs: 3, pint_type, pchar_type_node, size_type_node);
3975
3976	gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec (
3977	get_identifier (PREFIX("caf_sync_images")), spec: ". . r w w . ", void_type_node,
3978	nargs: 5, integer_type_node, pint_type, pint_type,
3979	pchar_type_node, size_type_node);
3980
3981	gfor_fndecl_caf_error_stop = gfc_build_library_function_decl (
3982	get_identifier (PREFIX("caf_error_stop")),
3983	void_type_node, nargs: 1, integer_type_node);
3984	/* CAF's ERROR STOP doesn't return. */
3985	TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1;
3986
3987	gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec (
3988	get_identifier (PREFIX("caf_error_stop_str")), spec: ". r . ",
3989	void_type_node, nargs: 2, pchar_type_node, size_type_node);
3990	/* CAF's ERROR STOP doesn't return. */
3991	TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
3992
3993	gfor_fndecl_caf_stop_numeric = gfc_build_library_function_decl (
3994	get_identifier (PREFIX("caf_stop_numeric")),
3995	void_type_node, nargs: 1, integer_type_node);
3996	/* CAF's STOP doesn't return. */
3997	TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_numeric) = 1;
3998
3999	gfor_fndecl_caf_stop_str = gfc_build_library_function_decl_with_spec (
4000	get_identifier (PREFIX("caf_stop_str")), spec: ". r . ",
4001	void_type_node, nargs: 2, pchar_type_node, size_type_node);
4002	/* CAF's STOP doesn't return. */
4003	TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_str) = 1;
4004
4005	gfor_fndecl_caf_atomic_def = gfc_build_library_function_decl_with_spec (
4006	get_identifier (PREFIX("caf_atomic_define")), spec: ". r . . w w . . ",
4007	void_type_node, nargs: 7, pvoid_type_node, size_type_node, integer_type_node,
4008	pvoid_type_node, pint_type, integer_type_node, integer_type_node);
4009
4010	gfor_fndecl_caf_atomic_ref = gfc_build_library_function_decl_with_spec (
4011	get_identifier (PREFIX("caf_atomic_ref")), spec: ". r . . w w . . ",
4012	void_type_node, nargs: 7, pvoid_type_node, size_type_node, integer_type_node,
4013	pvoid_type_node, pint_type, integer_type_node, integer_type_node);
4014
4015	gfor_fndecl_caf_atomic_cas = gfc_build_library_function_decl_with_spec (
4016	get_identifier (PREFIX("caf_atomic_cas")), spec: ". r . . w r r w . . ",
4017	void_type_node, nargs: 9, pvoid_type_node, size_type_node, integer_type_node,
4018	pvoid_type_node, pvoid_type_node, pvoid_type_node, pint_type,
4019	integer_type_node, integer_type_node);
4020
4021	gfor_fndecl_caf_atomic_op = gfc_build_library_function_decl_with_spec (
4022	get_identifier (PREFIX("caf_atomic_op")), spec: ". . r . . r w w . . ",
4023	void_type_node, nargs: 9, integer_type_node, pvoid_type_node, size_type_node,
4024	integer_type_node, pvoid_type_node, pvoid_type_node, pint_type,
4025	integer_type_node, integer_type_node);
4026
4027	gfor_fndecl_caf_lock = gfc_build_library_function_decl_with_spec (
4028	get_identifier (PREFIX("caf_lock")), spec: ". r . . w w w . ",
4029	void_type_node, nargs: 7, pvoid_type_node, size_type_node, integer_type_node,
4030	pint_type, pint_type, pchar_type_node, size_type_node);
4031
4032	gfor_fndecl_caf_unlock = gfc_build_library_function_decl_with_spec (
4033	get_identifier (PREFIX("caf_unlock")), spec: ". r . . w w . ",
4034	void_type_node, nargs: 6, pvoid_type_node, size_type_node, integer_type_node,
4035	pint_type, pchar_type_node, size_type_node);
4036
4037	gfor_fndecl_caf_event_post = gfc_build_library_function_decl_with_spec (
4038	get_identifier (PREFIX("caf_event_post")), spec: ". r . . w w . ",
4039	void_type_node, nargs: 6, pvoid_type_node, size_type_node, integer_type_node,
4040	pint_type, pchar_type_node, size_type_node);
4041
4042	gfor_fndecl_caf_event_wait = gfc_build_library_function_decl_with_spec (
4043	get_identifier (PREFIX("caf_event_wait")), spec: ". r . . w w . ",
4044	void_type_node, nargs: 6, pvoid_type_node, size_type_node, integer_type_node,
4045	pint_type, pchar_type_node, size_type_node);
4046
4047	gfor_fndecl_caf_event_query = gfc_build_library_function_decl_with_spec (
4048	get_identifier (PREFIX("caf_event_query")), spec: ". r . . w w ",
4049	void_type_node, nargs: 5, pvoid_type_node, size_type_node, integer_type_node,
4050	pint_type, pint_type);
4051
4052	gfor_fndecl_caf_fail_image = gfc_build_library_function_decl (
4053	get_identifier (PREFIX("caf_fail_image")), void_type_node, nargs: 0);
4054	/* CAF's FAIL doesn't return. */
4055	TREE_THIS_VOLATILE (gfor_fndecl_caf_fail_image) = 1;
4056
4057	gfor_fndecl_caf_failed_images
4058	= gfc_build_library_function_decl_with_spec (
4059	get_identifier (PREFIX("caf_failed_images")), spec: ". w . r ",
4060	void_type_node, nargs: 3, pvoid_type_node, ppvoid_type_node,
4061	integer_type_node);
4062
4063	gfor_fndecl_caf_form_team
4064	= gfc_build_library_function_decl_with_spec (
4065	get_identifier (PREFIX("caf_form_team")), spec: ". . W . ",
4066	void_type_node, nargs: 3, integer_type_node, ppvoid_type_node,
4067	integer_type_node);
4068
4069	gfor_fndecl_caf_change_team
4070	= gfc_build_library_function_decl_with_spec (
4071	get_identifier (PREFIX("caf_change_team")), spec: ". w . ",
4072	void_type_node, nargs: 2, ppvoid_type_node,
4073	integer_type_node);
4074
4075	gfor_fndecl_caf_end_team
4076	= gfc_build_library_function_decl (
4077	get_identifier (PREFIX("caf_end_team")), void_type_node, nargs: 0);
4078
4079	gfor_fndecl_caf_get_team
4080	= gfc_build_library_function_decl (
4081	get_identifier (PREFIX("caf_get_team")),
4082	void_type_node, nargs: 1, integer_type_node);
4083
4084	gfor_fndecl_caf_sync_team
4085	= gfc_build_library_function_decl_with_spec (
4086	get_identifier (PREFIX("caf_sync_team")), spec: ". r . ",
4087	void_type_node, nargs: 2, ppvoid_type_node,
4088	integer_type_node);
4089
4090	gfor_fndecl_caf_team_number
4091	= gfc_build_library_function_decl_with_spec (
4092	get_identifier (PREFIX("caf_team_number")), spec: ". r ",
4093	integer_type_node, nargs: 1, integer_type_node);
4094
4095	gfor_fndecl_caf_image_status
4096	= gfc_build_library_function_decl_with_spec (
4097	get_identifier (PREFIX("caf_image_status")), spec: ". . r ",
4098	integer_type_node, nargs: 2, integer_type_node, ppvoid_type_node);
4099
4100	gfor_fndecl_caf_stopped_images
4101	= gfc_build_library_function_decl_with_spec (
4102	get_identifier (PREFIX("caf_stopped_images")), spec: ". w r r ",
4103	void_type_node, nargs: 3, pvoid_type_node, ppvoid_type_node,
4104	integer_type_node);
4105
4106	gfor_fndecl_co_broadcast = gfc_build_library_function_decl_with_spec (
4107	get_identifier (PREFIX("caf_co_broadcast")), spec: ". w . w w . ",
4108	void_type_node, nargs: 5, pvoid_type_node, integer_type_node,
4109	pint_type, pchar_type_node, size_type_node);
4110
4111	gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec (
4112	get_identifier (PREFIX("caf_co_max")), spec: ". w . w w . . ",
4113	void_type_node, nargs: 6, pvoid_type_node, integer_type_node,
4114	pint_type, pchar_type_node, integer_type_node, size_type_node);
4115
4116	gfor_fndecl_co_min = gfc_build_library_function_decl_with_spec (
4117	get_identifier (PREFIX("caf_co_min")), spec: ". w . w w . . ",
4118	void_type_node, nargs: 6, pvoid_type_node, integer_type_node,
4119	pint_type, pchar_type_node, integer_type_node, size_type_node);
4120
4121	gfor_fndecl_co_reduce = gfc_build_library_function_decl_with_spec (
4122	get_identifier (PREFIX("caf_co_reduce")), spec: ". w r . . w w . . ",
4123	void_type_node, nargs: 8, pvoid_type_node,
4124	build_pointer_type (build_varargs_function_type_list (void_type_node,
4125	NULL_TREE)),
4126	integer_type_node, integer_type_node, pint_type, pchar_type_node,
4127	integer_type_node, size_type_node);
4128
4129	gfor_fndecl_co_sum = gfc_build_library_function_decl_with_spec (
4130	get_identifier (PREFIX("caf_co_sum")), spec: ". w . w w . ",
4131	void_type_node, nargs: 5, pvoid_type_node, integer_type_node,
4132	pint_type, pchar_type_node, size_type_node);
4133
4134	gfor_fndecl_caf_is_present = gfc_build_library_function_decl_with_spec (
4135	get_identifier (PREFIX("caf_is_present")), spec: ". r . r ",
4136	integer_type_node, nargs: 3, pvoid_type_node, integer_type_node,
4137	pvoid_type_node);
4138
4139	gfor_fndecl_caf_random_init = gfc_build_library_function_decl (
4140	get_identifier (PREFIX("caf_random_init")),
4141	void_type_node, nargs: 2, logical_type_node, logical_type_node);
4142	}
4143
4144	gfc_build_intrinsic_function_decls ();
4145	gfc_build_intrinsic_lib_fndecls ();
4146	gfc_build_io_library_fndecls ();
4147	}
4148
4149
4150	/* Evaluate the length of dummy character variables. */
4151
4152	static void
4153	gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
4154	gfc_wrapped_block *block)
4155	{
4156	stmtblock_t init;
4157
4158	gfc_finish_decl (decl: cl->backend_decl);
4159
4160	gfc_start_block (&init);
4161
4162	/* Evaluate the string length expression. */
4163	gfc_conv_string_length (cl, NULL, &init);
4164
4165	gfc_trans_vla_type_sizes (sym, &init);
4166
4167	gfc_add_init_cleanup (block, init: gfc_finish_block (&init), NULL_TREE);
4168	}
4169
4170
4171	/* Allocate and cleanup an automatic character variable. */
4172
4173	static void
4174	gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
4175	{
4176	stmtblock_t init;
4177	tree decl;
4178	tree tmp;
4179
4180	gcc_assert (sym->backend_decl);
4181	gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
4182
4183	gfc_init_block (&init);
4184
4185	/* Evaluate the string length expression. */
4186	gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4187
4188	gfc_trans_vla_type_sizes (sym, &init);
4189
4190	decl = sym->backend_decl;
4191
4192	/* Emit a DECL_EXPR for this variable, which will cause the
4193	gimplifier to allocate storage, and all that good stuff. */
4194	tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
4195	gfc_add_expr_to_block (&init, tmp);
4196
4197	gfc_add_init_cleanup (block, init: gfc_finish_block (&init), NULL_TREE);
4198	}
4199
4200	/* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
4201
4202	static void
4203	gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
4204	{
4205	stmtblock_t init;
4206
4207	gcc_assert (sym->backend_decl);
4208	gfc_start_block (&init);
4209
4210	/* Set the initial value to length. See the comments in
4211	function gfc_add_assign_aux_vars in this file. */
4212	gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
4213	build_int_cst (gfc_charlen_type_node, -2));
4214
4215	gfc_add_init_cleanup (block, init: gfc_finish_block (&init), NULL_TREE);
4216	}
4217
4218	static void
4219	gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
4220	{
4221	tree t = *tp, var, val;
4222
4223	if (t == NULL || t == error_mark_node)
4224	return;
4225	if (TREE_CONSTANT (t) || DECL_P (t))
4226	return;
4227
4228	if (TREE_CODE (t) == SAVE_EXPR)
4229	{
4230	if (SAVE_EXPR_RESOLVED_P (t))
4231	{
4232	*tp = TREE_OPERAND (t, 0);
4233	return;
4234	}
4235	val = TREE_OPERAND (t, 0);
4236	}
4237	else
4238	val = t;
4239
4240	var = gfc_create_var_np (TREE_TYPE (t), NULL);
4241	gfc_add_decl_to_function (decl: var);
4242	gfc_add_modify (body, var, unshare_expr (val));
4243	if (TREE_CODE (t) == SAVE_EXPR)
4244	TREE_OPERAND (t, 0) = var;
4245	*tp = var;
4246	}
4247
4248	static void
4249	gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
4250	{
4251	tree t;
4252
4253	if (type == NULL || type == error_mark_node)
4254	return;
4255
4256	type = TYPE_MAIN_VARIANT (type);
4257
4258	if (TREE_CODE (type) == INTEGER_TYPE)
4259	{
4260	gfc_trans_vla_one_sizepos (tp: &TYPE_MIN_VALUE (type), body);
4261	gfc_trans_vla_one_sizepos (tp: &TYPE_MAX_VALUE (type), body);
4262
4263	for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
4264	{
4265	TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
4266	TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
4267	}
4268	}
4269	else if (TREE_CODE (type) == ARRAY_TYPE)
4270	{
4271	gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
4272	gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
4273	gfc_trans_vla_one_sizepos (tp: &TYPE_SIZE (type), body);
4274	gfc_trans_vla_one_sizepos (tp: &TYPE_SIZE_UNIT (type), body);
4275
4276	for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
4277	{
4278	TYPE_SIZE (t) = TYPE_SIZE (type);
4279	TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
4280	}
4281	}
4282	}
4283
4284	/* Make sure all type sizes and array domains are either constant,
4285	or variable or parameter decls. This is a simplified variant
4286	of gimplify_type_sizes, but we can't use it here, as none of the
4287	variables in the expressions have been gimplified yet.
4288	As type sizes and domains for various variable length arrays
4289	contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
4290	time, without this routine gimplify_type_sizes in the middle-end
4291	could result in the type sizes being gimplified earlier than where
4292	those variables are initialized. */
4293
4294	void
4295	gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
4296	{
4297	tree type = TREE_TYPE (sym->backend_decl);
4298
4299	if (TREE_CODE (type) == FUNCTION_TYPE
4300	&& (sym->attr.function || sym->attr.result || sym->attr.entry))
4301	{
4302	if (! current_fake_result_decl)
4303	return;
4304
4305	type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
4306	}
4307
4308	while (POINTER_TYPE_P (type))
4309	type = TREE_TYPE (type);
4310
4311	if (GFC_DESCRIPTOR_TYPE_P (type))
4312	{
4313	tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
4314
4315	while (POINTER_TYPE_P (etype))
4316	etype = TREE_TYPE (etype);
4317
4318	gfc_trans_vla_type_sizes_1 (type: etype, body);
4319	}
4320
4321	gfc_trans_vla_type_sizes_1 (type, body);
4322	}
4323
4324
4325	/* Initialize a derived type by building an lvalue from the symbol
4326	and using trans_assignment to do the work. Set dealloc to false
4327	if no deallocation prior the assignment is needed. */
4328	void
4329	gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
4330	{
4331	gfc_expr *e;
4332	tree tmp;
4333	tree present;
4334
4335	gcc_assert (block);
4336
4337	/* Initialization of PDTs is done elsewhere. */
4338	if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type)
4339	return;
4340
4341	gcc_assert (!sym->attr.allocatable);
4342	gfc_set_sym_referenced (sym);
4343	e = gfc_lval_expr_from_sym (sym);
4344	tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
4345	if (sym->attr.dummy && (sym->attr.optional
4346	|| sym->ns->proc_name->attr.entry_master))
4347	{
4348	present = gfc_conv_expr_present (sym);
4349	tmp = build3_loc (loc: input_location, code: COND_EXPR, TREE_TYPE (tmp), arg0: present,
4350	arg1: tmp, arg2: build_empty_stmt (input_location));
4351	}
4352	gfc_add_expr_to_block (block, tmp);
4353	gfc_free_expr (e);
4354	}
4355
4356
4357	/* Initialize INTENT(OUT) derived type dummies. As well as giving
4358	them their default initializer, if they have allocatable
4359	components, they have their allocatable components deallocated. */
4360
4361	static void
4362	init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
4363	{
4364	stmtblock_t init;
4365	gfc_formal_arglist *f;
4366	tree tmp;
4367	tree present;
4368	gfc_symbol *s;
4369	bool dealloc_with_value = false;
4370
4371	gfc_init_block (&init);
4372	for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
4373	if (f->sym && f->sym->attr.intent == INTENT_OUT
4374	&& !f->sym->attr.pointer
4375	&& f->sym->ts.type == BT_DERIVED)
4376	{
4377	s = f->sym;
4378	tmp = NULL_TREE;
4379
4380	/* Note: Allocatables are excluded as they are already handled
4381	by the caller. */
4382	if (!f->sym->attr.allocatable
4383	&& gfc_is_finalizable (s->ts.u.derived, NULL))
4384	{
4385	stmtblock_t block;
4386	gfc_expr *e;
4387
4388	gfc_init_block (&block);
4389	s->attr.referenced = 1;
4390	e = gfc_lval_expr_from_sym (s);
4391	gfc_add_finalizer_call (&block, e);
4392	gfc_free_expr (e);
4393	tmp = gfc_finish_block (&block);
4394	}
4395
4396	/* Note: Allocatables are excluded as they are already handled
4397	by the caller. */
4398	if (tmp == NULL_TREE && !s->attr.allocatable
4399	&& s->ts.u.derived->attr.alloc_comp)
4400	{
4401	tmp = gfc_deallocate_alloc_comp (s->ts.u.derived,
4402	s->backend_decl,
4403	s->as ? s->as->rank : 0);
4404	dealloc_with_value = s->value;
4405	}
4406
4407	if (tmp != NULL_TREE && (s->attr.optional
4408	|| s->ns->proc_name->attr.entry_master))
4409	{
4410	present = gfc_conv_expr_present (s);
4411	tmp = build3_loc (loc: input_location, code: COND_EXPR, TREE_TYPE (tmp),
4412	arg0: present, arg1: tmp, arg2: build_empty_stmt (input_location));
4413	}
4414
4415	if (tmp != NULL_TREE && !dealloc_with_value)
4416	gfc_add_expr_to_block (&init, tmp);
4417	else if (s->value && !s->attr.allocatable)
4418	{
4419	gfc_add_expr_to_block (&init, tmp);
4420	gfc_init_default_dt (sym: s, block: &init, dealloc: false);
4421	dealloc_with_value = false;
4422	}
4423	}
4424	else if (f->sym && f->sym->attr.intent == INTENT_OUT
4425	&& f->sym->ts.type == BT_CLASS
4426	&& !CLASS_DATA (f->sym)->attr.class_pointer
4427	&& !CLASS_DATA (f->sym)->attr.allocatable)
4428	{
4429	stmtblock_t block;
4430	gfc_expr *e;
4431
4432	gfc_init_block (&block);
4433	f->sym->attr.referenced = 1;
4434	e = gfc_lval_expr_from_sym (f->sym);
4435	gfc_add_finalizer_call (&block, e);
4436	gfc_free_expr (e);
4437	tmp = gfc_finish_block (&block);
4438
4439	if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
4440	{
4441	present = gfc_conv_expr_present (f->sym);
4442	tmp = build3_loc (loc: input_location, code: COND_EXPR, TREE_TYPE (tmp),
4443	arg0: present, arg1: tmp,
4444	arg2: build_empty_stmt (input_location));
4445	}
4446	gfc_add_expr_to_block (&init, tmp);
4447	}
4448	gfc_add_init_cleanup (block, init: gfc_finish_block (&init), NULL_TREE);
4449	}
4450
4451
4452	/* Helper function to manage deferred string lengths. */
4453
4454	static tree
4455	gfc_null_and_pass_deferred_len (gfc_symbol *sym, stmtblock_t *init,
4456	locus *loc)
4457	{
4458	tree tmp;
4459
4460	/* Character length passed by reference. */
4461	tmp = sym->ts.u.cl->passed_length;
4462	tmp = build_fold_indirect_ref_loc (input_location, tmp);
4463	tmp = fold_convert (gfc_charlen_type_node, tmp);
4464
4465	if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
4466	/* Zero the string length when entering the scope. */
4467	gfc_add_modify (init, sym->ts.u.cl->backend_decl,
4468	build_int_cst (gfc_charlen_type_node, 0));
4469	else
4470	{
4471	tree tmp2;
4472
4473	tmp2 = fold_build2_loc (input_location, MODIFY_EXPR,
4474	gfc_charlen_type_node,
4475	sym->ts.u.cl->backend_decl, tmp);
4476	if (sym->attr.optional)
4477	{
4478	tree present = gfc_conv_expr_present (sym);
4479	tmp2 = build3_loc (loc: input_location, code: COND_EXPR,
4480	void_type_node, arg0: present, arg1: tmp2,
4481	arg2: build_empty_stmt (input_location));
4482	}
4483	gfc_add_expr_to_block (init, tmp2);
4484	}
4485
4486	gfc_restore_backend_locus (loc);
4487
4488	/* Pass the final character length back. */
4489	if (sym->attr.intent != INTENT_IN)
4490	{
4491	tmp = fold_build2_loc (input_location, MODIFY_EXPR,
4492	gfc_charlen_type_node, tmp,
4493	sym->ts.u.cl->backend_decl);
4494	if (sym->attr.optional)
4495	{
4496	tree present = gfc_conv_expr_present (sym);
4497	tmp = build3_loc (loc: input_location, code: COND_EXPR,
4498	void_type_node, arg0: present, arg1: tmp,
4499	arg2: build_empty_stmt (input_location));
4500	}
4501	}
4502	else
4503	tmp = NULL_TREE;
4504
4505	return tmp;
4506	}
4507
4508
4509	/* Get the result expression for a procedure. */
4510
4511	static tree
4512	get_proc_result (gfc_symbol* sym)
4513	{
4514	if (sym->attr.subroutine || sym == sym->result)
4515	{
4516	if (current_fake_result_decl != NULL)
4517	return TREE_VALUE (current_fake_result_decl);
4518
4519	return NULL_TREE;
4520	}
4521
4522	return sym->result->backend_decl;
4523	}
4524
4525
4526	/* Generate function entry and exit code, and add it to the function body.
4527	This includes:
4528	Allocation and initialization of array variables.
4529	Allocation of character string variables.
4530	Initialization and possibly repacking of dummy arrays.
4531	Initialization of ASSIGN statement auxiliary variable.
4532	Initialization of ASSOCIATE names.
4533	Automatic deallocation. */
4534
4535	void
4536	gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
4537	{
4538	locus loc;
4539	gfc_symbol *sym;
4540	gfc_formal_arglist *f;
4541	stmtblock_t tmpblock;
4542	bool seen_trans_deferred_array = false;
4543	bool is_pdt_type = false;
4544	tree tmp = NULL;
4545	gfc_expr *e;
4546	gfc_se se;
4547	stmtblock_t init;
4548
4549	/* Deal with implicit return variables. Explicit return variables will
4550	already have been added. */
4551	if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
4552	{
4553	if (!current_fake_result_decl)
4554	{
4555	gfc_entry_list *el = NULL;
4556	if (proc_sym->attr.entry_master)
4557	{
4558	for (el = proc_sym->ns->entries; el; el = el->next)
4559	if (el->sym != el->sym->result)
4560	break;
4561	}
4562	/* TODO: move to the appropriate place in resolve.cc. */
4563	if (warn_return_type > 0 && el == NULL)
4564	gfc_warning (opt: OPT_Wreturn_type,
4565	"Return value of function %qs at %L not set",
4566	proc_sym->name, &proc_sym->declared_at);
4567	}
4568	else if (proc_sym->as)
4569	{
4570	tree result = TREE_VALUE (current_fake_result_decl);
4571	gfc_save_backend_locus (&loc);
4572	gfc_set_backend_locus (&proc_sym->declared_at);
4573	gfc_trans_dummy_array_bias (proc_sym, result, block);
4574
4575	/* An automatic character length, pointer array result. */
4576	if (proc_sym->ts.type == BT_CHARACTER
4577	&& VAR_P (proc_sym->ts.u.cl->backend_decl))
4578	{
4579	tmp = NULL;
4580	if (proc_sym->ts.deferred)
4581	{
4582	gfc_start_block (&init);
4583	tmp = gfc_null_and_pass_deferred_len (sym: proc_sym, init: &init, loc: &loc);
4584	gfc_add_init_cleanup (block, init: gfc_finish_block (&init), cleanup: tmp);
4585	}
4586	else
4587	gfc_trans_dummy_character (sym: proc_sym, cl: proc_sym->ts.u.cl, block);
4588	}
4589	}
4590	else if (proc_sym->ts.type == BT_CHARACTER)
4591	{
4592	if (proc_sym->ts.deferred)
4593	{
4594	tmp = NULL;
4595	gfc_save_backend_locus (&loc);
4596	gfc_set_backend_locus (&proc_sym->declared_at);
4597	gfc_start_block (&init);
4598	/* Zero the string length on entry. */
4599	gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
4600	build_int_cst (gfc_charlen_type_node, 0));
4601	/* Null the pointer. */
4602	e = gfc_lval_expr_from_sym (proc_sym);
4603	gfc_init_se (&se, NULL);
4604	se.want_pointer = 1;
4605	gfc_conv_expr (se: &se, expr: e);
4606	gfc_free_expr (e);
4607	tmp = se.expr;
4608	gfc_add_modify (&init, tmp,
4609	fold_convert (TREE_TYPE (se.expr),
4610	null_pointer_node));
4611	gfc_restore_backend_locus (&loc);
4612
4613	/* Pass back the string length on exit. */
4614	tmp = proc_sym->ts.u.cl->backend_decl;
4615	if (TREE_CODE (tmp) != INDIRECT_REF
4616	&& proc_sym->ts.u.cl->passed_length)
4617	{
4618	tmp = proc_sym->ts.u.cl->passed_length;
4619	tmp = build_fold_indirect_ref_loc (input_location, tmp);
4620	tmp = fold_build2_loc (input_location, MODIFY_EXPR,
4621	TREE_TYPE (tmp), tmp,
4622	fold_convert
4623	(TREE_TYPE (tmp),
4624	proc_sym->ts.u.cl->backend_decl));
4625	}
4626	else
4627	tmp = NULL_TREE;
4628
4629	gfc_add_init_cleanup (block, init: gfc_finish_block (&init), cleanup: tmp);
4630	}
4631	else if (VAR_P (proc_sym->ts.u.cl->backend_decl))
4632	gfc_trans_dummy_character (sym: proc_sym, cl: proc_sym->ts.u.cl, block);
4633	}
4634	else
4635	gcc_assert (flag_f2c && proc_sym->ts.type == BT_COMPLEX);
4636	}
4637	else if (proc_sym == proc_sym->result && IS_CLASS_ARRAY (proc_sym))
4638	{
4639	/* Nullify explicit return class arrays on entry. */
4640	tree type;
4641	tmp = get_proc_result (sym: proc_sym);
4642	if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
4643	{
4644	gfc_start_block (&init);
4645	tmp = gfc_class_data_get (tmp);
4646	type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp));
4647	gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0));
4648	gfc_add_init_cleanup (block, init: gfc_finish_block (&init), NULL_TREE);
4649	}
4650	}
4651
4652
4653	/* Initialize the INTENT(OUT) derived type dummy arguments. This
4654	should be done here so that the offsets and lbounds of arrays
4655	are available. */
4656	gfc_save_backend_locus (&loc);
4657	gfc_set_backend_locus (&proc_sym->declared_at);
4658	init_intent_out_dt (proc_sym, block);
4659	gfc_restore_backend_locus (&loc);
4660
4661	/* For some reasons, internal procedures point to the parent's
4662	namespace. Top-level procedure and variables inside BLOCK are fine. */
4663	gfc_namespace *omp_ns = proc_sym->ns;
4664	if (proc_sym->ns->proc_name != proc_sym)
4665	for (omp_ns = proc_sym->ns->contained; omp_ns;
4666	omp_ns = omp_ns->sibling)
4667	if (omp_ns->proc_name == proc_sym)
4668	break;
4669
4670	/* Add 'omp allocate' attribute for gfc_trans_auto_array_allocation and
4671	unset attr.omp_allocate for 'omp allocate allocator(omp_default_mem_alloc),
4672	which has the normal codepath except for an invalid-use check in the ME.
4673	The main processing happens later in this function. */
4674	for (struct gfc_omp_namelist *n = omp_ns ? omp_ns->omp_allocate : NULL;
4675	n; n = n->next)
4676	if (!TREE_STATIC (n->sym->backend_decl))
4677	{
4678	/* Add empty entries - described and to be filled below. */
4679	tree tmp = build_tree_list (NULL_TREE, NULL_TREE);
4680	TREE_CHAIN (tmp) = build_tree_list (NULL_TREE, NULL_TREE);
4681	DECL_ATTRIBUTES (n->sym->backend_decl)
4682	= tree_cons (get_identifier ("omp allocate"), tmp,
4683	DECL_ATTRIBUTES (n->sym->backend_decl));
4684	if (n->u.align == NULL
4685	&& n->u2.allocator != NULL
4686	&& n->u2.allocator->expr_type == EXPR_CONSTANT
4687	&& mpz_cmp_si (n->u2.allocator->value.integer, 1) == 0)
4688	n->sym->attr.omp_allocate = 0;
4689	}
4690
4691	for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
4692	{
4693	bool alloc_comp_or_fini = (sym->ts.type == BT_DERIVED)
4694	&& (sym->ts.u.derived->attr.alloc_comp
4695	|| gfc_is_finalizable (sym->ts.u.derived,
4696	NULL));
4697	if (sym->assoc)
4698	continue;
4699
4700	/* Set the vptr of unlimited polymorphic pointer variables so that
4701	they do not cause segfaults in select type, when the selector
4702	is an intrinsic type. */
4703	if (sym->ts.type == BT_CLASS && UNLIMITED_POLY (sym)
4704	&& sym->attr.flavor == FL_VARIABLE && !sym->assoc
4705	&& !sym->attr.dummy && CLASS_DATA (sym)->attr.class_pointer)
4706	{
4707	gfc_symbol *vtab;
4708	gfc_init_block (&tmpblock);
4709	vtab = gfc_find_vtab (&sym->ts);
4710	if (!vtab->backend_decl)
4711	{
4712	if (!vtab->attr.referenced)
4713	gfc_set_sym_referenced (vtab);
4714	gfc_get_symbol_decl (sym: vtab);
4715	}
4716	tmp = gfc_class_vptr_get (sym->backend_decl);
4717	gfc_add_modify (&tmpblock, tmp,
4718	gfc_build_addr_expr (TREE_TYPE (tmp),
4719	vtab->backend_decl));
4720	gfc_add_init_cleanup (block, init: gfc_finish_block (&tmpblock), NULL);
4721	}
4722
4723	if (sym->ts.type == BT_DERIVED
4724	&& sym->ts.u.derived
4725	&& sym->ts.u.derived->attr.pdt_type)
4726	{
4727	is_pdt_type = true;
4728	gfc_init_block (&tmpblock);
4729	if (!(sym->attr.dummy
4730	|| sym->attr.pointer
4731	|| sym->attr.allocatable))
4732	{
4733	tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
4734	sym->backend_decl,
4735	sym->as ? sym->as->rank : 0,
4736	sym->param_list);
4737	gfc_add_expr_to_block (&tmpblock, tmp);
4738	if (!sym->attr.result)
4739	tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived,
4740	sym->backend_decl,
4741	sym->as ? sym->as->rank : 0);
4742	else
4743	tmp = NULL_TREE;
4744	gfc_add_init_cleanup (block, init: gfc_finish_block (&tmpblock), cleanup: tmp);
4745	}
4746	else if (sym->attr.dummy)
4747	{
4748	tmp = gfc_check_pdt_dummy (sym->ts.u.derived,
4749	sym->backend_decl,
4750	sym->as ? sym->as->rank : 0,
4751	sym->param_list);
4752	gfc_add_expr_to_block (&tmpblock, tmp);
4753	gfc_add_init_cleanup (block, init: gfc_finish_block (&tmpblock), NULL);
4754	}
4755	}
4756	else if (sym->ts.type == BT_CLASS
4757	&& CLASS_DATA (sym)->ts.u.derived
4758	&& CLASS_DATA (sym)->ts.u.derived->attr.pdt_type)
4759	{
4760	gfc_component *data = CLASS_DATA (sym);
4761	is_pdt_type = true;
4762	gfc_init_block (&tmpblock);
4763	if (!(sym->attr.dummy
4764	|| CLASS_DATA (sym)->attr.pointer
4765	|| CLASS_DATA (sym)->attr.allocatable))
4766	{
4767	tmp = gfc_class_data_get (sym->backend_decl);
4768	tmp = gfc_allocate_pdt_comp (data->ts.u.derived, tmp,
4769	data->as ? data->as->rank : 0,
4770	sym->param_list);
4771	gfc_add_expr_to_block (&tmpblock, tmp);
4772	tmp = gfc_class_data_get (sym->backend_decl);
4773	if (!sym->attr.result)
4774	tmp = gfc_deallocate_pdt_comp (data->ts.u.derived, tmp,
4775	data->as ? data->as->rank : 0);
4776	else
4777	tmp = NULL_TREE;
4778	gfc_add_init_cleanup (block, init: gfc_finish_block (&tmpblock), cleanup: tmp);
4779	}
4780	else if (sym->attr.dummy)
4781	{
4782	tmp = gfc_class_data_get (sym->backend_decl);
4783	tmp = gfc_check_pdt_dummy (data->ts.u.derived, tmp,
4784	data->as ? data->as->rank : 0,
4785	sym->param_list);
4786	gfc_add_expr_to_block (&tmpblock, tmp);
4787	gfc_add_init_cleanup (block, init: gfc_finish_block (&tmpblock), NULL);
4788	}
4789	}
4790
4791	if (sym->attr.pointer && sym->attr.dimension
4792	&& sym->attr.save == SAVE_NONE
4793	&& !sym->attr.use_assoc
4794	&& !sym->attr.host_assoc
4795	&& !sym->attr.dummy
4796	&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)))
4797	{
4798	gfc_init_block (&tmpblock);
4799	gfc_conv_descriptor_span_set (&tmpblock, sym->backend_decl,
4800	build_int_cst (gfc_array_index_type, 0));
4801	gfc_add_init_cleanup (block, init: gfc_finish_block (&tmpblock),
4802	NULL_TREE);
4803	}
4804
4805	if (sym->ts.type == BT_CLASS
4806	&& (sym->attr.save || flag_max_stack_var_size == 0)
4807	&& CLASS_DATA (sym)->attr.allocatable)
4808	{
4809	tree vptr;
4810
4811	if (UNLIMITED_POLY (sym))
4812	vptr = null_pointer_node;
4813	else
4814	{
4815	gfc_symbol *vsym;
4816	vsym = gfc_find_derived_vtab (sym->ts.u.derived);
4817	vptr = gfc_get_symbol_decl (sym: vsym);
4818	vptr = gfc_build_addr_expr (NULL, vptr);
4819	}
4820
4821	if (CLASS_DATA (sym)->attr.dimension
4822	|| (CLASS_DATA (sym)->attr.codimension
4823	&& flag_coarray != GFC_FCOARRAY_LIB))
4824	{
4825	tmp = gfc_class_data_get (sym->backend_decl);
4826	tmp = gfc_build_null_descriptor (TREE_TYPE (tmp));
4827	}
4828	else
4829	tmp = null_pointer_node;
4830
4831	DECL_INITIAL (sym->backend_decl)
4832	= gfc_class_set_static_fields (sym->backend_decl, vptr, tmp);
4833	TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
4834	}
4835	else if ((sym->attr.dimension || sym->attr.codimension
4836	|| (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable)))
4837	{
4838	bool is_classarray = IS_CLASS_ARRAY (sym);
4839	symbol_attribute *array_attr;
4840	gfc_array_spec *as;
4841	array_type type_of_array;
4842
4843	array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
4844	as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
4845	/* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
4846	type_of_array = as->type;
4847	if (type_of_array == AS_ASSUMED_SIZE && as->cp_was_assumed)
4848	type_of_array = AS_EXPLICIT;
4849	switch (type_of_array)
4850	{
4851	case AS_EXPLICIT:
4852	if (sym->attr.dummy || sym->attr.result)
4853	gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
4854	/* Allocatable and pointer arrays need to processed
4855	explicitly. */
4856	else if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
4857	|| (sym->ts.type == BT_CLASS
4858	&& CLASS_DATA (sym)->attr.class_pointer)
4859	|| array_attr->allocatable)
4860	{
4861	if (TREE_STATIC (sym->backend_decl))
4862	{
4863	gfc_save_backend_locus (&loc);
4864	gfc_set_backend_locus (&sym->declared_at);
4865	gfc_trans_static_array_pointer (sym);
4866	gfc_restore_backend_locus (&loc);
4867	}
4868	else
4869	{
4870	seen_trans_deferred_array = true;
4871	gfc_trans_deferred_array (sym, block);
4872	}
4873	}
4874	else if (sym->attr.codimension
4875	&& TREE_STATIC (sym->backend_decl))
4876	{
4877	gfc_init_block (&tmpblock);
4878	gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl),
4879	&tmpblock, sym);
4880	gfc_add_init_cleanup (block, init: gfc_finish_block (&tmpblock),
4881	NULL_TREE);
4882	continue;
4883	}
4884	else
4885	{
4886	gfc_save_backend_locus (&loc);
4887	gfc_set_backend_locus (&sym->declared_at);
4888
4889	if (alloc_comp_or_fini)
4890	{
4891	seen_trans_deferred_array = true;
4892	gfc_trans_deferred_array (sym, block);
4893	}
4894	else if (sym->ts.type == BT_DERIVED
4895	&& sym->value
4896	&& !sym->attr.data
4897	&& sym->attr.save == SAVE_NONE)
4898	{
4899	gfc_start_block (&tmpblock);
4900	gfc_init_default_dt (sym, block: &tmpblock, dealloc: false);
4901	gfc_add_init_cleanup (block,
4902	init: gfc_finish_block (&tmpblock),
4903	NULL_TREE);
4904	}
4905
4906	gfc_trans_auto_array_allocation (sym->backend_decl,
4907	sym, block);
4908	gfc_restore_backend_locus (&loc);
4909	}
4910	break;
4911
4912	case AS_ASSUMED_SIZE:
4913	/* Must be a dummy parameter. */
4914	gcc_assert (sym->attr.dummy || as->cp_was_assumed);
4915
4916	/* We should always pass assumed size arrays the g77 way. */
4917	if (sym->attr.dummy)
4918	gfc_trans_g77_array (sym, block);
4919	break;
4920
4921	case AS_ASSUMED_SHAPE:
4922	/* Must be a dummy parameter. */
4923	gcc_assert (sym->attr.dummy);
4924
4925	gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
4926	break;
4927
4928	case AS_ASSUMED_RANK:
4929	case AS_DEFERRED:
4930	seen_trans_deferred_array = true;
4931	gfc_trans_deferred_array (sym, block);
4932	if (sym->ts.type == BT_CHARACTER && sym->ts.deferred
4933	&& sym->attr.result)
4934	{
4935	gfc_start_block (&init);
4936	gfc_save_backend_locus (&loc);
4937	gfc_set_backend_locus (&sym->declared_at);
4938	tmp = gfc_null_and_pass_deferred_len (sym, init: &init, loc: &loc);
4939	gfc_add_init_cleanup (block, init: gfc_finish_block (&init), cleanup: tmp);
4940	}
4941	break;
4942
4943	default:
4944	gcc_unreachable ();
4945	}
4946	if (alloc_comp_or_fini && !seen_trans_deferred_array)
4947	gfc_trans_deferred_array (sym, block);
4948	}
4949	else if ((!sym->attr.dummy || sym->ts.deferred)
4950	&& (sym->ts.type == BT_CLASS
4951	&& CLASS_DATA (sym)->attr.class_pointer))
4952	gfc_trans_class_array (sym, block);
4953	else if ((!sym->attr.dummy || sym->ts.deferred)
4954	&& (sym->attr.allocatable
4955	|| (sym->attr.pointer && sym->attr.result)
4956	|| (sym->ts.type == BT_CLASS
4957	&& CLASS_DATA (sym)->attr.allocatable)))
4958	{
4959	if (!sym->attr.save && flag_max_stack_var_size != 0)
4960	{
4961	tree descriptor = NULL_TREE;
4962
4963	gfc_save_backend_locus (&loc);
4964	gfc_set_backend_locus (&sym->declared_at);
4965	gfc_start_block (&init);
4966
4967	if (sym->ts.type == BT_CHARACTER
4968	&& sym->attr.allocatable
4969	&& !sym->attr.dimension
4970	&& sym->ts.u.cl && sym->ts.u.cl->length
4971	&& sym->ts.u.cl->length->expr_type == EXPR_VARIABLE)
4972	gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4973
4974	if (!sym->attr.pointer)
4975	{
4976	/* Nullify and automatic deallocation of allocatable
4977	scalars. */
4978	e = gfc_lval_expr_from_sym (sym);
4979	if (sym->ts.type == BT_CLASS)
4980	gfc_add_data_component (e);
4981
4982	gfc_init_se (&se, NULL);
4983	if (sym->ts.type != BT_CLASS
4984	|| sym->ts.u.derived->attr.dimension
4985	|| sym->ts.u.derived->attr.codimension)
4986	{
4987	se.want_pointer = 1;
4988	gfc_conv_expr (se: &se, expr: e);
4989	}
4990	else if (sym->ts.type == BT_CLASS
4991	&& !CLASS_DATA (sym)->attr.dimension
4992	&& !CLASS_DATA (sym)->attr.codimension)
4993	{
4994	se.want_pointer = 1;
4995	gfc_conv_expr (se: &se, expr: e);
4996	}
4997	else
4998	{
4999	se.descriptor_only = 1;
5000	gfc_conv_expr (se: &se, expr: e);
5001	descriptor = se.expr;
5002	se.expr = gfc_conv_descriptor_data_addr (se.expr);
5003	se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
5004	}
5005	gfc_free_expr (e);
5006
5007	if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
5008	{
5009	/* Nullify when entering the scope. */
5010	tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5011	TREE_TYPE (se.expr), se.expr,
5012	fold_convert (TREE_TYPE (se.expr),
5013	null_pointer_node));
5014	if (sym->attr.optional)
5015	{
5016	tree present = gfc_conv_expr_present (sym);
5017	tmp = build3_loc (loc: input_location, code: COND_EXPR,
5018	void_type_node, arg0: present, arg1: tmp,
5019	arg2: build_empty_stmt (input_location));
5020	}
5021	gfc_add_expr_to_block (&init, tmp);
5022	}
5023	}
5024
5025	if ((sym->attr.dummy || sym->attr.result)
5026	&& sym->ts.type == BT_CHARACTER
5027	&& sym->ts.deferred
5028	&& sym->ts.u.cl->passed_length)
5029	tmp = gfc_null_and_pass_deferred_len (sym, init: &init, loc: &loc);
5030	else
5031	{
5032	gfc_restore_backend_locus (&loc);
5033	tmp = NULL_TREE;
5034	}
5035
5036	/* Initialize descriptor's TKR information. */
5037	if (sym->ts.type == BT_CLASS)
5038	gfc_trans_class_array (sym, block);
5039
5040	/* Deallocate when leaving the scope. Nullifying is not
5041	needed. */
5042	if (!sym->attr.result && !sym->attr.dummy && !sym->attr.pointer
5043	&& !sym->ns->proc_name->attr.is_main_program)
5044	{
5045	if (sym->ts.type == BT_CLASS
5046	&& CLASS_DATA (sym)->attr.codimension)
5047	tmp = gfc_deallocate_with_status (descriptor, NULL_TREE,
5048	NULL_TREE, NULL_TREE,
5049	NULL_TREE, true, NULL,
5050	GFC_CAF_COARRAY_ANALYZE);
5051	else
5052	{
5053	gfc_expr *expr = gfc_lval_expr_from_sym (sym);
5054	tmp = gfc_deallocate_scalar_with_status (se.expr,
5055	NULL_TREE,
5056	NULL_TREE,
5057	true, expr,
5058	sym->ts);
5059	gfc_free_expr (expr);
5060	}
5061	}
5062
5063	if (sym->ts.type == BT_CLASS)
5064	{
5065	/* Initialize _vptr to declared type. */
5066	gfc_symbol *vtab;
5067	tree rhs;
5068
5069	gfc_save_backend_locus (&loc);
5070	gfc_set_backend_locus (&sym->declared_at);
5071	e = gfc_lval_expr_from_sym (sym);
5072	gfc_add_vptr_component (e);
5073	gfc_init_se (&se, NULL);
5074	se.want_pointer = 1;
5075	gfc_conv_expr (se: &se, expr: e);
5076	gfc_free_expr (e);
5077	if (UNLIMITED_POLY (sym))
5078	rhs = build_int_cst (TREE_TYPE (se.expr), 0);
5079	else
5080	{
5081	vtab = gfc_find_derived_vtab (sym->ts.u.derived);
5082	rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
5083	gfc_get_symbol_decl (sym: vtab));
5084	}
5085	gfc_add_modify (&init, se.expr, rhs);
5086	gfc_restore_backend_locus (&loc);
5087	}
5088
5089	gfc_add_init_cleanup (block, init: gfc_finish_block (&init), cleanup: tmp);
5090	}
5091	}
5092	else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
5093	{
5094	tree tmp = NULL;
5095	stmtblock_t init;
5096
5097	/* If we get to here, all that should be left are pointers. */
5098	gcc_assert (sym->attr.pointer);
5099
5100	if (sym->attr.dummy)
5101	{
5102	gfc_start_block (&init);
5103	gfc_save_backend_locus (&loc);
5104	gfc_set_backend_locus (&sym->declared_at);
5105	tmp = gfc_null_and_pass_deferred_len (sym, init: &init, loc: &loc);
5106	gfc_add_init_cleanup (block, init: gfc_finish_block (&init), cleanup: tmp);
5107	}
5108	}
5109	else if (sym->ts.deferred)
5110	gfc_fatal_error ("Deferred type parameter not yet supported");
5111	else if (alloc_comp_or_fini)
5112	gfc_trans_deferred_array (sym, block);
5113	else if (sym->ts.type == BT_CHARACTER)
5114	{
5115	gfc_save_backend_locus (&loc);
5116	gfc_set_backend_locus (&sym->declared_at);
5117	if (sym->attr.dummy || sym->attr.result)
5118	gfc_trans_dummy_character (sym, cl: sym->ts.u.cl, block);
5119	else
5120	gfc_trans_auto_character_variable (sym, block);
5121	gfc_restore_backend_locus (&loc);
5122	}
5123	else if (sym->attr.assign)
5124	{
5125	gfc_save_backend_locus (&loc);
5126	gfc_set_backend_locus (&sym->declared_at);
5127	gfc_trans_assign_aux_var (sym, block);
5128	gfc_restore_backend_locus (&loc);
5129	}
5130	else if (sym->ts.type == BT_DERIVED
5131	&& sym->value
5132	&& !sym->attr.data
5133	&& sym->attr.save == SAVE_NONE)
5134	{
5135	gfc_start_block (&tmpblock);
5136	gfc_init_default_dt (sym, block: &tmpblock, dealloc: false);
5137	gfc_add_init_cleanup (block, init: gfc_finish_block (&tmpblock),
5138	NULL_TREE);
5139	}
5140	else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type)
5141	gcc_unreachable ();
5142	}
5143
5144	/* Handle 'omp allocate'. This has to be after the block above as
5145	gfc_add_init_cleanup (..., init, ...) puts 'init' of later calls
5146	before earlier calls. The code is a bit more complex as gfortran does
5147	not really work with bind expressions / BIND_EXPR_VARS properly, i.e.
5148	gimplify_bind_expr needs some help for placing the GOMP_alloc. Thus,
5149	we pass on the location of the allocate-assignment expression and,
5150	if the size is not constant, the size variable if Fortran computes this
5151	differently. We also might add an expression location after which the
5152	code has to be added, e.g. for character len expressions, which affect
5153	the UNIT_SIZE. */
5154	gfc_expr *last_allocator = NULL;
5155	if (omp_ns && omp_ns->omp_allocate)
5156	{
5157	if (!block->init || TREE_CODE (block->init) != STATEMENT_LIST)
5158	{
5159	tree tmp = build1_v (LABEL_EXPR, gfc_build_label_decl (NULL_TREE));
5160	append_to_statement_list (tmp, &block->init);
5161	}
5162	if (!block->cleanup || TREE_CODE (block->cleanup) != STATEMENT_LIST)
5163	{
5164	tree tmp = build1_v (LABEL_EXPR, gfc_build_label_decl (NULL_TREE));
5165	append_to_statement_list (tmp, &block->cleanup);
5166	}
5167	}
5168	tree init_stmtlist = block->init;
5169	tree cleanup_stmtlist = block->cleanup;
5170	se.expr = NULL_TREE;
5171	for (struct gfc_omp_namelist *n = omp_ns ? omp_ns->omp_allocate : NULL;
5172	n; n = n->next)
5173	if (!TREE_STATIC (n->sym->backend_decl))
5174	{
5175	tree align = (n->u.align ? gfc_conv_constant_to_tree (n->u.align)
5176	: NULL_TREE);
5177	if (last_allocator != n->u2.allocator)
5178	{
5179	location_t loc = input_location;
5180	gfc_init_se (&se, NULL);
5181	if (n->u2.allocator)
5182	{
5183	input_location = gfc_get_location (&n->u2.allocator->where);
5184	gfc_conv_expr (se: &se, expr: n->u2.allocator);
5185	}
5186	/* We need to evalulate non-constants - also to find the location
5187	after which the GOMP_alloc has to be added to - also as BLOCK
5188	does not yield a new BIND_EXPR_BODY. */
5189	if (n->u2.allocator
5190	&& (!(CONSTANT_CLASS_P (se.expr) && DECL_P (se.expr))
5191	|| se.pre.head || se.post.head))
5192	{
5193	stmtblock_t tmpblock;
5194	gfc_init_block (&tmpblock);
5195	se.expr = gfc_evaluate_now (se.expr, &tmpblock);
5196	/* First post then pre because the new code is inserted
5197	at the top. */
5198	gfc_add_init_cleanup (block, init: gfc_finish_block (&se.post), NULL);
5199	gfc_add_init_cleanup (block, init: gfc_finish_block (&tmpblock),
5200	NULL);
5201	gfc_add_init_cleanup (block, init: gfc_finish_block (&se.pre), NULL);
5202	}
5203	last_allocator = n->u2.allocator;
5204	input_location = loc;
5205	}
5206
5207	/* 'omp allocate( {purpose: allocator, value: align},
5208	{purpose: init-stmtlist, value: cleanup-stmtlist},
5209	{purpose: size-var, value: last-size-expr}}
5210	where init-stmt/cleanup-stmt is the STATEMENT list to find the
5211	try-final block; last-size-expr is to find the location after
5212	which to add the code and 'size-var' is for the proper size, cf.
5213	gfc_trans_auto_array_allocation - either or both of the latter
5214	can be NULL. */
5215	tree tmp = lookup_attribute (attr_name: "omp allocate",
5216	DECL_ATTRIBUTES (n->sym->backend_decl));
5217	tmp = TREE_VALUE (tmp);
5218	TREE_PURPOSE (tmp) = se.expr;
5219	TREE_VALUE (tmp) = align;
5220	TREE_PURPOSE (TREE_CHAIN (tmp)) = init_stmtlist;
5221	TREE_VALUE (TREE_CHAIN (tmp)) = cleanup_stmtlist;
5222	}
5223	else if (n->sym->attr.in_common)
5224	{
5225	gfc_error ("Sorry, !$OMP allocate for COMMON block variable %qs at %L "
5226	"not supported", n->sym->common_block->name,
5227	&n->sym->common_block->where);
5228	break;
5229	}
5230	else
5231	{
5232	gfc_error ("Sorry, !$OMP allocate for variable %qs at %L with SAVE "
5233	"attribute not yet implemented", n->sym->name,
5234	&n->sym->declared_at);
5235	/* FIXME: Remember to handle last_allocator. */
5236	break;
5237	}
5238
5239	gfc_init_block (&tmpblock);
5240
5241	for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
5242	{
5243	if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER
5244	&& f->sym->ts.u.cl->backend_decl)
5245	{
5246	if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
5247	gfc_trans_vla_type_sizes (sym: f->sym, body: &tmpblock);
5248	}
5249	}
5250
5251	if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
5252	&& current_fake_result_decl != NULL)
5253	{
5254	gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
5255	if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
5256	gfc_trans_vla_type_sizes (sym: proc_sym, body: &tmpblock);
5257	}
5258
5259	gfc_add_init_cleanup (block, init: gfc_finish_block (&tmpblock), NULL_TREE);
5260	}
5261
5262
5263	struct module_hasher : ggc_ptr_hash<module_htab_entry>
5264	{
5265	typedef const char *compare_type;
5266
5267	static hashval_t hash (module_htab_entry *s)
5268	{
5269	return htab_hash_string (s->name);
5270	}
5271
5272	static bool
5273	equal (module_htab_entry *a, const char *b)
5274	{
5275	return !strcmp (s1: a->name, s2: b);
5276	}
5277	};
5278
5279	static GTY (()) hash_table<module_hasher> *module_htab;
5280
5281	/* Hash and equality functions for module_htab's decls. */
5282
5283	hashval_t
5284	module_decl_hasher::hash (tree t)
5285	{
5286	const_tree n = DECL_NAME (t);
5287	if (n == NULL_TREE)
5288	n = TYPE_NAME (TREE_TYPE (t));
5289	return htab_hash_string (IDENTIFIER_POINTER (n));
5290	}
5291
5292	bool
5293	module_decl_hasher::equal (tree t1, const char *x2)
5294	{
5295	const_tree n1 = DECL_NAME (t1);
5296	if (n1 == NULL_TREE)
5297	n1 = TYPE_NAME (TREE_TYPE (t1));
5298	return strcmp (IDENTIFIER_POINTER (n1), s2: x2) == 0;
5299	}
5300
5301	struct module_htab_entry *
5302	gfc_find_module (const char *name)
5303	{
5304	if (! module_htab)
5305	module_htab = hash_table<module_hasher>::create_ggc (n: 10);
5306
5307	module_htab_entry **slot
5308	= module_htab->find_slot_with_hash (comparable: name, hash: htab_hash_string (name), insert: INSERT);
5309	if (*slot == NULL)
5310	{
5311	module_htab_entry *entry = ggc_cleared_alloc<module_htab_entry> ();
5312
5313	entry->name = gfc_get_string ("%s", name);
5314	entry->decls = hash_table<module_decl_hasher>::create_ggc (n: 10);
5315	*slot = entry;
5316	}
5317	return *slot;
5318	}
5319
5320	void
5321	gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
5322	{
5323	const char *name;
5324
5325	if (DECL_NAME (decl))
5326	name = IDENTIFIER_POINTER (DECL_NAME (decl));
5327	else
5328	{
5329	gcc_assert (TREE_CODE (decl) == TYPE_DECL);
5330	name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
5331	}
5332	tree *slot
5333	= entry->decls->find_slot_with_hash (comparable: name, hash: htab_hash_string (name),
5334	insert: INSERT);
5335	if (*slot == NULL)
5336	*slot = decl;
5337	}
5338
5339
5340	/* Generate debugging symbols for namelists. This function must come after
5341	generate_local_decl to ensure that the variables in the namelist are
5342	already declared. */
5343
5344	static tree
5345	generate_namelist_decl (gfc_symbol * sym)
5346	{
5347	gfc_namelist *nml;
5348	tree decl;
5349	vec<constructor_elt, va_gc> *nml_decls = NULL;
5350
5351	gcc_assert (sym->attr.flavor == FL_NAMELIST);
5352	for (nml = sym->namelist; nml; nml = nml->next)
5353	{
5354	if (nml->sym->backend_decl == NULL_TREE)
5355	{
5356	nml->sym->attr.referenced = 1;
5357	nml->sym->backend_decl = gfc_get_symbol_decl (sym: nml->sym);
5358	}
5359	DECL_IGNORED_P (nml->sym->backend_decl) = 0;
5360	CONSTRUCTOR_APPEND_ELT (nml_decls, NULL_TREE, nml->sym->backend_decl);
5361	}
5362
5363	decl = make_node (NAMELIST_DECL);
5364	TREE_TYPE (decl) = void_type_node;
5365	NAMELIST_DECL_ASSOCIATED_DECL (decl) = build_constructor (NULL_TREE, nml_decls);
5366	DECL_NAME (decl) = get_identifier (sym->name);
5367	return decl;
5368	}
5369
5370
5371	/* Output an initialized decl for a module variable. */
5372
5373	static void
5374	gfc_create_module_variable (gfc_symbol * sym)
5375	{
5376	tree decl;
5377
5378	/* Module functions with alternate entries are dealt with later and
5379	would get caught by the next condition. */
5380	if (sym->attr.entry)
5381	return;
5382
5383	/* Make sure we convert the types of the derived types from iso_c_binding
5384	into (void *). */
5385	if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
5386	&& sym->ts.type == BT_DERIVED)
5387	sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
5388
5389	if (gfc_fl_struct (sym->attr.flavor)
5390	&& sym->backend_decl
5391	&& TREE_CODE (sym->backend_decl) == RECORD_TYPE)
5392	{
5393	decl = sym->backend_decl;
5394	gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
5395
5396	if (!sym->attr.use_assoc && !sym->attr.used_in_submodule)
5397	{
5398	gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
5399	|| TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
5400	gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
5401	|| DECL_CONTEXT (TYPE_STUB_DECL (decl))
5402	== sym->ns->proc_name->backend_decl);
5403	}
5404	TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
5405	DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
5406	gfc_module_add_decl (entry: cur_module, TYPE_STUB_DECL (decl));
5407	}
5408
5409	/* Only output variables, procedure pointers and array valued,
5410	or derived type, parameters. */
5411	if (sym->attr.flavor != FL_VARIABLE
5412	&& !(sym->attr.flavor == FL_PARAMETER
5413	&& (sym->attr.dimension || sym->ts.type == BT_DERIVED))
5414	&& !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
5415	return;
5416
5417	if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
5418	{
5419	decl = sym->backend_decl;
5420	gcc_assert (DECL_FILE_SCOPE_P (decl));
5421	gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
5422	DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
5423	gfc_module_add_decl (entry: cur_module, decl);
5424	}
5425
5426	/* Don't generate variables from other modules. Variables from
5427	COMMONs and Cray pointees will already have been generated. */
5428	if (sym->attr.use_assoc || sym->attr.used_in_submodule
5429	|| sym->attr.in_common || sym->attr.cray_pointee)
5430	return;
5431
5432	/* Equivalenced variables arrive here after creation. */
5433	if (sym->backend_decl
5434	&& (sym->equiv_built || sym->attr.in_equivalence))
5435	return;
5436
5437	if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
5438	gfc_internal_error ("backend decl for module variable %qs already exists",
5439	sym->name);
5440
5441	if (sym->module && !sym->attr.result && !sym->attr.dummy
5442	&& (sym->attr.access == ACCESS_UNKNOWN
5443	&& (sym->ns->default_access == ACCESS_PRIVATE
5444	|| (sym->ns->default_access == ACCESS_UNKNOWN
5445	&& flag_module_private))))
5446	sym->attr.access = ACCESS_PRIVATE;
5447
5448	if (warn_unused_variable && !sym->attr.referenced
5449	&& sym->attr.access == ACCESS_PRIVATE)
5450	gfc_warning (opt: OPT_Wunused_value,
5451	"Unused PRIVATE module variable %qs declared at %L",
5452	sym->name, &sym->declared_at);
5453
5454	/* We always want module variables to be created. */
5455	sym->attr.referenced = 1;
5456	/* Create the decl. */
5457	decl = gfc_get_symbol_decl (sym);
5458
5459	/* Create the variable. */
5460	pushdecl (decl);
5461	gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE
5462	|| (sym->ns->parent->proc_name->attr.flavor == FL_MODULE
5463	&& sym->fn_result_spec));
5464	DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
5465	rest_of_decl_compilation (decl, 1, 0);
5466	gfc_module_add_decl (entry: cur_module, decl);
5467
5468	/* Also add length of strings. */
5469	if (sym->ts.type == BT_CHARACTER)
5470	{
5471	tree length;
5472
5473	length = sym->ts.u.cl->backend_decl;
5474	gcc_assert (length || sym->attr.proc_pointer);
5475	if (length && !INTEGER_CST_P (length))
5476	{
5477	pushdecl (length);
5478	rest_of_decl_compilation (length, 1, 0);
5479	}
5480	}
5481
5482	if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
5483	&& sym->attr.referenced && !sym->attr.use_assoc)
5484	has_coarray_vars = true;
5485	}
5486
5487	/* Emit debug information for USE statements. */
5488
5489	static void
5490	gfc_trans_use_stmts (gfc_namespace * ns)
5491	{
5492	gfc_use_list *use_stmt;
5493	for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
5494	{
5495	struct module_htab_entry *entry
5496	= gfc_find_module (name: use_stmt->module_name);
5497	gfc_use_rename *rent;
5498
5499	if (entry->namespace_decl == NULL)
5500	{
5501	entry->namespace_decl
5502	= build_decl (input_location,
5503	NAMESPACE_DECL,
5504	get_identifier (use_stmt->module_name),
5505	void_type_node);
5506	DECL_EXTERNAL (entry->namespace_decl) = 1;
5507	}
5508	gfc_set_backend_locus (&use_stmt->where);
5509	if (!use_stmt->only_flag)
5510	(*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
5511	NULL_TREE,
5512	ns->proc_name->backend_decl,
5513	false, false);
5514	for (rent = use_stmt->rename; rent; rent = rent->next)
5515	{
5516	tree decl, local_name;
5517
5518	if (rent->op != INTRINSIC_NONE)
5519	continue;
5520
5521	hashval_t hash = htab_hash_string (rent->use_name);
5522	tree *slot = entry->decls->find_slot_with_hash (comparable: rent->use_name, hash,
5523	insert: INSERT);
5524	if (*slot == NULL)
5525	{
5526	gfc_symtree *st;
5527
5528	st = gfc_find_symtree (ns->sym_root,
5529	rent->local_name[0]
5530	? rent->local_name : rent->use_name);
5531
5532	/* The following can happen if a derived type is renamed. */
5533	if (!st)
5534	{
5535	char *name;
5536	name = xstrdup (rent->local_name[0]
5537	? rent->local_name : rent->use_name);
5538	name[0] = (char) TOUPPER ((unsigned char) name[0]);
5539	st = gfc_find_symtree (ns->sym_root, name);
5540	free (ptr: name);
5541	gcc_assert (st);
5542	}
5543
5544	/* Sometimes, generic interfaces wind up being over-ruled by a
5545	local symbol (see PR41062). */
5546	if (!st->n.sym->attr.use_assoc)
5547	{
5548	*slot = error_mark_node;
5549	entry->decls->clear_slot (slot);
5550	continue;
5551	}
5552
5553	if (st->n.sym->backend_decl
5554	&& DECL_P (st->n.sym->backend_decl)
5555	&& st->n.sym->module
5556	&& strcmp (s1: st->n.sym->module, s2: use_stmt->module_name) == 0)
5557	{
5558	gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
5559	|| !VAR_P (st->n.sym->backend_decl));
5560	decl = copy_node (st->n.sym->backend_decl);
5561	DECL_CONTEXT (decl) = entry->namespace_decl;
5562	DECL_EXTERNAL (decl) = 1;
5563	DECL_IGNORED_P (decl) = 0;
5564	DECL_INITIAL (decl) = NULL_TREE;
5565	}
5566	else if (st->n.sym->attr.flavor == FL_NAMELIST
5567	&& st->n.sym->attr.use_only
5568	&& st->n.sym->module
5569	&& strcmp (s1: st->n.sym->module, s2: use_stmt->module_name)
5570	== 0)
5571	{
5572	decl = generate_namelist_decl (sym: st->n.sym);
5573	DECL_CONTEXT (decl) = entry->namespace_decl;
5574	DECL_EXTERNAL (decl) = 1;
5575	DECL_IGNORED_P (decl) = 0;
5576	DECL_INITIAL (decl) = NULL_TREE;
5577	}
5578	else
5579	{
5580	*slot = error_mark_node;
5581	entry->decls->clear_slot (slot);
5582	continue;
5583	}
5584	*slot = decl;
5585	}
5586	decl = (tree) *slot;
5587	if (rent->local_name[0])
5588	local_name = get_identifier (rent->local_name);
5589	else
5590	local_name = NULL_TREE;
5591	gfc_set_backend_locus (&rent->where);
5592	(*debug_hooks->imported_module_or_decl) (decl, local_name,
5593	ns->proc_name->backend_decl,
5594	!use_stmt->only_flag,
5595	false);
5596	}
5597	}
5598	}
5599
5600
5601	/* Return true if expr is a constant initializer that gfc_conv_initializer
5602	will handle. */
5603
5604	static bool
5605	check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
5606	bool pointer)
5607	{
5608	gfc_constructor *c;
5609	gfc_component *cm;
5610
5611	if (pointer)
5612	return true;
5613	else if (array)
5614	{
5615	if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
5616	return true;
5617	else if (expr->expr_type == EXPR_STRUCTURE)
5618	return check_constant_initializer (expr, ts, array: false, pointer: false);
5619	else if (expr->expr_type != EXPR_ARRAY)
5620	return false;
5621	for (c = gfc_constructor_first (base: expr->value.constructor);
5622	c; c = gfc_constructor_next (ctor: c))
5623	{
5624	if (c->iterator)
5625	return false;
5626	if (c->expr->expr_type == EXPR_STRUCTURE)
5627	{
5628	if (!check_constant_initializer (expr: c->expr, ts, array: false, pointer: false))
5629	return false;
5630	}
5631	else if (c->expr->expr_type != EXPR_CONSTANT)
5632	return false;
5633	}
5634	return true;
5635	}
5636	else switch (ts->type)
5637	{
5638	case_bt_struct:
5639	if (expr->expr_type != EXPR_STRUCTURE)
5640	return false;
5641	cm = expr->ts.u.derived->components;
5642	for (c = gfc_constructor_first (base: expr->value.constructor);
5643	c; c = gfc_constructor_next (ctor: c), cm = cm->next)
5644	{
5645	if (!c->expr || cm->attr.allocatable)
5646	continue;
5647	if (!check_constant_initializer (expr: c->expr, ts: &cm->ts,
5648	array: cm->attr.dimension,
5649	pointer: cm->attr.pointer))
5650	return false;
5651	}
5652	return true;
5653	default:
5654	return expr->expr_type == EXPR_CONSTANT;
5655	}
5656	}
5657
5658	/* Emit debug info for parameters and unreferenced variables with
5659	initializers. */
5660
5661	static void
5662	gfc_emit_parameter_debug_info (gfc_symbol *sym)
5663	{
5664	tree decl;
5665
5666	if (sym->attr.flavor != FL_PARAMETER
5667	&& (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
5668	return;
5669
5670	if (sym->backend_decl != NULL
5671	|| sym->value == NULL
5672	|| sym->attr.use_assoc
5673	|| sym->attr.dummy
5674	|| sym->attr.result
5675	|| sym->attr.function
5676	|| sym->attr.intrinsic
5677	|| sym->attr.pointer
5678	|| sym->attr.allocatable
5679	|| sym->attr.cray_pointee
5680	|| sym->attr.threadprivate
5681	|| sym->attr.is_bind_c
5682	|| sym->attr.subref_array_pointer
5683	|| sym->attr.assign)
5684	return;
5685
5686	if (sym->ts.type == BT_CHARACTER)
5687	{
5688	gfc_conv_const_charlen (sym->ts.u.cl);
5689	if (sym->ts.u.cl->backend_decl == NULL
5690	|| TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
5691	return;
5692	}
5693	else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
5694	return;
5695
5696	if (sym->as)
5697	{
5698	int n;
5699
5700	if (sym->as->type != AS_EXPLICIT)
5701	return;
5702	for (n = 0; n < sym->as->rank; n++)
5703	if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
5704	|| sym->as->upper[n] == NULL
5705	|| sym->as->upper[n]->expr_type != EXPR_CONSTANT)
5706	return;
5707	}
5708
5709	if (!check_constant_initializer (expr: sym->value, ts: &sym->ts,
5710	array: sym->attr.dimension, pointer: false))
5711	return;
5712
5713	if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
5714	return;
5715
5716	/* Create the decl for the variable or constant. */
5717	decl = build_decl (input_location,
5718	sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
5719	gfc_sym_identifier (sym), gfc_sym_type (sym));
5720	if (sym->attr.flavor == FL_PARAMETER)
5721	TREE_READONLY (decl) = 1;
5722	gfc_set_decl_location (decl, loc: &sym->declared_at);
5723	if (sym->attr.dimension)
5724	GFC_DECL_PACKED_ARRAY (decl) = 1;
5725	DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
5726	TREE_STATIC (decl) = 1;
5727	TREE_USED (decl) = 1;
5728	if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
5729	TREE_PUBLIC (decl) = 1;
5730	DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
5731	TREE_TYPE (decl),
5732	sym->attr.dimension,
5733	false, false);
5734	debug_hooks->early_global_decl (decl);
5735	}
5736
5737
5738	static void
5739	generate_coarray_sym_init (gfc_symbol *sym)
5740	{
5741	tree tmp, size, decl, token, desc;
5742	bool is_lock_type, is_event_type;
5743	int reg_type;
5744	gfc_se se;
5745	symbol_attribute attr;
5746
5747	if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
5748	|| sym->attr.use_assoc || !sym->attr.referenced
5749	|| sym->attr.associate_var
5750	|| sym->attr.select_type_temporary)
5751	return;
5752
5753	decl = sym->backend_decl;
5754	TREE_USED(decl) = 1;
5755	gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
5756
5757	is_lock_type = sym->ts.type == BT_DERIVED
5758	&& sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
5759	&& sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE;
5760
5761	is_event_type = sym->ts.type == BT_DERIVED
5762	&& sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
5763	&& sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE;
5764
5765	/* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
5766	to make sure the variable is not optimized away. */
5767	DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
5768
5769	/* For lock types, we pass the array size as only the library knows the
5770	size of the variable. */
5771	if (is_lock_type || is_event_type)
5772	size = gfc_index_one_node;
5773	else
5774	size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
5775
5776	/* Ensure that we do not have size=0 for zero-sized arrays. */
5777	size = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
5778	fold_convert (size_type_node, size),
5779	build_int_cst (size_type_node, 1));
5780
5781	if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)))
5782	{
5783	tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl));
5784	size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
5785	fold_convert (size_type_node, tmp), size);
5786	}
5787
5788	gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE);
5789	token = gfc_build_addr_expr (ppvoid_type_node,
5790	GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
5791	if (is_lock_type)
5792	reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL : GFC_CAF_LOCK_STATIC;
5793	else if (is_event_type)
5794	reg_type = GFC_CAF_EVENT_STATIC;
5795	else
5796	reg_type = GFC_CAF_COARRAY_STATIC;
5797
5798	/* Compile the symbol attribute. */
5799	if (sym->ts.type == BT_CLASS)
5800	{
5801	attr = CLASS_DATA (sym)->attr;
5802	/* The pointer attribute is always set on classes, overwrite it with the
5803	class_pointer attribute, which denotes the pointer for classes. */
5804	attr.pointer = attr.class_pointer;
5805	}
5806	else
5807	attr = sym->attr;
5808	gfc_init_se (&se, NULL);
5809	desc = gfc_conv_scalar_to_descriptor (&se, decl, attr);
5810	gfc_add_block_to_block (&caf_init_block, &se.pre);
5811
5812	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 7, size,
5813	build_int_cst (integer_type_node, reg_type),
5814	token, gfc_build_addr_expr (pvoid_type_node, desc),
5815	null_pointer_node, /* stat. */
5816	null_pointer_node, /* errgmsg. */
5817	build_zero_cst (size_type_node)); /* errmsg_len. */
5818	gfc_add_expr_to_block (&caf_init_block, tmp);
5819	gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl),
5820	gfc_conv_descriptor_data_get (desc)));
5821
5822	/* Handle "static" initializer. */
5823	if (sym->value)
5824	{
5825	if (sym->value->expr_type == EXPR_ARRAY)
5826	{
5827	gfc_constructor *c, *cnext;
5828
5829	/* Test if the array has more than one element. */
5830	c = gfc_constructor_first (base: sym->value->value.constructor);
5831	gcc_assert (c); /* Empty constructor should not happen here. */
5832	cnext = gfc_constructor_next (ctor: c);
5833
5834	if (cnext)
5835	{
5836	/* An EXPR_ARRAY with a rank > 1 here has to come from a
5837	DATA statement. Set its rank here as not to confuse
5838	the following steps. */
5839	sym->value->rank = 1;
5840	}
5841	else
5842	{
5843	/* There is only a single value in the constructor, use
5844	it directly for the assignment. */
5845	gfc_expr *new_expr;
5846	new_expr = gfc_copy_expr (c->expr);
5847	gfc_free_expr (sym->value);
5848	sym->value = new_expr;
5849	}
5850	}
5851
5852	sym->attr.pointer = 1;
5853	tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value,
5854	true, false);
5855	sym->attr.pointer = 0;
5856	gfc_add_expr_to_block (&caf_init_block, tmp);
5857	}
5858	else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pointer_comp)
5859	{
5860	tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, decl, sym->as
5861	? sym->as->rank : 0,
5862	cm: GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
5863	gfc_add_expr_to_block (&caf_init_block, tmp);
5864	}
5865	}
5866
5867
5868	/* Generate constructor function to initialize static, nonallocatable
5869	coarrays. */
5870
5871	static void
5872	generate_coarray_init (gfc_namespace * ns __attribute((unused)))
5873	{
5874	tree fndecl, tmp, decl, save_fn_decl;
5875
5876	save_fn_decl = current_function_decl;
5877	push_function_context ();
5878
5879	tmp = build_function_type_list (void_type_node, NULL_TREE);
5880	fndecl = build_decl (input_location, FUNCTION_DECL,
5881	create_tmp_var_name ("_caf_init"), tmp);
5882
5883	DECL_STATIC_CONSTRUCTOR (fndecl) = 1;
5884	SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY);
5885
5886	decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node);
5887	DECL_ARTIFICIAL (decl) = 1;
5888	DECL_IGNORED_P (decl) = 1;
5889	DECL_CONTEXT (decl) = fndecl;
5890	DECL_RESULT (fndecl) = decl;
5891
5892	pushdecl (fndecl);
5893	current_function_decl = fndecl;
5894	announce_function (fndecl);
5895
5896	rest_of_decl_compilation (fndecl, 0, 0);
5897	make_decl_rtl (fndecl);
5898	allocate_struct_function (fndecl, false);
5899
5900	pushlevel ();
5901	gfc_init_block (&caf_init_block);
5902
5903	gfc_traverse_ns (ns, generate_coarray_sym_init);
5904
5905	DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block);
5906	decl = getdecls ();
5907
5908	poplevel (1, 1);
5909	BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5910
5911	DECL_SAVED_TREE (fndecl)
5912	= fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR, void_type_node,
5913	decl, DECL_SAVED_TREE (fndecl), DECL_INITIAL (fndecl));
5914	dump_function (phase: TDI_original, fn: fndecl);
5915
5916	cfun->function_end_locus = input_location;
5917	set_cfun (NULL);
5918
5919	if (decl_function_context (fndecl))
5920	(void) cgraph_node::create (decl: fndecl);
5921	else
5922	cgraph_node::finalize_function (fndecl, true);
5923
5924	pop_function_context ();
5925	current_function_decl = save_fn_decl;
5926	}
5927
5928
5929	static void
5930	create_module_nml_decl (gfc_symbol *sym)
5931	{
5932	if (sym->attr.flavor == FL_NAMELIST)
5933	{
5934	tree decl = generate_namelist_decl (sym);
5935	pushdecl (decl);
5936	gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
5937	DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
5938	rest_of_decl_compilation (decl, 1, 0);
5939	gfc_module_add_decl (entry: cur_module, decl);
5940	}
5941	}
5942
5943
5944	/* Generate all the required code for module variables. */
5945
5946	void
5947	gfc_generate_module_vars (gfc_namespace * ns)
5948	{
5949	module_namespace = ns;
5950	cur_module = gfc_find_module (name: ns->proc_name->name);
5951
5952	/* Check if the frontend left the namespace in a reasonable state. */
5953	gcc_assert (ns->proc_name && !ns->proc_name->tlink);
5954
5955	/* Generate COMMON blocks. */
5956	gfc_trans_common (ns);
5957
5958	has_coarray_vars = false;
5959
5960	/* Create decls for all the module variables. */
5961	gfc_traverse_ns (ns, gfc_create_module_variable);
5962	gfc_traverse_ns (ns, create_module_nml_decl);
5963
5964	if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
5965	generate_coarray_init (ns);
5966
5967	cur_module = NULL;
5968
5969	gfc_trans_use_stmts (ns);
5970	gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
5971	}
5972
5973
5974	static void
5975	gfc_generate_contained_functions (gfc_namespace * parent)
5976	{
5977	gfc_namespace *ns;
5978
5979	/* We create all the prototypes before generating any code. */
5980	for (ns = parent->contained; ns; ns = ns->sibling)
5981	{
5982	/* Skip namespaces from used modules. */
5983	if (ns->parent != parent)
5984	continue;
5985
5986	gfc_create_function_decl (ns, global: false);
5987	}
5988
5989	for (ns = parent->contained; ns; ns = ns->sibling)
5990	{
5991	/* Skip namespaces from used modules. */
5992	if (ns->parent != parent)
5993	continue;
5994
5995	gfc_generate_function_code (ns);
5996	}
5997	}
5998
5999
6000	/* Drill down through expressions for the array specification bounds and
6001	character length calling generate_local_decl for all those variables
6002	that have not already been declared. */
6003
6004	static void
6005	generate_local_decl (gfc_symbol *);
6006
6007	/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
6008
6009	static bool
6010	expr_decls (gfc_expr *e, gfc_symbol *sym,
6011	int *f ATTRIBUTE_UNUSED)
6012	{
6013	if (e->expr_type != EXPR_VARIABLE
6014	|| sym == e->symtree->n.sym
6015	|| e->symtree->n.sym->mark
6016	|| e->symtree->n.sym->ns != sym->ns)
6017	return false;
6018
6019	generate_local_decl (e->symtree->n.sym);
6020	return false;
6021	}
6022
6023	static void
6024	generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
6025	{
6026	gfc_traverse_expr (e, sym, expr_decls, 0);
6027	}
6028
6029
6030	/* Check for dependencies in the character length and array spec. */
6031
6032	static void
6033	generate_dependency_declarations (gfc_symbol *sym)
6034	{
6035	int i;
6036
6037	if (sym->ts.type == BT_CHARACTER
6038	&& sym->ts.u.cl
6039	&& sym->ts.u.cl->length
6040	&& sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6041	generate_expr_decls (sym, e: sym->ts.u.cl->length);
6042
6043	if (sym->as && sym->as->rank)
6044	{
6045	for (i = 0; i < sym->as->rank; i++)
6046	{
6047	generate_expr_decls (sym, e: sym->as->lower[i]);
6048	generate_expr_decls (sym, e: sym->as->upper[i]);
6049	}
6050	}
6051	}
6052
6053
6054	/* Generate decls for all local variables. We do this to ensure correct
6055	handling of expressions which only appear in the specification of
6056	other functions. */
6057
6058	static void
6059	generate_local_decl (gfc_symbol * sym)
6060	{
6061	if (sym->attr.flavor == FL_VARIABLE)
6062	{
6063	if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
6064	&& sym->attr.referenced && !sym->attr.use_assoc)
6065	has_coarray_vars = true;
6066
6067	if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
6068	generate_dependency_declarations (sym);
6069
6070	if (sym->attr.ext_attr & (1 << EXT_ATTR_WEAK))
6071	{
6072	if (sym->attr.dummy)
6073	gfc_error ("Symbol %qs at %L has the WEAK attribute but is a "
6074	"dummy argument", sym->name, &sym->declared_at);
6075	else
6076	gfc_error ("Symbol %qs at %L has the WEAK attribute but is a "
6077	"local variable", sym->name, &sym->declared_at);
6078	}
6079
6080	if (sym->attr.referenced)
6081	gfc_get_symbol_decl (sym);
6082
6083	/* Warnings for unused dummy arguments. */
6084	else if (sym->attr.dummy && !sym->attr.in_namelist)
6085	{
6086	/* INTENT(out) dummy arguments are likely meant to be set. */
6087	if (warn_unused_dummy_argument && sym->attr.intent == INTENT_OUT)
6088	{
6089	if (sym->ts.type != BT_DERIVED)
6090	gfc_warning (opt: OPT_Wunused_dummy_argument,
6091	"Dummy argument %qs at %L was declared "
6092	"INTENT(OUT) but was not set", sym->name,
6093	&sym->declared_at);
6094	else if (!gfc_has_default_initializer (sym->ts.u.derived)
6095	&& !sym->ts.u.derived->attr.zero_comp)
6096	gfc_warning (opt: OPT_Wunused_dummy_argument,
6097	"Derived-type dummy argument %qs at %L was "
6098	"declared INTENT(OUT) but was not set and "
6099	"does not have a default initializer",
6100	sym->name, &sym->declared_at);
6101	if (sym->backend_decl != NULL_TREE)
6102	suppress_warning (sym->backend_decl);
6103	}
6104	else if (warn_unused_dummy_argument)
6105	{
6106	if (!sym->attr.artificial)
6107	gfc_warning (opt: OPT_Wunused_dummy_argument,
6108	"Unused dummy argument %qs at %L", sym->name,
6109	&sym->declared_at);
6110
6111	if (sym->backend_decl != NULL_TREE)
6112	suppress_warning (sym->backend_decl);
6113	}
6114	}
6115
6116	/* Warn for unused variables, but not if they're inside a common
6117	block or a namelist. */
6118	else if (warn_unused_variable
6119	&& !(sym->attr.in_common || sym->mark || sym->attr.in_namelist))
6120	{
6121	if (sym->attr.use_only)
6122	{
6123	gfc_warning (opt: OPT_Wunused_variable,
6124	"Unused module variable %qs which has been "
6125	"explicitly imported at %L", sym->name,
6126	&sym->declared_at);
6127	if (sym->backend_decl != NULL_TREE)
6128	suppress_warning (sym->backend_decl);
6129	}
6130	else if (!sym->attr.use_assoc)
6131	{
6132	/* Corner case: the symbol may be an entry point. At this point,
6133	it may appear to be an unused variable. Suppress warning. */
6134	bool enter = false;
6135	gfc_entry_list *el;
6136
6137	for (el = sym->ns->entries; el; el=el->next)
6138	if (strcmp(s1: sym->name, s2: el->sym->name) == 0)
6139	enter = true;
6140
6141	if (!enter)
6142	gfc_warning (opt: OPT_Wunused_variable,
6143	"Unused variable %qs declared at %L",
6144	sym->name, &sym->declared_at);
6145	if (sym->backend_decl != NULL_TREE)
6146	suppress_warning (sym->backend_decl);
6147	}
6148	}
6149
6150	/* For variable length CHARACTER parameters, the PARM_DECL already
6151	references the length variable, so force gfc_get_symbol_decl
6152	even when not referenced. If optimize > 0, it will be optimized
6153	away anyway. But do this only after emitting -Wunused-parameter
6154	warning if requested. */
6155	if (sym->attr.dummy && !sym->attr.referenced
6156	&& sym->ts.type == BT_CHARACTER
6157	&& sym->ts.u.cl->backend_decl != NULL
6158	&& VAR_P (sym->ts.u.cl->backend_decl))
6159	{
6160	sym->attr.referenced = 1;
6161	gfc_get_symbol_decl (sym);
6162	}
6163
6164	/* INTENT(out) dummy arguments and result variables with allocatable
6165	components are reset by default and need to be set referenced to
6166	generate the code for nullification and automatic lengths. */
6167	if (!sym->attr.referenced
6168	&& sym->ts.type == BT_DERIVED
6169	&& sym->ts.u.derived->attr.alloc_comp
6170	&& !sym->attr.pointer
6171	&& ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
6172	||
6173	(sym->attr.result && sym != sym->result)))
6174	{
6175	sym->attr.referenced = 1;
6176	gfc_get_symbol_decl (sym);
6177	}
6178
6179	/* Check for dependencies in the array specification and string
6180	length, adding the necessary declarations to the function. We
6181	mark the symbol now, as well as in traverse_ns, to prevent
6182	getting stuck in a circular dependency. */
6183	sym->mark = 1;
6184	}
6185	else if (sym->attr.flavor == FL_PARAMETER)
6186	{
6187	if (warn_unused_parameter
6188	&& !sym->attr.referenced)
6189	{
6190	if (!sym->attr.use_assoc)
6191	gfc_warning (opt: OPT_Wunused_parameter,
6192	"Unused parameter %qs declared at %L", sym->name,
6193	&sym->declared_at);
6194	else if (sym->attr.use_only)
6195	gfc_warning (opt: OPT_Wunused_parameter,
6196	"Unused parameter %qs which has been explicitly "
6197	"imported at %L", sym->name, &sym->declared_at);
6198	}
6199
6200	if (sym->ns && sym->ns->construct_entities)
6201	{
6202	/* Construction of the intrinsic modules within a BLOCK
6203	construct, where ONLY and RENAMED entities are included,
6204	seems to be bogus. This is a workaround that can be removed
6205	if someone ever takes on the task to creating full-fledge
6206	modules. See PR 69455. */
6207	if (sym->attr.referenced
6208	&& sym->from_intmod != INTMOD_ISO_C_BINDING
6209	&& sym->from_intmod != INTMOD_ISO_FORTRAN_ENV)
6210	gfc_get_symbol_decl (sym);
6211	sym->mark = 1;
6212	}
6213	}
6214	else if (sym->attr.flavor == FL_PROCEDURE)
6215	{
6216	/* TODO: move to the appropriate place in resolve.cc. */
6217	if (warn_return_type > 0
6218	&& sym->attr.function
6219	&& sym->result
6220	&& sym != sym->result
6221	&& !sym->result->attr.referenced
6222	&& !sym->attr.use_assoc
6223	&& sym->attr.if_source != IFSRC_IFBODY)
6224	{
6225	gfc_warning (opt: OPT_Wreturn_type,
6226	"Return value %qs of function %qs declared at "
6227	"%L not set", sym->result->name, sym->name,
6228	&sym->result->declared_at);
6229
6230	/* Prevents "Unused variable" warning for RESULT variables. */
6231	sym->result->mark = 1;
6232	}
6233	}
6234
6235	if (sym->attr.dummy == 1)
6236	{
6237	/* The tree type for scalar character dummy arguments of BIND(C)
6238	procedures, if they are passed by value, should be unsigned char.
6239	The value attribute implies the dummy is a scalar. */
6240	if (sym->attr.value == 1 && sym->backend_decl != NULL
6241	&& sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
6242	&& sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
6243	{
6244	/* We used to modify the tree here. Now it is done earlier in
6245	the front-end, so we only check it here to avoid regressions. */
6246	gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE);
6247	gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1);
6248	gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE);
6249	gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0);
6250	}
6251
6252	/* Unused procedure passed as dummy argument. */
6253	if (sym->attr.flavor == FL_PROCEDURE)
6254	{
6255	if (!sym->attr.referenced && !sym->attr.artificial)
6256	{
6257	if (warn_unused_dummy_argument)
6258	gfc_warning (opt: OPT_Wunused_dummy_argument,
6259	"Unused dummy argument %qs at %L", sym->name,
6260	&sym->declared_at);
6261	}
6262
6263	/* Silence bogus "unused parameter" warnings from the
6264	middle end. */
6265	if (sym->backend_decl != NULL_TREE)
6266	suppress_warning (sym->backend_decl);
6267	}
6268	}
6269
6270	/* Make sure we convert the types of the derived types from iso_c_binding
6271	into (void *). */
6272	if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
6273	&& sym->ts.type == BT_DERIVED)
6274	sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
6275	}
6276
6277
6278	static void
6279	generate_local_nml_decl (gfc_symbol * sym)
6280	{
6281	if (sym->attr.flavor == FL_NAMELIST && !sym->attr.use_assoc)
6282	{
6283	tree decl = generate_namelist_decl (sym);
6284	pushdecl (decl);
6285	}
6286	}
6287
6288
6289	static void
6290	generate_local_vars (gfc_namespace * ns)
6291	{
6292	gfc_traverse_ns (ns, generate_local_decl);
6293	gfc_traverse_ns (ns, generate_local_nml_decl);
6294	}
6295
6296
6297	/* Generate a switch statement to jump to the correct entry point. Also
6298	creates the label decls for the entry points. */
6299
6300	static tree
6301	gfc_trans_entry_master_switch (gfc_entry_list * el)
6302	{
6303	stmtblock_t block;
6304	tree label;
6305	tree tmp;
6306	tree val;
6307
6308	gfc_init_block (&block);
6309	for (; el; el = el->next)
6310	{
6311	/* Add the case label. */
6312	label = gfc_build_label_decl (NULL_TREE);
6313	val = build_int_cst (gfc_array_index_type, el->id);
6314	tmp = build_case_label (val, NULL_TREE, label);
6315	gfc_add_expr_to_block (&block, tmp);
6316
6317	/* And jump to the actual entry point. */
6318	label = gfc_build_label_decl (NULL_TREE);
6319	tmp = build1_v (GOTO_EXPR, label);
6320	gfc_add_expr_to_block (&block, tmp);
6321
6322	/* Save the label decl. */
6323	el->label = label;
6324	}
6325	tmp = gfc_finish_block (&block);
6326	/* The first argument selects the entry point. */
6327	val = DECL_ARGUMENTS (current_function_decl);
6328	tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, val, tmp);
6329	return tmp;
6330	}
6331
6332
6333	/* Add code to string lengths of actual arguments passed to a function against
6334	the expected lengths of the dummy arguments. */
6335
6336	static void
6337	add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
6338	{
6339	gfc_formal_arglist *formal;
6340
6341	for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
6342	if (formal->sym && formal->sym->ts.type == BT_CHARACTER
6343	&& !formal->sym->ts.deferred)
6344	{
6345	enum tree_code comparison;
6346	tree cond;
6347	tree argname;
6348	gfc_symbol *fsym;
6349	gfc_charlen *cl;
6350	const char *message;
6351
6352	fsym = formal->sym;
6353	cl = fsym->ts.u.cl;
6354
6355	gcc_assert (cl);
6356	gcc_assert (cl->passed_length != NULL_TREE);
6357	gcc_assert (cl->backend_decl != NULL_TREE);
6358
6359	/* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
6360	string lengths must match exactly. Otherwise, it is only required
6361	that the actual string length is *at least* the expected one.
6362	Sequence association allows for a mismatch of the string length
6363	if the actual argument is (part of) an array, but only if the
6364	dummy argument is an array. (See "Sequence association" in
6365	Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
6366	if (fsym->attr.pointer || fsym->attr.allocatable
6367	|| (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE
6368	|| fsym->as->type == AS_ASSUMED_RANK)))
6369	{
6370	comparison = NE_EXPR;
6371	message = _("Actual string length does not match the declared one"
6372	" for dummy argument '%s' (%ld/%ld)");
6373	}
6374	else if (fsym->as && fsym->as->rank != 0)
6375	continue;
6376	else
6377	{
6378	comparison = LT_EXPR;
6379	message = _("Actual string length is shorter than the declared one"
6380	" for dummy argument '%s' (%ld/%ld)");
6381	}
6382
6383	/* Build the condition. For optional arguments, an actual length
6384	of 0 is also acceptable if the associated string is NULL, which
6385	means the argument was not passed. */
6386	cond = fold_build2_loc (input_location, comparison, logical_type_node,
6387	cl->passed_length, cl->backend_decl);
6388	if (fsym->attr.optional)
6389	{
6390	tree not_absent;
6391	tree not_0length;
6392	tree absent_failed;
6393
6394	not_0length = fold_build2_loc (input_location, NE_EXPR,
6395	logical_type_node,
6396	cl->passed_length,
6397	build_zero_cst
6398	(TREE_TYPE (cl->passed_length)));
6399	/* The symbol needs to be referenced for gfc_get_symbol_decl. */
6400	fsym->attr.referenced = 1;
6401	not_absent = gfc_conv_expr_present (fsym);
6402
6403	absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6404	logical_type_node, not_0length,
6405	not_absent);
6406
6407	cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6408	logical_type_node, cond, absent_failed);
6409	}
6410
6411	/* Build the runtime check. */
6412	argname = gfc_build_cstring_const (fsym->name);
6413	argname = gfc_build_addr_expr (pchar_type_node, argname);
6414	gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
6415	message, argname,
6416	fold_convert (long_integer_type_node,
6417	cl->passed_length),
6418	fold_convert (long_integer_type_node,
6419	cl->backend_decl));
6420	}
6421	}
6422
6423
6424	static void
6425	create_main_function (tree fndecl)
6426	{
6427	tree old_context;
6428	tree ftn_main;
6429	tree tmp, decl, result_decl, argc, argv, typelist, arglist;
6430	stmtblock_t body;
6431
6432	old_context = current_function_decl;
6433
6434	if (old_context)
6435	{
6436	push_function_context ();
6437	saved_parent_function_decls = saved_function_decls;
6438	saved_function_decls = NULL_TREE;
6439	}
6440
6441	/* main() function must be declared with global scope. */
6442	gcc_assert (current_function_decl == NULL_TREE);
6443
6444	/* Declare the function. */
6445	tmp = build_function_type_list (integer_type_node, integer_type_node,
6446	build_pointer_type (pchar_type_node),
6447	NULL_TREE);
6448	main_identifier_node = get_identifier ("main");
6449	ftn_main = build_decl (input_location, FUNCTION_DECL,
6450	main_identifier_node, tmp);
6451	DECL_EXTERNAL (ftn_main) = 0;
6452	TREE_PUBLIC (ftn_main) = 1;
6453	TREE_STATIC (ftn_main) = 1;
6454	DECL_ATTRIBUTES (ftn_main)
6455	= tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
6456
6457	/* Setup the result declaration (for "return 0"). */
6458	result_decl = build_decl (input_location,
6459	RESULT_DECL, NULL_TREE, integer_type_node);
6460	DECL_ARTIFICIAL (result_decl) = 1;
6461	DECL_IGNORED_P (result_decl) = 1;
6462	DECL_CONTEXT (result_decl) = ftn_main;
6463	DECL_RESULT (ftn_main) = result_decl;
6464
6465	pushdecl (ftn_main);
6466
6467	/* Get the arguments. */
6468
6469	arglist = NULL_TREE;
6470	typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
6471
6472	tmp = TREE_VALUE (typelist);
6473	argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
6474	DECL_CONTEXT (argc) = ftn_main;
6475	DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
6476	TREE_READONLY (argc) = 1;
6477	gfc_finish_decl (decl: argc);
6478	arglist = chainon (arglist, argc);
6479
6480	typelist = TREE_CHAIN (typelist);
6481	tmp = TREE_VALUE (typelist);
6482	argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
6483	DECL_CONTEXT (argv) = ftn_main;
6484	DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
6485	TREE_READONLY (argv) = 1;
6486	DECL_BY_REFERENCE (argv) = 1;
6487	gfc_finish_decl (decl: argv);
6488	arglist = chainon (arglist, argv);
6489
6490	DECL_ARGUMENTS (ftn_main) = arglist;
6491	current_function_decl = ftn_main;
6492	announce_function (ftn_main);
6493
6494	rest_of_decl_compilation (ftn_main, 1, 0);
6495	make_decl_rtl (ftn_main);
6496	allocate_struct_function (ftn_main, false);
6497	pushlevel ();
6498
6499	gfc_init_block (&body);
6500
6501	/* Call some libgfortran initialization routines, call then MAIN__(). */
6502
6503	/* Call _gfortran_caf_init (*argc, ***argv). */
6504	if (flag_coarray == GFC_FCOARRAY_LIB)
6505	{
6506	tree pint_type, pppchar_type;
6507	pint_type = build_pointer_type (integer_type_node);
6508	pppchar_type
6509	= build_pointer_type (build_pointer_type (pchar_type_node));
6510
6511	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 2,
6512	gfc_build_addr_expr (pint_type, argc),
6513	gfc_build_addr_expr (pppchar_type, argv));
6514	gfc_add_expr_to_block (&body, tmp);
6515	}
6516
6517	/* Call _gfortran_set_args (argc, argv). */
6518	TREE_USED (argc) = 1;
6519	TREE_USED (argv) = 1;
6520	tmp = build_call_expr_loc (input_location,
6521	gfor_fndecl_set_args, 2, argc, argv);
6522	gfc_add_expr_to_block (&body, tmp);
6523
6524	/* Add a call to set_options to set up the runtime library Fortran
6525	language standard parameters. */
6526	{
6527	tree array_type, array, var;
6528	vec<constructor_elt, va_gc> *v = NULL;
6529	static const int noptions = 7;
6530
6531	/* Passing a new option to the library requires three modifications:
6532	+ add it to the tree_cons list below
6533	+ change the noptions variable above
6534	+ modify the library (runtime/compile_options.c)! */
6535
6536	CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6537	build_int_cst (integer_type_node,
6538	gfc_option.warn_std));
6539	CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6540	build_int_cst (integer_type_node,
6541	gfc_option.allow_std));
6542	CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6543	build_int_cst (integer_type_node, pedantic));
6544	CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6545	build_int_cst (integer_type_node, flag_backtrace));
6546	CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6547	build_int_cst (integer_type_node, flag_sign_zero));
6548	CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6549	build_int_cst (integer_type_node,
6550	(gfc_option.rtcheck
6551	& GFC_RTCHECK_BOUNDS)));
6552	CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6553	build_int_cst (integer_type_node,
6554	gfc_option.fpe_summary));
6555
6556	array_type = build_array_type_nelts (integer_type_node, noptions);
6557	array = build_constructor (array_type, v);
6558	TREE_CONSTANT (array) = 1;
6559	TREE_STATIC (array) = 1;
6560
6561	/* Create a static variable to hold the jump table. */
6562	var = build_decl (input_location, VAR_DECL,
6563	create_tmp_var_name ("options"), array_type);
6564	DECL_ARTIFICIAL (var) = 1;
6565	DECL_IGNORED_P (var) = 1;
6566	TREE_CONSTANT (var) = 1;
6567	TREE_STATIC (var) = 1;
6568	TREE_READONLY (var) = 1;
6569	DECL_INITIAL (var) = array;
6570	pushdecl (var);
6571	var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
6572
6573	tmp = build_call_expr_loc (input_location,
6574	gfor_fndecl_set_options, 2,
6575	build_int_cst (integer_type_node, noptions), var);
6576	gfc_add_expr_to_block (&body, tmp);
6577	}
6578
6579	/* If -ffpe-trap option was provided, add a call to set_fpe so that
6580	the library will raise a FPE when needed. */
6581	if (gfc_option.fpe != 0)
6582	{
6583	tmp = build_call_expr_loc (input_location,
6584	gfor_fndecl_set_fpe, 1,
6585	build_int_cst (integer_type_node,
6586	gfc_option.fpe));
6587	gfc_add_expr_to_block (&body, tmp);
6588	}
6589
6590	/* If this is the main program and an -fconvert option was provided,
6591	add a call to set_convert. */
6592
6593	if (flag_convert != GFC_FLAG_CONVERT_NATIVE)
6594	{
6595	tmp = build_call_expr_loc (input_location,
6596	gfor_fndecl_set_convert, 1,
6597	build_int_cst (integer_type_node, flag_convert));
6598	gfc_add_expr_to_block (&body, tmp);
6599	}
6600
6601	/* If this is the main program and an -frecord-marker option was provided,
6602	add a call to set_record_marker. */
6603
6604	if (flag_record_marker != 0)
6605	{
6606	tmp = build_call_expr_loc (input_location,
6607	gfor_fndecl_set_record_marker, 1,
6608	build_int_cst (integer_type_node,
6609	flag_record_marker));
6610	gfc_add_expr_to_block (&body, tmp);
6611	}
6612
6613	if (flag_max_subrecord_length != 0)
6614	{
6615	tmp = build_call_expr_loc (input_location,
6616	gfor_fndecl_set_max_subrecord_length, 1,
6617	build_int_cst (integer_type_node,
6618	flag_max_subrecord_length));
6619	gfc_add_expr_to_block (&body, tmp);
6620	}
6621
6622	/* Call MAIN__(). */
6623	tmp = build_call_expr_loc (input_location,
6624	fndecl, 0);
6625	gfc_add_expr_to_block (&body, tmp);
6626
6627	/* Mark MAIN__ as used. */
6628	TREE_USED (fndecl) = 1;
6629
6630	/* Coarray: Call _gfortran_caf_finalize(void). */
6631	if (flag_coarray == GFC_FCOARRAY_LIB)
6632	{
6633	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
6634	gfc_add_expr_to_block (&body, tmp);
6635	}
6636
6637	/* "return 0". */
6638	tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
6639	DECL_RESULT (ftn_main),
6640	integer_zero_node);
6641	tmp = build1_v (RETURN_EXPR, tmp);
6642	gfc_add_expr_to_block (&body, tmp);
6643
6644
6645	DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
6646	decl = getdecls ();
6647
6648	/* Finish off this function and send it for code generation. */
6649	poplevel (1, 1);
6650	BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
6651
6652	DECL_SAVED_TREE (ftn_main)
6653	= fold_build3_loc (DECL_SOURCE_LOCATION (ftn_main), BIND_EXPR,
6654	void_type_node, decl, DECL_SAVED_TREE (ftn_main),
6655	DECL_INITIAL (ftn_main));
6656
6657	/* Output the GENERIC tree. */
6658	dump_function (phase: TDI_original, fn: ftn_main);
6659
6660	cgraph_node::finalize_function (ftn_main, true);
6661
6662	if (old_context)
6663	{
6664	pop_function_context ();
6665	saved_function_decls = saved_parent_function_decls;
6666	}
6667	current_function_decl = old_context;
6668	}
6669
6670
6671	/* Generate an appropriate return-statement for a procedure. */
6672
6673	tree
6674	gfc_generate_return (void)
6675	{
6676	gfc_symbol* sym;
6677	tree result;
6678	tree fndecl;
6679
6680	sym = current_procedure_symbol;
6681	fndecl = sym->backend_decl;
6682
6683	if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
6684	result = NULL_TREE;
6685	else
6686	{
6687	result = get_proc_result (sym);
6688
6689	/* Set the return value to the dummy result variable. The
6690	types may be different for scalar default REAL functions
6691	with -ff2c, therefore we have to convert. */
6692	if (result != NULL_TREE)
6693	{
6694	result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
6695	result = fold_build2_loc (input_location, MODIFY_EXPR,
6696	TREE_TYPE (result), DECL_RESULT (fndecl),
6697	result);
6698	}
6699	else
6700	{
6701	/* If the function does not have a result variable, result is
6702	NULL_TREE, and a 'return' is generated without a variable.
6703	The following generates a 'return __result_XXX' where XXX is
6704	the function name. */
6705	if (sym == sym->result && sym->attr.function && !flag_f2c)
6706	{
6707	result = gfc_get_fake_result_decl (sym, parent_flag: 0);
6708	result = fold_build2_loc (input_location, MODIFY_EXPR,
6709	TREE_TYPE (result),
6710	DECL_RESULT (fndecl), result);
6711	}
6712	}
6713	}
6714
6715	return build1_v (RETURN_EXPR, result);
6716	}
6717
6718
6719	static void
6720	is_from_ieee_module (gfc_symbol *sym)
6721	{
6722	if (sym->from_intmod == INTMOD_IEEE_FEATURES
6723	|| sym->from_intmod == INTMOD_IEEE_EXCEPTIONS
6724	|| sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
6725	seen_ieee_symbol = 1;
6726	}
6727
6728
6729	static int
6730	is_ieee_module_used (gfc_namespace *ns)
6731	{
6732	seen_ieee_symbol = 0;
6733	gfc_traverse_ns (ns, is_from_ieee_module);
6734	return seen_ieee_symbol;
6735	}
6736
6737
6738	static gfc_omp_clauses *module_oacc_clauses;
6739
6740
6741	static void
6742	add_clause (gfc_symbol *sym, gfc_omp_map_op map_op)
6743	{
6744	gfc_omp_namelist *n;
6745
6746	n = gfc_get_omp_namelist ();
6747	n->sym = sym;
6748	n->u.map.op = map_op;
6749
6750	if (!module_oacc_clauses)
6751	module_oacc_clauses = gfc_get_omp_clauses ();
6752
6753	if (module_oacc_clauses->lists[OMP_LIST_MAP])
6754	n->next = module_oacc_clauses->lists[OMP_LIST_MAP];
6755
6756	module_oacc_clauses->lists[OMP_LIST_MAP] = n;
6757	}
6758
6759
6760	static void
6761	find_module_oacc_declare_clauses (gfc_symbol *sym)
6762	{
6763	if (sym->attr.use_assoc)
6764	{
6765	gfc_omp_map_op map_op;
6766
6767	if (sym->attr.oacc_declare_create)
6768	map_op = OMP_MAP_FORCE_ALLOC;
6769
6770	if (sym->attr.oacc_declare_copyin)
6771	map_op = OMP_MAP_FORCE_TO;
6772
6773	if (sym->attr.oacc_declare_deviceptr)
6774	map_op = OMP_MAP_FORCE_DEVICEPTR;
6775
6776	if (sym->attr.oacc_declare_device_resident)
6777	map_op = OMP_MAP_DEVICE_RESIDENT;
6778
6779	if (sym->attr.oacc_declare_create
6780	|| sym->attr.oacc_declare_copyin
6781	|| sym->attr.oacc_declare_deviceptr
6782	|| sym->attr.oacc_declare_device_resident)
6783	{
6784	sym->attr.referenced = 1;
6785	add_clause (sym, map_op);
6786	}
6787	}
6788	}
6789
6790
6791	void
6792	finish_oacc_declare (gfc_namespace *ns, gfc_symbol *sym, bool block)
6793	{
6794	gfc_code *code;
6795	gfc_oacc_declare *oc;
6796	locus where = gfc_current_locus;
6797	gfc_omp_clauses *omp_clauses = NULL;
6798	gfc_omp_namelist *n, *p;
6799
6800	module_oacc_clauses = NULL;
6801	gfc_traverse_ns (ns, find_module_oacc_declare_clauses);
6802
6803	if (module_oacc_clauses && sym->attr.flavor == FL_PROGRAM)
6804	{
6805	gfc_oacc_declare *new_oc;
6806
6807	new_oc = gfc_get_oacc_declare ();
6808	new_oc->next = ns->oacc_declare;
6809	new_oc->clauses = module_oacc_clauses;
6810
6811	ns->oacc_declare = new_oc;
6812	}
6813
6814	if (!ns->oacc_declare)
6815	return;
6816
6817	for (oc = ns->oacc_declare; oc; oc = oc->next)
6818	{
6819	if (oc->module_var)
6820	continue;
6821
6822	if (block)
6823	gfc_error ("Sorry, !$ACC DECLARE at %L is not allowed "
6824	"in BLOCK construct", &oc->loc);
6825
6826
6827	if (oc->clauses && oc->clauses->lists[OMP_LIST_MAP])
6828	{
6829	if (omp_clauses == NULL)
6830	{
6831	omp_clauses = oc->clauses;
6832	continue;
6833	}
6834
6835	for (n = oc->clauses->lists[OMP_LIST_MAP]; n; p = n, n = n->next)
6836	;
6837
6838	gcc_assert (p->next == NULL);
6839
6840	p->next = omp_clauses->lists[OMP_LIST_MAP];
6841	omp_clauses = oc->clauses;
6842	}
6843	}
6844
6845	if (!omp_clauses)
6846	return;
6847
6848	for (n = omp_clauses->lists[OMP_LIST_MAP]; n; n = n->next)
6849	{
6850	switch (n->u.map.op)
6851	{
6852	case OMP_MAP_DEVICE_RESIDENT:
6853	n->u.map.op = OMP_MAP_FORCE_ALLOC;
6854	break;
6855
6856	default:
6857	break;
6858	}
6859	}
6860
6861	code = XCNEW (gfc_code);
6862	code->op = EXEC_OACC_DECLARE;
6863	code->loc = where;
6864
6865	code->ext.oacc_declare = gfc_get_oacc_declare ();
6866	code->ext.oacc_declare->clauses = omp_clauses;
6867
6868	code->block = XCNEW (gfc_code);
6869	code->block->op = EXEC_OACC_DECLARE;
6870	code->block->loc = where;
6871
6872	if (ns->code)
6873	code->block->next = ns->code;
6874
6875	ns->code = code;
6876
6877	return;
6878	}
6879
6880	static void
6881	gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally,
6882	tree cfi_desc, tree gfc_desc, gfc_symbol *sym)
6883	{
6884	stmtblock_t block;
6885	gfc_init_block (&block);
6886	tree cfi = build_fold_indirect_ref_loc (input_location, cfi_desc);
6887	tree idx, etype, tmp, tmp2, size_var = NULL_TREE, rank = NULL_TREE;
6888	bool do_copy_inout = false;
6889
6890	/* When allocatable + intent out, free the cfi descriptor. */
6891	if (sym->attr.allocatable && sym->attr.intent == INTENT_OUT)
6892	{
6893	tmp = gfc_get_cfi_desc_base_addr (cfi);
6894	tree call = builtin_decl_explicit (fncode: BUILT_IN_FREE);
6895	call = build_call_expr_loc (input_location, call, 1, tmp);
6896	gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
6897	gfc_add_modify (&block, tmp,
6898	fold_convert (TREE_TYPE (tmp), null_pointer_node));
6899	}
6900
6901	/* -fcheck=bound: Do version, rank, attribute, type and is-NULL checks. */
6902	if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
6903	{
6904	char *msg;
6905	tree tmp3;
6906	msg = xasprintf ("Unexpected version %%d (expected %d) in CFI descriptor "
6907	"passed to dummy argument %s", CFI_VERSION, sym->name);
6908	tmp2 = gfc_get_cfi_desc_version (cfi);
6909	tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2,
6910	build_int_cst (TREE_TYPE (tmp2), CFI_VERSION));
6911	gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
6912	msg, tmp2);
6913	free (ptr: msg);
6914
6915	/* Rank check; however, for character(len=*), assumed/explicit-size arrays
6916	are permitted to differ in rank according to the Fortran rules. */
6917	if (sym->as && sym->as->type != AS_ASSUMED_SIZE
6918	&& sym->as->type != AS_EXPLICIT)
6919	{
6920	if (sym->as->rank != -1)
6921	msg = xasprintf ("Invalid rank %%d (expected %d) in CFI descriptor "
6922	"passed to dummy argument %s", sym->as->rank,
6923	sym->name);
6924	else
6925	msg = xasprintf ("Invalid rank %%d (expected 0..%d) in CFI "
6926	"descriptor passed to dummy argument %s",
6927	CFI_MAX_RANK, sym->name);
6928
6929	tmp3 = tmp2 = tmp = gfc_get_cfi_desc_rank (cfi);
6930	if (sym->as->rank != -1)
6931	tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6932	tmp, build_int_cst (signed_char_type_node,
6933	sym->as->rank));
6934	else
6935	{
6936	tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
6937	tmp, build_zero_cst (TREE_TYPE (tmp)));
6938	tmp2 = fold_build2_loc (input_location, GT_EXPR,
6939	boolean_type_node, tmp2,
6940	build_int_cst (TREE_TYPE (tmp2),
6941	CFI_MAX_RANK));
6942	tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6943	boolean_type_node, tmp, tmp2);
6944	}
6945	gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
6946	msg, tmp3);
6947	free (ptr: msg);
6948	}
6949
6950	tmp3 = tmp = gfc_get_cfi_desc_attribute (cfi);
6951	if (sym->attr.allocatable || sym->attr.pointer)
6952	{
6953	int attr = (sym->attr.pointer ? CFI_attribute_pointer
6954	: CFI_attribute_allocatable);
6955	msg = xasprintf ("Invalid attribute %%d (expected %d) in CFI "
6956	"descriptor passed to dummy argument %s with %s "
6957	"attribute", attr, sym->name,
6958	sym->attr.pointer ? "pointer" : "allocatable");
6959	tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6960	tmp, build_int_cst (TREE_TYPE (tmp), attr));
6961	}
6962	else
6963	{
6964	int amin = MIN (CFI_attribute_pointer,
6965	MIN (CFI_attribute_allocatable, CFI_attribute_other));
6966	int amax = MAX (CFI_attribute_pointer,
6967	MAX (CFI_attribute_allocatable, CFI_attribute_other));
6968	msg = xasprintf ("Invalid attribute %%d (expected %d..%d) in CFI "
6969	"descriptor passed to nonallocatable, nonpointer "
6970	"dummy argument %s", amin, amax, sym->name);
6971	tmp2 = tmp;
6972	tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, tmp,
6973	build_int_cst (TREE_TYPE (tmp), amin));
6974	tmp2 = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp2,
6975	build_int_cst (TREE_TYPE (tmp2), amax));
6976	tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6977	boolean_type_node, tmp, tmp2);
6978	gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
6979	msg, tmp3);
6980	free (ptr: msg);
6981	msg = xasprintf ("Invalid unallocatated/unassociated CFI "
6982	"descriptor passed to nonallocatable, nonpointer "
6983	"dummy argument %s", sym->name);
6984	tmp3 = tmp = gfc_get_cfi_desc_base_addr (cfi),
6985	tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6986	tmp, null_pointer_node);
6987	}
6988	gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
6989	msg, tmp3);
6990	free (ptr: msg);
6991
6992	if (sym->ts.type != BT_ASSUMED)
6993	{
6994	int type = CFI_type_other;
6995	if (sym->ts.f90_type == BT_VOID)
6996	{
6997	type = (sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6998	? CFI_type_cfunptr : CFI_type_cptr);
6999	}
7000	else
7001	switch (sym->ts.type)
7002	{
7003	case BT_INTEGER:
7004	case BT_LOGICAL:
7005	case BT_REAL:
7006	case BT_COMPLEX:
7007	type = CFI_type_from_type_kind (sym->ts.type, sym->ts.kind);
7008	break;
7009	case BT_CHARACTER:
7010	type = CFI_type_from_type_kind (CFI_type_Character,
7011	sym->ts.kind);
7012	break;
7013	case BT_DERIVED:
7014	type = CFI_type_struct;
7015	break;
7016	case BT_VOID:
7017	type = (sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
7018	? CFI_type_cfunptr : CFI_type_cptr);
7019	break;
7020	case BT_ASSUMED:
7021	case BT_CLASS:
7022	case BT_PROCEDURE:
7023	case BT_HOLLERITH:
7024	case BT_UNION:
7025	case BT_BOZ:
7026	case BT_UNKNOWN:
7027	gcc_unreachable ();
7028	}
7029	msg = xasprintf ("Unexpected type %%d (expected %d) in CFI descriptor"
7030	" passed to dummy argument %s", type, sym->name);
7031	tmp2 = tmp = gfc_get_cfi_desc_type (cfi);
7032	tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7033	tmp, build_int_cst (TREE_TYPE (tmp), type));
7034	gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
7035	msg, tmp2);
7036	free (ptr: msg);
7037	}
7038	}
7039
7040	if (!sym->attr.referenced)
7041	goto done;
7042
7043	/* Set string length for len=* and len=:, otherwise, it is already set. */
7044	if (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length)
7045	{
7046	tmp = fold_convert (gfc_array_index_type,
7047	gfc_get_cfi_desc_elem_len (cfi));
7048	if (sym->ts.kind != 1)
7049	tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
7050	gfc_array_index_type, tmp,
7051	build_int_cst (gfc_charlen_type_node,
7052	sym->ts.kind));
7053	gfc_add_modify (&block, sym->ts.u.cl->backend_decl, tmp);
7054	}
7055
7056	if (sym->ts.type == BT_CHARACTER
7057	&& !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7058	{
7059	gfc_conv_string_length (sym->ts.u.cl, NULL, init);
7060	gfc_trans_vla_type_sizes (sym, body: init);
7061	}
7062
7063	/* gfc->data = cfi->base_addr - or for scalars: gfc = cfi->base_addr.
7064	assumed-size/explicit-size arrays end up here for character(len=*)
7065	only. */
7066	if (!sym->attr.dimension || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
7067	{
7068	tmp = gfc_get_cfi_desc_base_addr (cfi);
7069	gfc_add_modify (&block, gfc_desc,
7070	fold_convert (TREE_TYPE (gfc_desc), tmp));
7071	if (!sym->attr.dimension)
7072	goto done;
7073	}
7074
7075	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
7076	{
7077	/* gfc->dtype = ... (from declaration, not from cfi). */
7078	etype = gfc_get_element_type (TREE_TYPE (gfc_desc));
7079	gfc_add_modify (&block, gfc_conv_descriptor_dtype (gfc_desc),
7080	gfc_get_dtype_rank_type (sym->as->rank, etype));
7081	/* gfc->data = cfi->base_addr. */
7082	gfc_conv_descriptor_data_set (&block, gfc_desc,
7083	gfc_get_cfi_desc_base_addr (cfi));
7084	}
7085
7086	if (sym->ts.type == BT_ASSUMED)
7087	{
7088	/* For type(*), take elem_len + dtype.type from the actual argument. */
7089	gfc_add_modify (&block, gfc_conv_descriptor_elem_len (gfc_desc),
7090	gfc_get_cfi_desc_elem_len (cfi));
7091	tree cond;
7092	tree ctype = gfc_get_cfi_desc_type (cfi);
7093	ctype = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (ctype),
7094	ctype, build_int_cst (TREE_TYPE (ctype),
7095	CFI_type_mask));
7096	tree type = gfc_conv_descriptor_type (gfc_desc);
7097
7098	/* if (CFI_type_cptr) BT_VOID else BT_UNKNOWN */
7099	/* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
7100	cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
7101	build_int_cst (TREE_TYPE (ctype), CFI_type_cptr));
7102	tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
7103	build_int_cst (TREE_TYPE (type), BT_VOID));
7104	tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7105	type,
7106	build_int_cst (TREE_TYPE (type), BT_UNKNOWN));
7107	tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
7108	tmp, tmp2);
7109	/* if (CFI_type_struct) BT_DERIVED else < tmp2 > */
7110	cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
7111	build_int_cst (TREE_TYPE (ctype),
7112	CFI_type_struct));
7113	tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
7114	build_int_cst (TREE_TYPE (type), BT_DERIVED));
7115	tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
7116	tmp, tmp2);
7117	/* if (CFI_type_Character) BT_CHARACTER else < tmp2 > */
7118	/* Note: this is kind=1, CFI_type_ucs4_char is handled in the 'else if'
7119	before (see below, as generated bottom up). */
7120	cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
7121	build_int_cst (TREE_TYPE (ctype),
7122	CFI_type_Character));
7123	tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
7124	build_int_cst (TREE_TYPE (type), BT_CHARACTER));
7125	tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
7126	tmp, tmp2);
7127	/* if (CFI_type_ucs4_char) BT_CHARACTER else < tmp2 > */
7128	/* Note: gfc->elem_len = cfi->elem_len/4. */
7129	/* However, assuming that CFI_type_ucs4_char cannot be recovered, leave
7130	gfc->elem_len == cfi->elem_len, which helps with operations which use
7131	sizeof() in Fortran and cfi->elem_len in C. */
7132	tmp = gfc_get_cfi_desc_type (cfi);
7133	cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
7134	build_int_cst (TREE_TYPE (tmp),
7135	CFI_type_ucs4_char));
7136	tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
7137	build_int_cst (TREE_TYPE (type), BT_CHARACTER));
7138	tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
7139	tmp, tmp2);
7140	/* if (CFI_type_Complex) BT_COMPLEX + cfi->elem_len/2 else < tmp2 > */
7141	cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
7142	build_int_cst (TREE_TYPE (ctype),
7143	CFI_type_Complex));
7144	tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
7145	build_int_cst (TREE_TYPE (type), BT_COMPLEX));
7146	tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
7147	tmp, tmp2);
7148	/* if (CFI_type_Integer || CFI_type_Logical || CFI_type_Real)
7149	ctype else <tmp2> */
7150	cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
7151	build_int_cst (TREE_TYPE (ctype),
7152	CFI_type_Integer));
7153	tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
7154	build_int_cst (TREE_TYPE (ctype),
7155	CFI_type_Logical));
7156	cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
7157	cond, tmp);
7158	tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
7159	build_int_cst (TREE_TYPE (ctype),
7160	CFI_type_Real));
7161	cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
7162	cond, tmp);
7163	tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7164	type, fold_convert (TREE_TYPE (type), ctype));
7165	tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
7166	tmp, tmp2);
7167	gfc_add_expr_to_block (&block, tmp2);
7168	}
7169
7170	if (sym->as->rank < 0)
7171	{
7172	/* Set gfc->dtype.rank, if assumed-rank. */
7173	rank = gfc_get_cfi_desc_rank (cfi);
7174	gfc_add_modify (&block, gfc_conv_descriptor_rank (gfc_desc), rank);
7175	}
7176	else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
7177	/* In that case, the CFI rank and the declared rank can differ. */
7178	rank = gfc_get_cfi_desc_rank (cfi);
7179	else
7180	rank = build_int_cst (signed_char_type_node, sym->as->rank);
7181
7182	/* With bind(C), the standard requires that both Fortran callers and callees
7183	handle noncontiguous arrays passed to an dummy with 'contiguous' attribute
7184	and with character(len=*) + assumed-size/explicit-size arrays.
7185	cf. Fortran 2018, 18.3.6, paragraph 5 (and for the caller: para. 6). */
7186	if ((sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length
7187	&& (sym->as->type == AS_ASSUMED_SIZE || sym->as->type == AS_EXPLICIT))
7188	|| sym->attr.contiguous)
7189	{
7190	do_copy_inout = true;
7191	gcc_assert (!sym->attr.pointer);
7192	stmtblock_t block2;
7193	tree data;
7194	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
7195	data = gfc_conv_descriptor_data_get (gfc_desc);
7196	else if (!POINTER_TYPE_P (TREE_TYPE (gfc_desc)))
7197	data = gfc_build_addr_expr (NULL, gfc_desc);
7198	else
7199	data = gfc_desc;
7200
7201	/* Is copy-in/out needed? */
7202	/* do_copyin = rank != 0 && !assumed-size */
7203	tree cond_var = gfc_create_var (boolean_type_node, "do_copyin");
7204	tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7205	rank, build_zero_cst (TREE_TYPE (rank)));
7206	/* dim[rank-1].extent != -1 -> assumed size*/
7207	tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (rank),
7208	rank, build_int_cst (TREE_TYPE (rank), 1));
7209	tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7210	gfc_get_cfi_dim_extent (cfi, tmp),
7211	build_int_cst (gfc_array_index_type, -1));
7212	cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
7213	boolean_type_node, cond, tmp);
7214	gfc_add_modify (&block, cond_var, cond);
7215	/* if (do_copyin) do_copyin = ... || ... || ... */
7216	gfc_init_block (&block2);
7217	/* dim[0].sm != elem_len */
7218	tmp = fold_convert (gfc_array_index_type,
7219	gfc_get_cfi_desc_elem_len (cfi));
7220	cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7221	gfc_get_cfi_dim_sm (cfi, gfc_index_zero_node),
7222	tmp);
7223	gfc_add_modify (&block2, cond_var, cond);
7224
7225	/* for (i = 1; i < rank; ++i)
7226	cond &&= dim[i].sm != (dv->dim[i - 1].sm * dv->dim[i - 1].extent) */
7227	idx = gfc_create_var (TREE_TYPE (rank), "idx");
7228	stmtblock_t loop_body;
7229	gfc_init_block (&loop_body);
7230	tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (idx),
7231	idx, build_int_cst (TREE_TYPE (idx), 1));
7232	tree tmp2 = gfc_get_cfi_dim_sm (cfi, tmp);
7233	tmp = gfc_get_cfi_dim_extent (cfi, tmp);
7234	tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
7235	tmp2, tmp);
7236	cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7237	gfc_get_cfi_dim_sm (cfi, idx), tmp);
7238	cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
7239	cond_var, cond);
7240	gfc_add_modify (&loop_body, cond_var, cond);
7241	gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 1),
7242	rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
7243	gfc_finish_block (&loop_body));
7244	tmp = build3_v (COND_EXPR, cond_var, gfc_finish_block (&block2),
7245	build_empty_stmt (input_location));
7246	gfc_add_expr_to_block (&block, tmp);
7247
7248	/* Copy-in body. */
7249	gfc_init_block (&block2);
7250	/* size = dim[0].extent; for (i = 1; i < rank; ++i) size *= dim[i].extent */
7251	size_var = gfc_create_var (size_type_node, "size");
7252	tmp = fold_convert (size_type_node,
7253	gfc_get_cfi_dim_extent (cfi, gfc_index_zero_node));
7254	gfc_add_modify (&block2, size_var, tmp);
7255
7256	gfc_init_block (&loop_body);
7257	tmp = fold_convert (size_type_node,
7258	gfc_get_cfi_dim_extent (cfi, idx));
7259	tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
7260	size_var, fold_convert (size_type_node, tmp));
7261	gfc_add_modify (&loop_body, size_var, tmp);
7262	gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 1),
7263	rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
7264	gfc_finish_block (&loop_body));
7265	/* data = malloc (size * elem_len) */
7266	tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
7267	size_var, gfc_get_cfi_desc_elem_len (cfi));
7268	tree call = builtin_decl_explicit (fncode: BUILT_IN_MALLOC);
7269	call = build_call_expr_loc (input_location, call, 1, tmp);
7270	gfc_add_modify (&block2, data, fold_convert (TREE_TYPE (data), call));
7271
7272	/* Copy the data:
7273	for (idx = 0; idx < size; ++idx)
7274	{
7275	shift = 0;
7276	tmpidx = idx
7277	for (dim = 0; dim < rank; ++dim)
7278	{
7279	shift += (tmpidx % extent[d]) * sm[d]
7280	tmpidx = tmpidx / extend[d]
7281	}
7282	memcpy (lhs + idx*elem_len, rhs + shift, elem_len)
7283	} .*/
7284	idx = gfc_create_var (size_type_node, "arrayidx");
7285	gfc_init_block (&loop_body);
7286	tree shift = gfc_create_var (size_type_node, "shift");
7287	tree tmpidx = gfc_create_var (size_type_node, "tmpidx");
7288	gfc_add_modify (&loop_body, shift, build_zero_cst (TREE_TYPE (shift)));
7289	gfc_add_modify (&loop_body, tmpidx, idx);
7290	stmtblock_t inner_loop;
7291	gfc_init_block (&inner_loop);
7292	tree dim = gfc_create_var (TREE_TYPE (rank), "dim");
7293	/* shift += (tmpidx % extent[d]) * sm[d] */
7294	tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
7295	size_type_node, tmpidx,
7296	fold_convert (size_type_node,
7297	gfc_get_cfi_dim_extent (cfi, dim)));
7298	tmp = fold_build2_loc (input_location, MULT_EXPR,
7299	size_type_node, tmp,
7300	fold_convert (size_type_node,
7301	gfc_get_cfi_dim_sm (cfi, dim)));
7302	gfc_add_modify (&inner_loop, shift,
7303	fold_build2_loc (input_location, PLUS_EXPR,
7304	size_type_node, shift, tmp));
7305	/* tmpidx = tmpidx / extend[d] */
7306	tmp = fold_convert (size_type_node, gfc_get_cfi_dim_extent (cfi, dim));
7307	gfc_add_modify (&inner_loop, tmpidx,
7308	fold_build2_loc (input_location, TRUNC_DIV_EXPR,
7309	size_type_node, tmpidx, tmp));
7310	gfc_simple_for_loop (&loop_body, dim, build_zero_cst (TREE_TYPE (rank)),
7311	rank, LT_EXPR, build_int_cst (TREE_TYPE (dim), 1),
7312	gfc_finish_block (&inner_loop));
7313	/* Assign. */
7314	tmp = fold_convert (pchar_type_node, gfc_get_cfi_desc_base_addr (cfi));
7315	tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, tmp, shift);
7316	tree lhs;
7317	/* memcpy (lhs + idx*elem_len, rhs + shift, elem_len) */
7318	tree elem_len;
7319	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
7320	elem_len = gfc_conv_descriptor_elem_len (gfc_desc);
7321	else
7322	elem_len = gfc_get_cfi_desc_elem_len (cfi);
7323	lhs = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
7324	elem_len, idx);
7325	lhs = fold_build2_loc (input_location, POINTER_PLUS_EXPR, pchar_type_node,
7326	fold_convert (pchar_type_node, data), lhs);
7327	tmp = fold_convert (pvoid_type_node, tmp);
7328	lhs = fold_convert (pvoid_type_node, lhs);
7329	call = builtin_decl_explicit (fncode: BUILT_IN_MEMCPY);
7330	call = build_call_expr_loc (input_location, call, 3, lhs, tmp, elem_len);
7331	gfc_add_expr_to_block (&loop_body, fold_convert (void_type_node, call));
7332	gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)),
7333	size_var, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
7334	gfc_finish_block (&loop_body));
7335	/* if (cond) { block2 } */
7336	tmp = build3_v (COND_EXPR, cond_var, gfc_finish_block (&block2),
7337	build_empty_stmt (input_location));
7338	gfc_add_expr_to_block (&block, tmp);
7339	}
7340
7341	if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
7342	{
7343	tree offset, type;
7344	type = TREE_TYPE (gfc_desc);
7345	gfc_trans_array_bounds (type, sym, &offset, &block);
7346	if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7347	gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
7348	goto done;
7349	}
7350
7351	/* If cfi->data != NULL. */
7352	stmtblock_t block2;
7353	gfc_init_block (&block2);
7354
7355	/* if do_copy_inout: gfc->dspan = gfc->dtype.elem_len
7356	We use gfc instead of cfi on the RHS as this might be a constant. */
7357	tmp = fold_convert (gfc_array_index_type,
7358	gfc_conv_descriptor_elem_len (gfc_desc));
7359	if (!do_copy_inout)
7360	{
7361	/* gfc->dspan = ((cfi->dim[0].sm % gfc->elem_len)
7362	? cfi->dim[0].sm : gfc->elem_len). */
7363	tree cond;
7364	tree tmp2 = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
7365	cond = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
7366	gfc_array_index_type, tmp2, tmp);
7367	cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7368	cond, gfc_index_zero_node);
7369	tmp = build3_loc (loc: input_location, code: COND_EXPR, type: gfc_array_index_type, arg0: cond,
7370	arg1: tmp2, arg2: tmp);
7371	}
7372	gfc_conv_descriptor_span_set (&block2, gfc_desc, tmp);
7373
7374	/* Calculate offset + set lbound, ubound and stride. */
7375	gfc_conv_descriptor_offset_set (&block2, gfc_desc, gfc_index_zero_node);
7376	if (sym->as->rank > 0 && !sym->attr.pointer && !sym->attr.allocatable)
7377	for (int i = 0; i < sym->as->rank; ++i)
7378	{
7379	gfc_se se;
7380	gfc_init_se (&se, NULL );
7381	if (sym->as->lower[i])
7382	{
7383	gfc_conv_expr (se: &se, expr: sym->as->lower[i]);
7384	tmp = se.expr;
7385	}
7386	else
7387	tmp = gfc_index_one_node;
7388	gfc_add_block_to_block (&block2, &se.pre);
7389	gfc_conv_descriptor_lbound_set (&block2, gfc_desc, gfc_rank_cst[i],
7390	tmp);
7391	gfc_add_block_to_block (&block2, &se.post);
7392	}
7393
7394	/* Loop: for (i = 0; i < rank; ++i). */
7395	idx = gfc_create_var (TREE_TYPE (rank), "idx");
7396
7397	/* Loop body. */
7398	stmtblock_t loop_body;
7399	gfc_init_block (&loop_body);
7400	/* gfc->dim[i].lbound = ... */
7401	if (sym->attr.pointer || sym->attr.allocatable)
7402	{
7403	tmp = gfc_get_cfi_dim_lbound (cfi, idx);
7404	gfc_conv_descriptor_lbound_set (&loop_body, gfc_desc, idx, tmp);
7405	}
7406	else if (sym->as->rank < 0)
7407	gfc_conv_descriptor_lbound_set (&loop_body, gfc_desc, idx,
7408	gfc_index_one_node);
7409
7410	/* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
7411	tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7412	gfc_conv_descriptor_lbound_get (gfc_desc, idx),
7413	gfc_index_one_node);
7414	tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7415	gfc_get_cfi_dim_extent (cfi, idx), tmp);
7416	gfc_conv_descriptor_ubound_set (&loop_body, gfc_desc, idx, tmp);
7417
7418	if (do_copy_inout)
7419	{
7420	/* gfc->dim[i].stride
7421	= idx == 0 ? 1 : gfc->dim[i-1].stride * cfi->dim[i-1].extent */
7422	tree cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7423	idx, build_zero_cst (TREE_TYPE (idx)));
7424	tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (idx),
7425	idx, build_int_cst (TREE_TYPE (idx), 1));
7426	tree tmp2 = gfc_get_cfi_dim_extent (cfi, tmp);
7427	tmp = gfc_conv_descriptor_stride_get (gfc_desc, tmp);
7428	tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp2),
7429	tmp2, tmp);
7430	tmp = build3_loc (loc: input_location, code: COND_EXPR, type: gfc_array_index_type, arg0: cond,
7431	gfc_index_one_node, arg2: tmp);
7432	}
7433	else
7434	{
7435	/* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
7436	tmp = gfc_get_cfi_dim_sm (cfi, idx);
7437	tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
7438	gfc_array_index_type, tmp,
7439	fold_convert (gfc_array_index_type,
7440	gfc_get_cfi_desc_elem_len (cfi)));
7441	}
7442	gfc_conv_descriptor_stride_set (&loop_body, gfc_desc, idx, tmp);
7443	/* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
7444	tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7445	gfc_conv_descriptor_stride_get (gfc_desc, idx),
7446	gfc_conv_descriptor_lbound_get (gfc_desc, idx));
7447	tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7448	gfc_conv_descriptor_offset_get (gfc_desc), tmp);
7449	gfc_conv_descriptor_offset_set (&loop_body, gfc_desc, tmp);
7450
7451	/* Generate loop. */
7452	gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)),
7453	rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
7454	gfc_finish_block (&loop_body));
7455	if (sym->attr.allocatable || sym->attr.pointer)
7456	{
7457	tmp = gfc_get_cfi_desc_base_addr (cfi),
7458	tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7459	tmp, null_pointer_node);
7460	tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
7461	build_empty_stmt (input_location));
7462	gfc_add_expr_to_block (&block, tmp);
7463	}
7464	else
7465	gfc_add_block_to_block (&block, &block2);
7466
7467	done:
7468	/* If optional arg: 'if (arg) { block } else { local_arg = NULL; }'. */
7469	if (sym->attr.optional)
7470	{
7471	tree present = fold_build2_loc (input_location, NE_EXPR,
7472	boolean_type_node, cfi_desc,
7473	null_pointer_node);
7474	tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7475	sym->backend_decl,
7476	fold_convert (TREE_TYPE (sym->backend_decl),
7477	null_pointer_node));
7478	tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block), tmp);
7479	gfc_add_expr_to_block (init, tmp);
7480	}
7481	else
7482	gfc_add_block_to_block (init, &block);
7483
7484	if (!sym->attr.referenced)
7485	return;
7486
7487	/* If pointer not changed, nothing to be done (except copy out) */
7488	if (!do_copy_inout && ((!sym->attr.pointer && !sym->attr.allocatable)
7489	|| sym->attr.intent == INTENT_IN))
7490	return;
7491
7492	gfc_init_block (&block);
7493
7494	/* For bind(C), Fortran does not permit mixing 'pointer' with 'contiguous' (or
7495	len=*). Thus, when copy out is needed, the bounds ofthe descriptor remain
7496	unchanged. */
7497	if (do_copy_inout)
7498	{
7499	tree data, call;
7500	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
7501	data = gfc_conv_descriptor_data_get (gfc_desc);
7502	else if (!POINTER_TYPE_P (TREE_TYPE (gfc_desc)))
7503	data = gfc_build_addr_expr (NULL, gfc_desc);
7504	else
7505	data = gfc_desc;
7506	gfc_init_block (&block2);
7507	if (sym->attr.intent != INTENT_IN)
7508	{
7509	/* First, create the inner copy-out loop.
7510	for (idx = 0; idx < size; ++idx)
7511	{
7512	shift = 0;
7513	tmpidx = idx
7514	for (dim = 0; dim < rank; ++dim)
7515	{
7516	shift += (tmpidx % extent[d]) * sm[d]
7517	tmpidx = tmpidx / extend[d]
7518	}
7519	memcpy (lhs + shift, rhs + idx*elem_len, elem_len)
7520	} .*/
7521	stmtblock_t loop_body;
7522	idx = gfc_create_var (size_type_node, "arrayidx");
7523	gfc_init_block (&loop_body);
7524	tree shift = gfc_create_var (size_type_node, "shift");
7525	tree tmpidx = gfc_create_var (size_type_node, "tmpidx");
7526	gfc_add_modify (&loop_body, shift,
7527	build_zero_cst (TREE_TYPE (shift)));
7528	gfc_add_modify (&loop_body, tmpidx, idx);
7529	stmtblock_t inner_loop;
7530	gfc_init_block (&inner_loop);
7531	tree dim = gfc_create_var (TREE_TYPE (rank), "dim");
7532	/* shift += (tmpidx % extent[d]) * sm[d] */
7533	tmp = fold_convert (size_type_node,
7534	gfc_get_cfi_dim_extent (cfi, dim));
7535	tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
7536	size_type_node, tmpidx, tmp);
7537	tmp = fold_build2_loc (input_location, MULT_EXPR,
7538	size_type_node, tmp,
7539	fold_convert (size_type_node,
7540	gfc_get_cfi_dim_sm (cfi, dim)));
7541	gfc_add_modify (&inner_loop, shift,
7542	fold_build2_loc (input_location, PLUS_EXPR,
7543	size_type_node, shift, tmp));
7544	/* tmpidx = tmpidx / extend[d] */
7545	tmp = fold_convert (size_type_node,
7546	gfc_get_cfi_dim_extent (cfi, dim));
7547	gfc_add_modify (&inner_loop, tmpidx,
7548	fold_build2_loc (input_location, TRUNC_DIV_EXPR,
7549	size_type_node, tmpidx, tmp));
7550	gfc_simple_for_loop (&loop_body, dim,
7551	build_zero_cst (TREE_TYPE (rank)), rank, LT_EXPR,
7552	build_int_cst (TREE_TYPE (dim), 1),
7553	gfc_finish_block (&inner_loop));
7554	/* Assign. */
7555	tree rhs;
7556	tmp = fold_convert (pchar_type_node,
7557	gfc_get_cfi_desc_base_addr (cfi));
7558	tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, tmp, shift);
7559	/* memcpy (lhs + shift, rhs + idx*elem_len, elem_len) */
7560	tree elem_len;
7561	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
7562	elem_len = gfc_conv_descriptor_elem_len (gfc_desc);
7563	else
7564	elem_len = gfc_get_cfi_desc_elem_len (cfi);
7565	rhs = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
7566	elem_len, idx);
7567	rhs = fold_build2_loc (input_location, POINTER_PLUS_EXPR,
7568	pchar_type_node,
7569	fold_convert (pchar_type_node, data), rhs);
7570	tmp = fold_convert (pvoid_type_node, tmp);
7571	rhs = fold_convert (pvoid_type_node, rhs);
7572	call = builtin_decl_explicit (fncode: BUILT_IN_MEMCPY);
7573	call = build_call_expr_loc (input_location, call, 3, tmp, rhs,
7574	elem_len);
7575	gfc_add_expr_to_block (&loop_body,
7576	fold_convert (void_type_node, call));
7577	gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)),
7578	size_var, LT_EXPR,
7579	build_int_cst (TREE_TYPE (idx), 1),
7580	gfc_finish_block (&loop_body));
7581	}
7582	call = builtin_decl_explicit (fncode: BUILT_IN_FREE);
7583	call = build_call_expr_loc (input_location, call, 1, data);
7584	gfc_add_expr_to_block (&block2, call);
7585
7586	/* if (cfi->base_addr != gfc->data) { copy out; free(var) }; return */
7587	tree tmp2 = gfc_get_cfi_desc_base_addr (cfi);
7588	tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7589	tmp2, fold_convert (TREE_TYPE (tmp2), data));
7590	tmp = build3_v (COND_EXPR, tmp2, gfc_finish_block (&block2),
7591	build_empty_stmt (input_location));
7592	gfc_add_expr_to_block (&block, tmp);
7593	goto done_finally;
7594	}
7595
7596	/* Update pointer + array data data on exit. */
7597	tmp = gfc_get_cfi_desc_base_addr (cfi);
7598	tmp2 = (!sym->attr.dimension
7599	? gfc_desc : gfc_conv_descriptor_data_get (gfc_desc));
7600	gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
7601
7602	/* Set string length for len=:, only. */
7603	if (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length)
7604	{
7605	tmp2 = gfc_get_cfi_desc_elem_len (cfi);
7606	tmp = fold_convert (TREE_TYPE (tmp2), sym->ts.u.cl->backend_decl);
7607	if (sym->ts.kind != 1)
7608	tmp = fold_build2_loc (input_location, MULT_EXPR,
7609	TREE_TYPE (tmp2), tmp,
7610	build_int_cst (TREE_TYPE (tmp2), sym->ts.kind));
7611	gfc_add_modify (&block, tmp2, tmp);
7612	}
7613
7614	if (!sym->attr.dimension)
7615	goto done_finally;
7616
7617	gfc_init_block (&block2);
7618
7619	/* Loop: for (i = 0; i < rank; ++i). */
7620	idx = gfc_create_var (TREE_TYPE (rank), "idx");
7621
7622	/* Loop body. */
7623	gfc_init_block (&loop_body);
7624	/* cfi->dim[i].lower_bound = gfc->dim[i].lbound */
7625	gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx),
7626	gfc_conv_descriptor_lbound_get (gfc_desc, idx));
7627	/* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
7628	tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7629	gfc_conv_descriptor_ubound_get (gfc_desc, idx),
7630	gfc_conv_descriptor_lbound_get (gfc_desc, idx));
7631	tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, tmp,
7632	gfc_index_one_node);
7633	gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
7634	/* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
7635	tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7636	gfc_conv_descriptor_stride_get (gfc_desc, idx),
7637	gfc_conv_descriptor_span_get (gfc_desc));
7638	gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
7639
7640	/* Generate loop. */
7641	gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)),
7642	rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
7643	gfc_finish_block (&loop_body));
7644	/* if (gfc->data != NULL) { block2 }. */
7645	tmp = gfc_get_cfi_desc_base_addr (cfi),
7646	tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7647	tmp, null_pointer_node);
7648	tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
7649	build_empty_stmt (input_location));
7650	gfc_add_expr_to_block (&block, tmp);
7651
7652	done_finally:
7653	/* If optional arg: 'if (arg) { block } else { local_arg = NULL; }'. */
7654	if (sym->attr.optional)
7655	{
7656	tree present = fold_build2_loc (input_location, NE_EXPR,
7657	boolean_type_node, cfi_desc,
7658	null_pointer_node);
7659	tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
7660	build_empty_stmt (input_location));
7661	gfc_add_expr_to_block (finally, tmp);
7662	}
7663	else
7664	gfc_add_block_to_block (finally, &block);
7665	}
7666
7667	/* Generate code for a function. */
7668
7669	void
7670	gfc_generate_function_code (gfc_namespace * ns)
7671	{
7672	tree fndecl;
7673	tree old_context;
7674	tree decl;
7675	tree tmp;
7676	tree fpstate = NULL_TREE;
7677	stmtblock_t init, cleanup, outer_block;
7678	stmtblock_t body;
7679	gfc_wrapped_block try_block;
7680	tree recurcheckvar = NULL_TREE;
7681	gfc_symbol *sym;
7682	gfc_symbol *previous_procedure_symbol;
7683	int rank, ieee;
7684	bool is_recursive;
7685
7686	sym = ns->proc_name;
7687	previous_procedure_symbol = current_procedure_symbol;
7688	current_procedure_symbol = sym;
7689
7690	/* Initialize sym->tlink so that gfc_trans_deferred_vars does not get
7691	lost or worse. */
7692	sym->tlink = sym;
7693
7694	/* Create the declaration for functions with global scope. */
7695	if (!sym->backend_decl)
7696	gfc_create_function_decl (ns, global: false);
7697
7698	fndecl = sym->backend_decl;
7699	old_context = current_function_decl;
7700
7701	if (old_context)
7702	{
7703	push_function_context ();
7704	saved_parent_function_decls = saved_function_decls;
7705	saved_function_decls = NULL_TREE;
7706	}
7707
7708	trans_function_start (sym);
7709	gfc_current_locus = sym->declared_at;
7710
7711	gfc_init_block (&init);
7712	gfc_init_block (&cleanup);
7713	gfc_init_block (&outer_block);
7714
7715	if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
7716	{
7717	/* Copy length backend_decls to all entry point result
7718	symbols. */
7719	gfc_entry_list *el;
7720	tree backend_decl;
7721
7722	gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
7723	backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
7724	for (el = ns->entries; el; el = el->next)
7725	el->sym->result->ts.u.cl->backend_decl = backend_decl;
7726	}
7727
7728	/* Translate COMMON blocks. */
7729	gfc_trans_common (ns);
7730
7731	/* Null the parent fake result declaration if this namespace is
7732	a module function or an external procedures. */
7733	if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
7734	|| ns->parent == NULL)
7735	parent_fake_result_decl = NULL_TREE;
7736
7737	/* For BIND(C):
7738	- deallocate intent-out allocatable dummy arguments.
7739	- Create GFC variable which will later be populated by convert_CFI_desc */
7740	if (sym->attr.is_bind_c)
7741	for (gfc_formal_arglist *formal = gfc_sym_get_dummy_args (sym);
7742	formal; formal = formal->next)
7743	{
7744	gfc_symbol *fsym = formal->sym;
7745	if (!is_CFI_desc (fsym, NULL))
7746	continue;
7747	if (!fsym->attr.referenced)
7748	{
7749	gfc_conv_cfi_to_gfc (init: &init, finally: &cleanup, cfi_desc: fsym->backend_decl,
7750	NULL_TREE, sym: fsym);
7751	continue;
7752	}
7753	/* Let's now create a local GFI descriptor. Afterwards:
7754	desc is the local descriptor,
7755	desc_p is a pointer to it
7756	and stored in sym->backend_decl
7757	GFC_DECL_SAVED_DESCRIPTOR (desc_p) contains the CFI descriptor
7758	-> PARM_DECL and before sym->backend_decl.
7759	For scalars, decl == decl_p is a pointer variable. */
7760	tree desc_p, desc;
7761	location_t loc = gfc_get_location (&sym->declared_at);
7762	if (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length)
7763	fsym->ts.u.cl->backend_decl = gfc_create_var (gfc_array_index_type,
7764	fsym->name);
7765	else if (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->backend_decl)
7766	{
7767	gfc_se se;
7768	gfc_init_se (&se, NULL );
7769	gfc_conv_expr (se: &se, expr: fsym->ts.u.cl->length);
7770	gfc_add_block_to_block (&init, &se.pre);
7771	fsym->ts.u.cl->backend_decl = se.expr;
7772	gcc_assert(se.post.head == NULL_TREE);
7773	}
7774	/* Nullify, otherwise gfc_sym_type will return the CFI type. */
7775	tree tmp = fsym->backend_decl;
7776	fsym->backend_decl = NULL;
7777	tree type = gfc_sym_type (fsym);
7778	gcc_assert (POINTER_TYPE_P (type));
7779	if (POINTER_TYPE_P (TREE_TYPE (type)))
7780	/* For instance, allocatable scalars. */
7781	type = TREE_TYPE (type);
7782	if (TREE_CODE (type) == REFERENCE_TYPE)
7783	type = build_pointer_type (TREE_TYPE (type));
7784	desc_p = build_decl (loc, VAR_DECL, get_identifier (fsym->name), type);
7785	if (!fsym->attr.dimension)
7786	desc = desc_p;
7787	else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc_p))))
7788	{
7789	/* Character(len=*) explicit-size/assumed-size array. */
7790	desc = desc_p;
7791	gfc_build_qualified_array (decl: desc, sym: fsym);
7792	}
7793	else
7794	{
7795	tree size = size_in_bytes (TREE_TYPE (TREE_TYPE (desc_p)));
7796	tree call = builtin_decl_explicit (fncode: BUILT_IN_ALLOCA);
7797	call = build_call_expr_loc (input_location, call, 1, size);
7798	gfc_add_modify (&outer_block, desc_p,
7799	fold_convert (TREE_TYPE(desc_p), call));
7800	desc = build_fold_indirect_ref_loc (input_location, desc_p);
7801	}
7802	pushdecl (desc_p);
7803	if (fsym->attr.optional)
7804	{
7805	gfc_allocate_lang_decl (decl: desc_p);
7806	GFC_DECL_OPTIONAL_ARGUMENT (desc_p) = 1;
7807	}
7808	fsym->backend_decl = desc_p;
7809	gfc_conv_cfi_to_gfc (init: &init, finally: &cleanup, cfi_desc: tmp, gfc_desc: desc, sym: fsym);
7810	}
7811
7812	gfc_generate_contained_functions (parent: ns);
7813
7814	has_coarray_vars = false;
7815	generate_local_vars (ns);
7816
7817	if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
7818	generate_coarray_init (ns);
7819
7820	/* Keep the parent fake result declaration in module functions
7821	or external procedures. */
7822	if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
7823	|| ns->parent == NULL)
7824	current_fake_result_decl = parent_fake_result_decl;
7825	else
7826	current_fake_result_decl = NULL_TREE;
7827
7828	is_recursive = sym->attr.recursive
7829	|| (sym->attr.entry_master
7830	&& sym->ns->entries->sym->attr.recursive);
7831	if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
7832	&& !is_recursive && !flag_recursive && !sym->attr.artificial)
7833	{
7834	char * msg;
7835
7836	msg = xasprintf ("Recursive call to nonrecursive procedure '%s'",
7837	sym->name);
7838	recurcheckvar = gfc_create_var (logical_type_node, "is_recursive");
7839	TREE_STATIC (recurcheckvar) = 1;
7840	DECL_INITIAL (recurcheckvar) = logical_false_node;
7841	gfc_add_expr_to_block (&init, recurcheckvar);
7842	gfc_trans_runtime_check (true, false, recurcheckvar, &init,
7843	&sym->declared_at, msg);
7844	gfc_add_modify (&init, recurcheckvar, logical_true_node);
7845	free (ptr: msg);
7846	}
7847
7848	/* Check if an IEEE module is used in the procedure. If so, save
7849	the floating point state. */
7850	ieee = is_ieee_module_used (ns);
7851	if (ieee)
7852	fpstate = gfc_save_fp_state (&init);
7853
7854	/* Now generate the code for the body of this function. */
7855	gfc_init_block (&body);
7856
7857	if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
7858	&& sym->attr.subroutine)
7859	{
7860	tree alternate_return;
7861	alternate_return = gfc_get_fake_result_decl (sym, parent_flag: 0);
7862	gfc_add_modify (&body, alternate_return, integer_zero_node);
7863	}
7864
7865	if (ns->entries)
7866	{
7867	/* Jump to the correct entry point. */
7868	tmp = gfc_trans_entry_master_switch (el: ns->entries);
7869	gfc_add_expr_to_block (&body, tmp);
7870	}
7871
7872	/* If bounds-checking is enabled, generate code to check passed in actual
7873	arguments against the expected dummy argument attributes (e.g. string
7874	lengths). */
7875	if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
7876	add_argument_checking (block: &body, sym);
7877
7878	finish_oacc_declare (ns, sym, block: false);
7879
7880	tmp = gfc_trans_code (ns->code);
7881	gfc_add_expr_to_block (&body, tmp);
7882
7883	if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
7884	|| (sym->result && sym->result != sym
7885	&& sym->result->ts.type == BT_DERIVED
7886	&& sym->result->ts.u.derived->attr.alloc_comp))
7887	{
7888	bool artificial_result_decl = false;
7889	tree result = get_proc_result (sym);
7890	gfc_symbol *rsym = sym == sym->result ? sym : sym->result;
7891
7892	/* Make sure that a function returning an object with
7893	alloc/pointer_components always has a result, where at least
7894	the allocatable/pointer components are set to zero. */
7895	if (result == NULL_TREE && sym->attr.function
7896	&& ((sym->result->ts.type == BT_DERIVED
7897	&& (sym->attr.allocatable
7898	|| sym->attr.pointer
7899	|| sym->result->ts.u.derived->attr.alloc_comp
7900	|| sym->result->ts.u.derived->attr.pointer_comp))
7901	|| (sym->result->ts.type == BT_CLASS
7902	&& (CLASS_DATA (sym)->attr.allocatable
7903	|| CLASS_DATA (sym)->attr.class_pointer
7904	|| CLASS_DATA (sym->result)->attr.alloc_comp
7905	|| CLASS_DATA (sym->result)->attr.pointer_comp))))
7906	{
7907	artificial_result_decl = true;
7908	result = gfc_get_fake_result_decl (sym, parent_flag: 0);
7909	}
7910
7911	if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer)
7912	{
7913	if (sym->attr.allocatable && sym->attr.dimension == 0
7914	&& sym->result == sym)
7915	gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
7916	null_pointer_node));
7917	else if (sym->ts.type == BT_CLASS
7918	&& CLASS_DATA (sym)->attr.allocatable
7919	&& CLASS_DATA (sym)->attr.dimension == 0
7920	&& sym->result == sym)
7921	{
7922	tmp = CLASS_DATA (sym)->backend_decl;
7923	tmp = fold_build3_loc (input_location, COMPONENT_REF,
7924	TREE_TYPE (tmp), result, tmp, NULL_TREE);
7925	gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
7926	null_pointer_node));
7927	}
7928	else if (sym->ts.type == BT_DERIVED
7929	&& !sym->attr.allocatable)
7930	{
7931	gfc_expr *init_exp;
7932	/* Arrays are not initialized using the default initializer of
7933	their elements. Therefore only check if a default
7934	initializer is available when the result is scalar. */
7935	init_exp = rsym->as ? NULL
7936	: gfc_generate_initializer (&rsym->ts, true);
7937	if (init_exp)
7938	{
7939	tmp = gfc_trans_structure_assign (result, init_exp, 0);
7940	gfc_free_expr (init_exp);
7941	gfc_add_expr_to_block (&init, tmp);
7942	}
7943	else if (rsym->ts.u.derived->attr.alloc_comp)
7944	{
7945	rank = rsym->as ? rsym->as->rank : 0;
7946	tmp = gfc_nullify_alloc_comp (rsym->ts.u.derived, result,
7947	rank);
7948	gfc_prepend_expr_to_block (&body, tmp);
7949	}
7950	}
7951	}
7952
7953	if (result == NULL_TREE || artificial_result_decl)
7954	{
7955	/* TODO: move to the appropriate place in resolve.cc. */
7956	if (warn_return_type > 0 && sym == sym->result)
7957	gfc_warning (opt: OPT_Wreturn_type,
7958	"Return value of function %qs at %L not set",
7959	sym->name, &sym->declared_at);
7960	if (warn_return_type > 0)
7961	suppress_warning (sym->backend_decl);
7962	}
7963	if (result != NULL_TREE)
7964	gfc_add_expr_to_block (&body, gfc_generate_return ());
7965	}
7966
7967	/* Reset recursion-check variable. */
7968	if (recurcheckvar != NULL_TREE)
7969	{
7970	gfc_add_modify (&cleanup, recurcheckvar, logical_false_node);
7971	recurcheckvar = NULL;
7972	}
7973
7974	/* If IEEE modules are loaded, restore the floating-point state. */
7975	if (ieee)
7976	gfc_restore_fp_state (&cleanup, fpstate);
7977
7978	/* Finish the function body and add init and cleanup code. */
7979	tmp = gfc_finish_block (&body);
7980	/* Add code to create and cleanup arrays. */
7981	gfc_start_wrapped_block (block: &try_block, code: tmp);
7982	gfc_trans_deferred_vars (proc_sym: sym, block: &try_block);
7983	gfc_add_init_cleanup (block: &try_block, init: gfc_finish_block (&init),
7984	cleanup: gfc_finish_block (&cleanup));
7985
7986	/* Add all the decls we created during processing. */
7987	decl = nreverse (saved_function_decls);
7988	while (decl)
7989	{
7990	tree next;
7991
7992	next = DECL_CHAIN (decl);
7993	DECL_CHAIN (decl) = NULL_TREE;
7994	pushdecl (decl);
7995	decl = next;
7996	}
7997	saved_function_decls = NULL_TREE;
7998
7999	gfc_add_expr_to_block (&outer_block, gfc_finish_wrapped_block (block: &try_block));
8000	DECL_SAVED_TREE (fndecl) = gfc_finish_block (&outer_block);
8001	decl = getdecls ();
8002
8003	/* Finish off this function and send it for code generation. */
8004	poplevel (1, 1);
8005	BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
8006
8007	DECL_SAVED_TREE (fndecl)
8008	= fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR, void_type_node,
8009	decl, DECL_SAVED_TREE (fndecl), DECL_INITIAL (fndecl));
8010
8011	/* Output the GENERIC tree. */
8012	dump_function (phase: TDI_original, fn: fndecl);
8013
8014	/* Store the end of the function, so that we get good line number
8015	info for the epilogue. */
8016	cfun->function_end_locus = input_location;
8017
8018	/* We're leaving the context of this function, so zap cfun.
8019	It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
8020	tree_rest_of_compilation. */
8021	set_cfun (NULL);
8022
8023	if (old_context)
8024	{
8025	pop_function_context ();
8026	saved_function_decls = saved_parent_function_decls;
8027	}
8028	current_function_decl = old_context;
8029
8030	if (decl_function_context (fndecl))
8031	{
8032	/* Register this function with cgraph just far enough to get it
8033	added to our parent's nested function list.
8034	If there are static coarrays in this function, the nested _caf_init
8035	function has already called cgraph_create_node, which also created
8036	the cgraph node for this function. */
8037	if (!has_coarray_vars || flag_coarray != GFC_FCOARRAY_LIB)
8038	(void) cgraph_node::get_create (fndecl);
8039	}
8040	else
8041	cgraph_node::finalize_function (fndecl, true);
8042
8043	gfc_trans_use_stmts (ns);
8044	gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
8045
8046	if (sym->attr.is_main_program)
8047	create_main_function (fndecl);
8048
8049	current_procedure_symbol = previous_procedure_symbol;
8050	}
8051
8052
8053	void
8054	gfc_generate_constructors (void)
8055	{
8056	gcc_assert (gfc_static_ctors == NULL_TREE);
8057	#if 0
8058	tree fnname;
8059	tree type;
8060	tree fndecl;
8061	tree decl;
8062	tree tmp;
8063
8064	if (gfc_static_ctors == NULL_TREE)
8065	return;
8066
8067	fnname = get_file_function_name ("I");
8068	type = build_function_type_list (void_type_node, NULL_TREE);
8069
8070	fndecl = build_decl (input_location,
8071	FUNCTION_DECL, fnname, type);
8072	TREE_PUBLIC (fndecl) = 1;
8073
8074	decl = build_decl (input_location,
8075	RESULT_DECL, NULL_TREE, void_type_node);
8076	DECL_ARTIFICIAL (decl) = 1;
8077	DECL_IGNORED_P (decl) = 1;
8078	DECL_CONTEXT (decl) = fndecl;
8079	DECL_RESULT (fndecl) = decl;
8080
8081	pushdecl (fndecl);
8082
8083	current_function_decl = fndecl;
8084
8085	rest_of_decl_compilation (fndecl, 1, 0);
8086
8087	make_decl_rtl (fndecl);
8088
8089	allocate_struct_function (fndecl, false);
8090
8091	pushlevel ();
8092
8093	for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
8094	{
8095	tmp = build_call_expr_loc (input_location,
8096	TREE_VALUE (gfc_static_ctors), 0);
8097	DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
8098	}
8099
8100	decl = getdecls ();
8101	poplevel (1, 1);
8102
8103	BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
8104	DECL_SAVED_TREE (fndecl)
8105	= build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
8106	DECL_INITIAL (fndecl));
8107
8108	free_after_parsing (cfun);
8109	free_after_compilation (cfun);
8110
8111	tree_rest_of_compilation (fndecl);
8112
8113	current_function_decl = NULL_TREE;
8114	#endif
8115	}
8116
8117	/* Translates a BLOCK DATA program unit. This means emitting the
8118	commons contained therein plus their initializations. We also emit
8119	a globally visible symbol to make sure that each BLOCK DATA program
8120	unit remains unique. */
8121
8122	void
8123	gfc_generate_block_data (gfc_namespace * ns)
8124	{
8125	tree decl;
8126	tree id;
8127
8128	/* Tell the backend the source location of the block data. */
8129	if (ns->proc_name)
8130	gfc_set_backend_locus (&ns->proc_name->declared_at);
8131	else
8132	gfc_set_backend_locus (&gfc_current_locus);
8133
8134	/* Process the DATA statements. */
8135	gfc_trans_common (ns);
8136
8137	/* Create a global symbol with the mane of the block data. This is to
8138	generate linker errors if the same name is used twice. It is never
8139	really used. */
8140	if (ns->proc_name)
8141	id = gfc_sym_mangled_function_id (sym: ns->proc_name);
8142	else
8143	id = get_identifier ("__BLOCK_DATA__");
8144
8145	decl = build_decl (input_location,
8146	VAR_DECL, id, gfc_array_index_type);
8147	TREE_PUBLIC (decl) = 1;
8148	TREE_STATIC (decl) = 1;
8149	DECL_IGNORED_P (decl) = 1;
8150
8151	pushdecl (decl);
8152	rest_of_decl_compilation (decl, 1, 0);
8153	}
8154
8155
8156	/* Process the local variables of a BLOCK construct. */
8157
8158	void
8159	gfc_process_block_locals (gfc_namespace* ns)
8160	{
8161	tree decl;
8162
8163	saved_local_decls = NULL_TREE;
8164	has_coarray_vars = false;
8165
8166	generate_local_vars (ns);
8167
8168	if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
8169	generate_coarray_init (ns);
8170
8171	decl = nreverse (saved_local_decls);
8172	while (decl)
8173	{
8174	tree next;
8175
8176	next = DECL_CHAIN (decl);
8177	DECL_CHAIN (decl) = NULL_TREE;
8178	pushdecl (decl);
8179	decl = next;
8180	}
8181	saved_local_decls = NULL_TREE;
8182	}
8183
8184
8185	#include "gt-fortran-trans-decl.h"
8186