1	/* Expression translation
2	Copyright (C) 2002-2023 Free Software Foundation, Inc.
3	Contributed by Paul Brook <paul@nowt.org>
4	and Steven Bosscher <s.bosscher@student.tudelft.nl>
5
6	This file is part of GCC.
7
8	GCC is free software; you can redistribute it and/or modify it under
9	the terms of the GNU General Public License as published by the Free
10	Software Foundation; either version 3, or (at your option) any later
11	version.
12
13	GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14	WARRANTY; without even the implied warranty of MERCHANTABILITY or
15	FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16	for more details.
17
18	You should have received a copy of the GNU General Public License
19	along with GCC; see the file COPYING3. If not see
20	<http://www.gnu.org/licenses/>. */
21
22	/* trans-expr.cc-- generate GENERIC trees for gfc_expr. */
23
24	#include "config.h"
25	#include "system.h"
26	#include "coretypes.h"
27	#include "options.h"
28	#include "tree.h"
29	#include "gfortran.h"
30	#include "trans.h"
31	#include "stringpool.h"
32	#include "diagnostic-core.h" /* For fatal_error. */
33	#include "fold-const.h"
34	#include "langhooks.h"
35	#include "arith.h"
36	#include "constructor.h"
37	#include "trans-const.h"
38	#include "trans-types.h"
39	#include "trans-array.h"
40	/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41	#include "trans-stmt.h"
42	#include "dependency.h"
43	#include "gimplify.h"
44	#include "tm.h" /* For CHAR_TYPE_SIZE. */
45
46
47	/* Calculate the number of characters in a string. */
48
49	static tree
50	gfc_get_character_len (tree type)
51	{
52	tree len;
53
54	gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
55	&& TYPE_STRING_FLAG (type));
56
57	len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
58	len = (len) ? (len) : (integer_zero_node);
59	return fold_convert (gfc_charlen_type_node, len);
60	}
61
62
63
64	/* Calculate the number of bytes in a string. */
65
66	tree
67	gfc_get_character_len_in_bytes (tree type)
68	{
69	tree tmp, len;
70
71	gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
72	&& TYPE_STRING_FLAG (type));
73
74	tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
75	tmp = (tmp && !integer_zerop (tmp))
76	? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
77	len = gfc_get_character_len (type);
78	if (tmp && len && !integer_zerop (len))
79	len = fold_build2_loc (input_location, MULT_EXPR,
80	gfc_charlen_type_node, len, tmp);
81	return len;
82	}
83
84
85	/* Convert a scalar to an array descriptor. To be used for assumed-rank
86	arrays. */
87
88	static tree
89	get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
90	{
91	enum gfc_array_kind akind;
92
93	if (attr.pointer)
94	akind = GFC_ARRAY_POINTER_CONT;
95	else if (attr.allocatable)
96	akind = GFC_ARRAY_ALLOCATABLE;
97	else
98	akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
99
100	if (POINTER_TYPE_P (TREE_TYPE (scalar)))
101	scalar = TREE_TYPE (scalar);
102	return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
103	akind, !(attr.pointer || attr.target));
104	}
105
106	tree
107	gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
108	{
109	tree desc, type, etype;
110
111	type = get_scalar_to_descriptor_type (scalar, attr);
112	etype = TREE_TYPE (scalar);
113	desc = gfc_create_var (type, "desc");
114	DECL_ARTIFICIAL (desc) = 1;
115
116	if (CONSTANT_CLASS_P (scalar))
117	{
118	tree tmp;
119	tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
120	gfc_add_modify (&se->pre, tmp, scalar);
121	scalar = tmp;
122	}
123	if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
124	scalar = gfc_build_addr_expr (NULL_TREE, scalar);
125	else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
126	etype = TREE_TYPE (etype);
127	gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
128	gfc_get_dtype_rank_type (0, etype));
129	gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
130	gfc_conv_descriptor_span_set (&se->pre, desc,
131	gfc_conv_descriptor_elem_len (desc));
132
133	/* Copy pointer address back - but only if it could have changed and
134	if the actual argument is a pointer and not, e.g., NULL(). */
135	if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
136	gfc_add_modify (&se->post, scalar,
137	fold_convert (TREE_TYPE (scalar),
138	gfc_conv_descriptor_data_get (desc)));
139	return desc;
140	}
141
142
143	/* Get the coarray token from the ultimate array or component ref.
144	Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
145
146	tree
147	gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
148	{
149	gfc_symbol *sym = expr->symtree->n.sym;
150	bool is_coarray = sym->attr.codimension;
151	gfc_expr *caf_expr = gfc_copy_expr (expr);
152	gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
153
154	while (ref)
155	{
156	if (ref->type == REF_COMPONENT
157	&& (ref->u.c.component->attr.allocatable
158	|| ref->u.c.component->attr.pointer)
159	&& (is_coarray || ref->u.c.component->attr.codimension))
160	last_caf_ref = ref;
161	ref = ref->next;
162	}
163
164	if (last_caf_ref == NULL)
165	return NULL_TREE;
166
167	tree comp = last_caf_ref->u.c.component->caf_token, caf;
168	gfc_se se;
169	bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
170	if (comp == NULL_TREE && comp_ref)
171	return NULL_TREE;
172	gfc_init_se (&se, outerse);
173	gfc_free_ref_list (last_caf_ref->next);
174	last_caf_ref->next = NULL;
175	caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
176	se.want_pointer = comp_ref;
177	gfc_conv_expr (se: &se, expr: caf_expr);
178	gfc_add_block_to_block (&outerse->pre, &se.pre);
179
180	if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
181	se.expr = TREE_OPERAND (se.expr, 0);
182	gfc_free_expr (caf_expr);
183
184	if (comp_ref)
185	caf = fold_build3_loc (input_location, COMPONENT_REF,
186	TREE_TYPE (comp), se.expr, comp, NULL_TREE);
187	else
188	caf = gfc_conv_descriptor_token (se.expr);
189	return gfc_build_addr_expr (NULL_TREE, caf);
190	}
191
192
193	/* This is the seed for an eventual trans-class.c
194
195	The following parameters should not be used directly since they might
196	in future implementations. Use the corresponding APIs. */
197	#define CLASS_DATA_FIELD 0
198	#define CLASS_VPTR_FIELD 1
199	#define CLASS_LEN_FIELD 2
200	#define VTABLE_HASH_FIELD 0
201	#define VTABLE_SIZE_FIELD 1
202	#define VTABLE_EXTENDS_FIELD 2
203	#define VTABLE_DEF_INIT_FIELD 3
204	#define VTABLE_COPY_FIELD 4
205	#define VTABLE_FINAL_FIELD 5
206	#define VTABLE_DEALLOCATE_FIELD 6
207
208
209	tree
210	gfc_class_set_static_fields (tree decl, tree vptr, tree data)
211	{
212	tree tmp;
213	tree field;
214	vec<constructor_elt, va_gc> *init = NULL;
215
216	field = TYPE_FIELDS (TREE_TYPE (decl));
217	tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
218	CONSTRUCTOR_APPEND_ELT (init, tmp, data);
219
220	tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
221	CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
222
223	return build_constructor (TREE_TYPE (decl), init);
224	}
225
226
227	tree
228	gfc_class_data_get (tree decl)
229	{
230	tree data;
231	if (POINTER_TYPE_P (TREE_TYPE (decl)))
232	decl = build_fold_indirect_ref_loc (input_location, decl);
233	data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
234	CLASS_DATA_FIELD);
235	return fold_build3_loc (input_location, COMPONENT_REF,
236	TREE_TYPE (data), decl, data,
237	NULL_TREE);
238	}
239
240
241	tree
242	gfc_class_vptr_get (tree decl)
243	{
244	tree vptr;
245	/* For class arrays decl may be a temporary descriptor handle, the vptr is
246	then available through the saved descriptor. */
247	if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
248	&& GFC_DECL_SAVED_DESCRIPTOR (decl))
249	decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
250	if (POINTER_TYPE_P (TREE_TYPE (decl)))
251	decl = build_fold_indirect_ref_loc (input_location, decl);
252	vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
253	CLASS_VPTR_FIELD);
254	return fold_build3_loc (input_location, COMPONENT_REF,
255	TREE_TYPE (vptr), decl, vptr,
256	NULL_TREE);
257	}
258
259
260	tree
261	gfc_class_len_get (tree decl)
262	{
263	tree len;
264	/* For class arrays decl may be a temporary descriptor handle, the len is
265	then available through the saved descriptor. */
266	if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
267	&& GFC_DECL_SAVED_DESCRIPTOR (decl))
268	decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
269	if (POINTER_TYPE_P (TREE_TYPE (decl)))
270	decl = build_fold_indirect_ref_loc (input_location, decl);
271	len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
272	CLASS_LEN_FIELD);
273	return fold_build3_loc (input_location, COMPONENT_REF,
274	TREE_TYPE (len), decl, len,
275	NULL_TREE);
276	}
277
278
279	/* Try to get the _len component of a class. When the class is not unlimited
280	poly, i.e. no _len field exists, then return a zero node. */
281
282	static tree
283	gfc_class_len_or_zero_get (tree decl)
284	{
285	tree len;
286	/* For class arrays decl may be a temporary descriptor handle, the vptr is
287	then available through the saved descriptor. */
288	if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
289	&& GFC_DECL_SAVED_DESCRIPTOR (decl))
290	decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
291	if (POINTER_TYPE_P (TREE_TYPE (decl)))
292	decl = build_fold_indirect_ref_loc (input_location, decl);
293	len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
294	CLASS_LEN_FIELD);
295	return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
296	TREE_TYPE (len), decl, len,
297	NULL_TREE)
298	: build_zero_cst (gfc_charlen_type_node);
299	}
300
301
302	tree
303	gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
304	{
305	tree tmp;
306	tree tmp2;
307	tree type;
308
309	tmp = gfc_class_len_or_zero_get (decl: class_expr);
310
311	/* Include the len value in the element size if present. */
312	if (!integer_zerop (tmp))
313	{
314	type = TREE_TYPE (size);
315	if (block)
316	{
317	size = gfc_evaluate_now (size, block);
318	tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
319	}
320	tmp2 = fold_build2_loc (input_location, MULT_EXPR,
321	type, size, tmp);
322	tmp = fold_build2_loc (input_location, GT_EXPR,
323	logical_type_node, tmp,
324	build_zero_cst (type));
325	size = fold_build3_loc (input_location, COND_EXPR,
326	type, tmp, tmp2, size);
327	}
328	else
329	return size;
330
331	if (block)
332	size = gfc_evaluate_now (size, block);
333
334	return size;
335	}
336
337
338	/* Get the specified FIELD from the VPTR. */
339
340	static tree
341	vptr_field_get (tree vptr, int fieldno)
342	{
343	tree field;
344	vptr = build_fold_indirect_ref_loc (input_location, vptr);
345	field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
346	fieldno);
347	field = fold_build3_loc (input_location, COMPONENT_REF,
348	TREE_TYPE (field), vptr, field,
349	NULL_TREE);
350	gcc_assert (field);
351	return field;
352	}
353
354
355	/* Get the field from the class' vptr. */
356
357	static tree
358	class_vtab_field_get (tree decl, int fieldno)
359	{
360	tree vptr;
361	vptr = gfc_class_vptr_get (decl);
362	return vptr_field_get (vptr, fieldno);
363	}
364
365
366	/* Define a macro for creating the class_vtab_* and vptr_* accessors in
367	unison. */
368	#define VTAB_GET_FIELD_GEN(name, field) tree \
369	gfc_class_vtab_## name ##_get (tree cl) \
370	{ \
371	return class_vtab_field_get (cl, field); \
372	} \
373	\
374	tree \
375	gfc_vptr_## name ##_get (tree vptr) \
376	{ \
377	return vptr_field_get (vptr, field); \
378	}
379
380	VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
381	VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
382	VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
383	VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
384	VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
385	VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
386	#undef VTAB_GET_FIELD_GEN
387
388	/* The size field is returned as an array index type. Therefore treat
389	it and only it specially. */
390
391	tree
392	gfc_class_vtab_size_get (tree cl)
393	{
394	tree size;
395	size = class_vtab_field_get (decl: cl, VTABLE_SIZE_FIELD);
396	/* Always return size as an array index type. */
397	size = fold_convert (gfc_array_index_type, size);
398	gcc_assert (size);
399	return size;
400	}
401
402	tree
403	gfc_vptr_size_get (tree vptr)
404	{
405	tree size;
406	size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
407	/* Always return size as an array index type. */
408	size = fold_convert (gfc_array_index_type, size);
409	gcc_assert (size);
410	return size;
411	}
412
413
414	#undef CLASS_DATA_FIELD
415	#undef CLASS_VPTR_FIELD
416	#undef CLASS_LEN_FIELD
417	#undef VTABLE_HASH_FIELD
418	#undef VTABLE_SIZE_FIELD
419	#undef VTABLE_EXTENDS_FIELD
420	#undef VTABLE_DEF_INIT_FIELD
421	#undef VTABLE_COPY_FIELD
422	#undef VTABLE_FINAL_FIELD
423
424
425	/* IF ts is null (default), search for the last _class ref in the chain
426	of references of the expression and cut the chain there. Although
427	this routine is similiar to class.cc:gfc_add_component_ref (), there
428	is a significant difference: gfc_add_component_ref () concentrates
429	on an array ref that is the last ref in the chain and is oblivious
430	to the kind of refs following.
431	ELSE IF ts is non-null the cut is at the class entity or component
432	that is followed by an array reference, which is not an element.
433	These calls come from trans-array.cc:build_class_array_ref, which
434	handles scalarized class array references.*/
435
436	gfc_expr *
437	gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
438	gfc_typespec **ts)
439	{
440	gfc_expr *base_expr;
441	gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
442
443	/* Find the last class reference. */
444	class_ref = NULL;
445	array_ref = NULL;
446
447	if (ts)
448	{
449	if (e->symtree
450	&& e->symtree->n.sym->ts.type == BT_CLASS)
451	*ts = &e->symtree->n.sym->ts;
452	else
453	*ts = NULL;
454	}
455
456	for (ref = e->ref; ref; ref = ref->next)
457	{
458	if (ts)
459	{
460	if (ref->type == REF_COMPONENT
461	&& ref->u.c.component->ts.type == BT_CLASS
462	&& ref->next && ref->next->type == REF_COMPONENT
463	&& !strcmp (s1: ref->next->u.c.component->name, s2: "_data")
464	&& ref->next->next
465	&& ref->next->next->type == REF_ARRAY
466	&& ref->next->next->u.ar.type != AR_ELEMENT)
467	{
468	*ts = &ref->u.c.component->ts;
469	class_ref = ref;
470	break;
471	}
472
473	if (ref->next == NULL)
474	break;
475	}
476	else
477	{
478	if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
479	array_ref = ref;
480
481	if (ref->type == REF_COMPONENT
482	&& ref->u.c.component->ts.type == BT_CLASS)
483	{
484	/* Component to the right of a part reference with nonzero
485	rank must not have the ALLOCATABLE attribute. If attempts
486	are made to reference such a component reference, an error
487	results followed by an ICE. */
488	if (array_ref
489	&& CLASS_DATA (ref->u.c.component)->attr.allocatable)
490	return NULL;
491	class_ref = ref;
492	}
493	}
494	}
495
496	if (ts && *ts == NULL)
497	return NULL;
498
499	/* Remove and store all subsequent references after the
500	CLASS reference. */
501	if (class_ref)
502	{
503	tail = class_ref->next;
504	class_ref->next = NULL;
505	}
506	else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
507	{
508	tail = e->ref;
509	e->ref = NULL;
510	}
511
512	if (is_mold)
513	base_expr = gfc_expr_to_initialize (e);
514	else
515	base_expr = gfc_copy_expr (e);
516
517	/* Restore the original tail expression. */
518	if (class_ref)
519	{
520	gfc_free_ref_list (class_ref->next);
521	class_ref->next = tail;
522	}
523	else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
524	{
525	gfc_free_ref_list (e->ref);
526	e->ref = tail;
527	}
528	return base_expr;
529	}
530
531
532	/* Reset the vptr to the declared type, e.g. after deallocation.
533	Use the variable in CLASS_CONTAINER if available. Otherwise, recreate
534	one with E. The generated assignment code is added at the end of BLOCK. */
535
536	void
537	gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container)
538	{
539	tree vptr = NULL_TREE;
540
541	if (class_container != NULL_TREE)
542	vptr = gfc_get_vptr_from_expr (class_container);
543
544	if (vptr == NULL_TREE)
545	{
546	gfc_se se;
547
548	/* Evaluate the expression and obtain the vptr from it. */
549	gfc_init_se (&se, NULL);
550	if (e->rank)
551	gfc_conv_expr_descriptor (&se, e);
552	else
553	gfc_conv_expr (se: &se, expr: e);
554	gfc_add_block_to_block (block, &se.pre);
555
556	vptr = gfc_get_vptr_from_expr (se.expr);
557	}
558
559	/* If a vptr is not found, we can do nothing more. */
560	if (vptr == NULL_TREE)
561	return;
562
563	if (UNLIMITED_POLY (e))
564	gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
565	else
566	{
567	gfc_symbol *vtab;
568	tree vtable;
569
570	/* Return the vptr to the address of the declared type. */
571	vtab = gfc_find_derived_vtab (e->ts.u.derived);
572	vtable = vtab->backend_decl;
573	if (vtable == NULL_TREE)
574	vtable = gfc_get_symbol_decl (vtab);
575	vtable = gfc_build_addr_expr (NULL, vtable);
576	vtable = fold_convert (TREE_TYPE (vptr), vtable);
577	gfc_add_modify (block, vptr, vtable);
578	}
579	}
580
581
582	/* Reset the len for unlimited polymorphic objects. */
583
584	void
585	gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
586	{
587	gfc_expr *e;
588	gfc_se se_len;
589	e = gfc_find_and_cut_at_last_class_ref (e: expr);
590	if (e == NULL)
591	return;
592	gfc_add_len_component (e);
593	gfc_init_se (&se_len, NULL);
594	gfc_conv_expr (se: &se_len, expr: e);
595	gfc_add_modify (block, se_len.expr,
596	fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
597	gfc_free_expr (e);
598	}
599
600
601	/* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
602	reference is found. Note that it is up to the caller to avoid using this
603	for expressions other than variables. */
604
605	tree
606	gfc_get_class_from_gfc_expr (gfc_expr *e)
607	{
608	gfc_expr *class_expr;
609	gfc_se cse;
610	class_expr = gfc_find_and_cut_at_last_class_ref (e);
611	if (class_expr == NULL)
612	return NULL_TREE;
613	gfc_init_se (&cse, NULL);
614	gfc_conv_expr (se: &cse, expr: class_expr);
615	gfc_free_expr (class_expr);
616	return cse.expr;
617	}
618
619
620	/* Obtain the last class reference in an expression.
621	Return NULL_TREE if no class reference is found. */
622
623	tree
624	gfc_get_class_from_expr (tree expr)
625	{
626	tree tmp;
627	tree type;
628
629	for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
630	{
631	if (CONSTANT_CLASS_P (tmp))
632	return NULL_TREE;
633
634	type = TREE_TYPE (tmp);
635	while (type)
636	{
637	if (GFC_CLASS_TYPE_P (type))
638	return tmp;
639	if (type != TYPE_CANONICAL (type))
640	type = TYPE_CANONICAL (type);
641	else
642	type = NULL_TREE;
643	}
644	if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
645	break;
646	}
647
648	if (POINTER_TYPE_P (TREE_TYPE (tmp)))
649	tmp = build_fold_indirect_ref_loc (input_location, tmp);
650
651	if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
652	return tmp;
653
654	return NULL_TREE;
655	}
656
657
658	/* Obtain the vptr of the last class reference in an expression.
659	Return NULL_TREE if no class reference is found. */
660
661	tree
662	gfc_get_vptr_from_expr (tree expr)
663	{
664	tree tmp;
665
666	tmp = gfc_get_class_from_expr (expr);
667
668	if (tmp != NULL_TREE)
669	return gfc_class_vptr_get (decl: tmp);
670
671	return NULL_TREE;
672	}
673
674
675	static void
676	class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
677	bool lhs_type)
678	{
679	tree tmp, tmp2, type;
680
681	gfc_conv_descriptor_data_set (block, lhs_desc,
682	gfc_conv_descriptor_data_get (rhs_desc));
683	gfc_conv_descriptor_offset_set (block, lhs_desc,
684	gfc_conv_descriptor_offset_get (rhs_desc));
685
686	gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
687	gfc_conv_descriptor_dtype (rhs_desc));
688
689	/* Assign the dimension as range-ref. */
690	tmp = gfc_get_descriptor_dimension (lhs_desc);
691	tmp2 = gfc_get_descriptor_dimension (rhs_desc);
692
693	type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
694	tmp = build4_loc (loc: input_location, code: ARRAY_RANGE_REF, type, arg0: tmp,
695	gfc_index_zero_node, NULL_TREE, NULL_TREE);
696	tmp2 = build4_loc (loc: input_location, code: ARRAY_RANGE_REF, type, arg0: tmp2,
697	gfc_index_zero_node, NULL_TREE, NULL_TREE);
698	gfc_add_modify (block, tmp, tmp2);
699	}
700
701
702	/* Takes a derived type expression and returns the address of a temporary
703	class object of the 'declared' type. If vptr is not NULL, this is
704	used for the temporary class object.
705	optional_alloc_ptr is false when the dummy is neither allocatable
706	nor a pointer; that's only relevant for the optional handling.
707	The optional argument 'derived_array' is used to preserve the parmse
708	expression for deallocation of allocatable components. Assumed rank
709	formal arguments made this necessary. */
710	void
711	gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
712	gfc_typespec class_ts, tree vptr, bool optional,
713	bool optional_alloc_ptr,
714	tree *derived_array)
715	{
716	gfc_symbol *vtab;
717	tree cond_optional = NULL_TREE;
718	gfc_ss *ss;
719	tree ctree;
720	tree var;
721	tree tmp;
722	int dim;
723
724	/* The derived type needs to be converted to a temporary
725	CLASS object. */
726	tmp = gfc_typenode_for_spec (&class_ts);
727	var = gfc_create_var (tmp, "class");
728
729	/* Set the vptr. */
730	ctree = gfc_class_vptr_get (decl: var);
731
732	if (vptr != NULL_TREE)
733	{
734	/* Use the dynamic vptr. */
735	tmp = vptr;
736	}
737	else
738	{
739	/* In this case the vtab corresponds to the derived type and the
740	vptr must point to it. */
741	vtab = gfc_find_derived_vtab (e->ts.u.derived);
742	gcc_assert (vtab);
743	tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
744	}
745	gfc_add_modify (&parmse->pre, ctree,
746	fold_convert (TREE_TYPE (ctree), tmp));
747
748	/* Now set the data field. */
749	ctree = gfc_class_data_get (decl: var);
750
751	if (optional)
752	cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
753
754	if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
755	{
756	/* If there is a ready made pointer to a derived type, use it
757	rather than evaluating the expression again. */
758	tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
759	gfc_add_modify (&parmse->pre, ctree, tmp);
760	}
761	else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
762	{
763	/* For an array reference in an elemental procedure call we need
764	to retain the ss to provide the scalarized array reference. */
765	gfc_conv_expr_reference (se: parmse, expr: e);
766	tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
767	if (optional)
768	tmp = build3_loc (loc: input_location, code: COND_EXPR, TREE_TYPE (tmp),
769	arg0: cond_optional, arg1: tmp,
770	fold_convert (TREE_TYPE (tmp), null_pointer_node));
771	gfc_add_modify (&parmse->pre, ctree, tmp);
772	}
773	else
774	{
775	ss = gfc_walk_expr (e);
776	if (ss == gfc_ss_terminator)
777	{
778	parmse->ss = NULL;
779	gfc_conv_expr_reference (se: parmse, expr: e);
780
781	/* Scalar to an assumed-rank array. */
782	if (class_ts.u.derived->components->as)
783	{
784	tree type;
785	type = get_scalar_to_descriptor_type (scalar: parmse->expr,
786	attr: gfc_expr_attr (e));
787	gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
788	gfc_get_dtype (type));
789	if (optional)
790	parmse->expr = build3_loc (loc: input_location, code: COND_EXPR,
791	TREE_TYPE (parmse->expr),
792	arg0: cond_optional, arg1: parmse->expr,
793	fold_convert (TREE_TYPE (parmse->expr),
794	null_pointer_node));
795	gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
796	}
797	else
798	{
799	tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
800	if (optional)
801	tmp = build3_loc (loc: input_location, code: COND_EXPR, TREE_TYPE (tmp),
802	arg0: cond_optional, arg1: tmp,
803	fold_convert (TREE_TYPE (tmp),
804	null_pointer_node));
805	gfc_add_modify (&parmse->pre, ctree, tmp);
806	}
807	}
808	else
809	{
810	stmtblock_t block;
811	gfc_init_block (&block);
812	gfc_ref *ref;
813
814	parmse->ss = ss;
815	parmse->use_offset = 1;
816	gfc_conv_expr_descriptor (parmse, e);
817
818	/* Detect any array references with vector subscripts. */
819	for (ref = e->ref; ref; ref = ref->next)
820	if (ref->type == REF_ARRAY
821	&& ref->u.ar.type != AR_ELEMENT
822	&& ref->u.ar.type != AR_FULL)
823	{
824	for (dim = 0; dim < ref->u.ar.dimen; dim++)
825	if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
826	break;
827	if (dim < ref->u.ar.dimen)
828	break;
829	}
830
831	/* Array references with vector subscripts and non-variable expressions
832	need be converted to a one-based descriptor. */
833	if (ref || e->expr_type != EXPR_VARIABLE)
834	{
835	for (dim = 0; dim < e->rank; ++dim)
836	gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
837	gfc_index_one_node);
838	}
839
840	if (e->rank != class_ts.u.derived->components->as->rank)
841	{
842	gcc_assert (class_ts.u.derived->components->as->type
843	== AS_ASSUMED_RANK);
844	if (derived_array
845	&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
846	{
847	*derived_array = gfc_create_var (TREE_TYPE (parmse->expr),
848	"array");
849	gfc_add_modify (&block, *derived_array , parmse->expr);
850	}
851	class_array_data_assign (block: &block, lhs_desc: ctree, rhs_desc: parmse->expr, lhs_type: false);
852	}
853	else
854	{
855	if (gfc_expr_attr (e).codimension)
856	parmse->expr = fold_build1_loc (input_location,
857	VIEW_CONVERT_EXPR,
858	TREE_TYPE (ctree),
859	parmse->expr);
860	gfc_add_modify (&block, ctree, parmse->expr);
861	}
862
863	if (optional)
864	{
865	tmp = gfc_finish_block (&block);
866
867	gfc_init_block (&block);
868	gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
869	if (derived_array && *derived_array != NULL_TREE)
870	gfc_conv_descriptor_data_set (&block, *derived_array,
871	null_pointer_node);
872
873	tmp = build3_v (COND_EXPR, cond_optional, tmp,
874	gfc_finish_block (&block));
875	gfc_add_expr_to_block (&parmse->pre, tmp);
876	}
877	else
878	gfc_add_block_to_block (&parmse->pre, &block);
879	}
880	}
881
882	if (class_ts.u.derived->components->ts.type == BT_DERIVED
883	&& class_ts.u.derived->components->ts.u.derived
884	->attr.unlimited_polymorphic)
885	{
886	/* Take care about initializing the _len component correctly. */
887	ctree = gfc_class_len_get (decl: var);
888	if (UNLIMITED_POLY (e))
889	{
890	gfc_expr *len;
891	gfc_se se;
892
893	len = gfc_find_and_cut_at_last_class_ref (e);
894	gfc_add_len_component (len);
895	gfc_init_se (&se, NULL);
896	gfc_conv_expr (se: &se, expr: len);
897	if (optional)
898	tmp = build3_loc (loc: input_location, code: COND_EXPR, TREE_TYPE (se.expr),
899	arg0: cond_optional, arg1: se.expr,
900	fold_convert (TREE_TYPE (se.expr),
901	integer_zero_node));
902	else
903	tmp = se.expr;
904	gfc_free_expr (len);
905	}
906	else
907	tmp = integer_zero_node;
908	gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
909	tmp));
910	}
911	/* Pass the address of the class object. */
912	parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
913
914	if (optional && optional_alloc_ptr)
915	parmse->expr = build3_loc (loc: input_location, code: COND_EXPR,
916	TREE_TYPE (parmse->expr),
917	arg0: cond_optional, arg1: parmse->expr,
918	fold_convert (TREE_TYPE (parmse->expr),
919	null_pointer_node));
920	}
921
922
923	/* Create a new class container, which is required as scalar coarrays
924	have an array descriptor while normal scalars haven't. Optionally,
925	NULL pointer checks are added if the argument is OPTIONAL. */
926
927	static void
928	class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
929	gfc_typespec class_ts, bool optional)
930	{
931	tree var, ctree, tmp;
932	stmtblock_t block;
933	gfc_ref *ref;
934	gfc_ref *class_ref;
935
936	gfc_init_block (&block);
937
938	class_ref = NULL;
939	for (ref = e->ref; ref; ref = ref->next)
940	{
941	if (ref->type == REF_COMPONENT
942	&& ref->u.c.component->ts.type == BT_CLASS)
943	class_ref = ref;
944	}
945
946	if (class_ref == NULL
947	&& e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
948	tmp = e->symtree->n.sym->backend_decl;
949	else
950	{
951	/* Remove everything after the last class reference, convert the
952	expression and then recover its tailend once more. */
953	gfc_se tmpse;
954	ref = class_ref->next;
955	class_ref->next = NULL;
956	gfc_init_se (&tmpse, NULL);
957	gfc_conv_expr (se: &tmpse, expr: e);
958	class_ref->next = ref;
959	tmp = tmpse.expr;
960	}
961
962	var = gfc_typenode_for_spec (&class_ts);
963	var = gfc_create_var (var, "class");
964
965	ctree = gfc_class_vptr_get (decl: var);
966	gfc_add_modify (&block, ctree,
967	fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
968
969	ctree = gfc_class_data_get (decl: var);
970	tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (decl: tmp));
971	gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
972
973	/* Pass the address of the class object. */
974	parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
975
976	if (optional)
977	{
978	tree cond = gfc_conv_expr_present (e->symtree->n.sym);
979	tree tmp2;
980
981	tmp = gfc_finish_block (&block);
982
983	gfc_init_block (&block);
984	tmp2 = gfc_class_data_get (decl: var);
985	gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
986	null_pointer_node));
987	tmp2 = gfc_finish_block (&block);
988
989	tmp = build3_loc (loc: input_location, code: COND_EXPR, void_type_node,
990	arg0: cond, arg1: tmp, arg2: tmp2);
991	gfc_add_expr_to_block (&parmse->pre, tmp);
992	}
993	else
994	gfc_add_block_to_block (&parmse->pre, &block);
995	}
996
997
998	/* Takes an intrinsic type expression and returns the address of a temporary
999	class object of the 'declared' type. */
1000	void
1001	gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
1002	gfc_typespec class_ts)
1003	{
1004	gfc_symbol *vtab;
1005	gfc_ss *ss;
1006	tree ctree;
1007	tree var;
1008	tree tmp;
1009	int dim;
1010	bool unlimited_poly;
1011
1012	unlimited_poly = class_ts.type == BT_CLASS
1013	&& class_ts.u.derived->components->ts.type == BT_DERIVED
1014	&& class_ts.u.derived->components->ts.u.derived
1015	->attr.unlimited_polymorphic;
1016
1017	/* The intrinsic type needs to be converted to a temporary
1018	CLASS object. */
1019	tmp = gfc_typenode_for_spec (&class_ts);
1020	var = gfc_create_var (tmp, "class");
1021
1022	/* Set the vptr. */
1023	ctree = gfc_class_vptr_get (decl: var);
1024
1025	vtab = gfc_find_vtab (&e->ts);
1026	gcc_assert (vtab);
1027	tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
1028	gfc_add_modify (&parmse->pre, ctree,
1029	fold_convert (TREE_TYPE (ctree), tmp));
1030
1031	/* Now set the data field. */
1032	ctree = gfc_class_data_get (decl: var);
1033	if (parmse->ss && parmse->ss->info->useflags)
1034	{
1035	/* For an array reference in an elemental procedure call we need
1036	to retain the ss to provide the scalarized array reference. */
1037	gfc_conv_expr_reference (se: parmse, expr: e);
1038	tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1039	gfc_add_modify (&parmse->pre, ctree, tmp);
1040	}
1041	else
1042	{
1043	ss = gfc_walk_expr (e);
1044	if (ss == gfc_ss_terminator)
1045	{
1046	parmse->ss = NULL;
1047	gfc_conv_expr_reference (se: parmse, expr: e);
1048	if (class_ts.u.derived->components->as
1049	&& class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
1050	{
1051	tmp = gfc_conv_scalar_to_descriptor (se: parmse, scalar: parmse->expr,
1052	attr: gfc_expr_attr (e));
1053	tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1054	TREE_TYPE (ctree), tmp);
1055	}
1056	else
1057	tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1058	gfc_add_modify (&parmse->pre, ctree, tmp);
1059	}
1060	else
1061	{
1062	parmse->ss = ss;
1063	parmse->use_offset = 1;
1064	gfc_conv_expr_descriptor (parmse, e);
1065
1066	/* Array references with vector subscripts and non-variable expressions
1067	need be converted to a one-based descriptor. */
1068	if (e->expr_type != EXPR_VARIABLE)
1069	{
1070	for (dim = 0; dim < e->rank; ++dim)
1071	gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
1072	dim, gfc_index_one_node);
1073	}
1074
1075	if (class_ts.u.derived->components->as->rank != e->rank)
1076	{
1077	tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1078	TREE_TYPE (ctree), parmse->expr);
1079	gfc_add_modify (&parmse->pre, ctree, tmp);
1080	}
1081	else
1082	gfc_add_modify (&parmse->pre, ctree, parmse->expr);
1083	}
1084	}
1085
1086	gcc_assert (class_ts.type == BT_CLASS);
1087	if (unlimited_poly)
1088	{
1089	ctree = gfc_class_len_get (decl: var);
1090	/* When the actual arg is a char array, then set the _len component of the
1091	unlimited polymorphic entity to the length of the string. */
1092	if (e->ts.type == BT_CHARACTER)
1093	{
1094	/* Start with parmse->string_length because this seems to be set to a
1095	correct value more often. */
1096	if (parmse->string_length)
1097	tmp = parmse->string_length;
1098	/* When the string_length is not yet set, then try the backend_decl of
1099	the cl. */
1100	else if (e->ts.u.cl->backend_decl)
1101	tmp = e->ts.u.cl->backend_decl;
1102	/* If both of the above approaches fail, then try to generate an
1103	expression from the input, which is only feasible currently, when the
1104	expression can be evaluated to a constant one. */
1105	else
1106	{
1107	/* Try to simplify the expression. */
1108	gfc_simplify_expr (e, 0);
1109	if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
1110	{
1111	/* Amazingly all data is present to compute the length of a
1112	constant string, but the expression is not yet there. */
1113	e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
1114	gfc_charlen_int_kind,
1115	&e->where);
1116	mpz_set_ui (e->ts.u.cl->length->value.integer,
1117	e->value.character.length);
1118	gfc_conv_const_charlen (e->ts.u.cl);
1119	e->ts.u.cl->resolved = 1;
1120	tmp = e->ts.u.cl->backend_decl;
1121	}
1122	else
1123	{
1124	gfc_error ("Cannot compute the length of the char array "
1125	"at %L.", &e->where);
1126	}
1127	}
1128	}
1129	else
1130	tmp = integer_zero_node;
1131
1132	gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1133	}
1134
1135	/* Pass the address of the class object. */
1136	parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1137	}
1138
1139
1140	/* Takes a scalarized class array expression and returns the
1141	address of a temporary scalar class object of the 'declared'
1142	type.
1143	OOP-TODO: This could be improved by adding code that branched on
1144	the dynamic type being the same as the declared type. In this case
1145	the original class expression can be passed directly.
1146	optional_alloc_ptr is false when the dummy is neither allocatable
1147	nor a pointer; that's relevant for the optional handling.
1148	Set copyback to true if class container's _data and _vtab pointers
1149	might get modified. */
1150
1151	void
1152	gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
1153	bool elemental, bool copyback, bool optional,
1154	bool optional_alloc_ptr)
1155	{
1156	tree ctree;
1157	tree var;
1158	tree tmp;
1159	tree vptr;
1160	tree cond = NULL_TREE;
1161	tree slen = NULL_TREE;
1162	gfc_ref *ref;
1163	gfc_ref *class_ref;
1164	stmtblock_t block;
1165	bool full_array = false;
1166
1167	gfc_init_block (&block);
1168
1169	class_ref = NULL;
1170	for (ref = e->ref; ref; ref = ref->next)
1171	{
1172	if (ref->type == REF_COMPONENT
1173	&& ref->u.c.component->ts.type == BT_CLASS)
1174	class_ref = ref;
1175
1176	if (ref->next == NULL)
1177	break;
1178	}
1179
1180	if ((ref == NULL || class_ref == ref)
1181	&& !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
1182	&& (!class_ts.u.derived->components->as
1183	|| class_ts.u.derived->components->as->rank != -1))
1184	return;
1185
1186	/* Test for FULL_ARRAY. */
1187	if (e->rank == 0
1188	&& ((gfc_expr_attr (e).codimension && gfc_expr_attr (e).dimension)
1189	|| (class_ts.u.derived->components->as
1190	&& class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)))
1191	full_array = true;
1192	else
1193	gfc_is_class_array_ref (e, &full_array);
1194
1195	/* The derived type needs to be converted to a temporary
1196	CLASS object. */
1197	tmp = gfc_typenode_for_spec (&class_ts);
1198	var = gfc_create_var (tmp, "class");
1199
1200	/* Set the data. */
1201	ctree = gfc_class_data_get (decl: var);
1202	if (class_ts.u.derived->components->as
1203	&& e->rank != class_ts.u.derived->components->as->rank)
1204	{
1205	if (e->rank == 0)
1206	{
1207	tree type = get_scalar_to_descriptor_type (scalar: parmse->expr,
1208	attr: gfc_expr_attr (e));
1209	gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
1210	gfc_get_dtype (type));
1211
1212	tmp = gfc_class_data_get (decl: parmse->expr);
1213	if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1214	tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1215
1216	gfc_conv_descriptor_data_set (&block, ctree, tmp);
1217	}
1218	else
1219	class_array_data_assign (block: &block, lhs_desc: ctree, rhs_desc: parmse->expr, lhs_type: false);
1220	}
1221	else
1222	{
1223	if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1224	parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1225	TREE_TYPE (ctree), parmse->expr);
1226	gfc_add_modify (&block, ctree, parmse->expr);
1227	}
1228
1229	/* Return the data component, except in the case of scalarized array
1230	references, where nullification of the cannot occur and so there
1231	is no need. */
1232	if (!elemental && full_array && copyback)
1233	{
1234	if (class_ts.u.derived->components->as
1235	&& e->rank != class_ts.u.derived->components->as->rank)
1236	{
1237	if (e->rank == 0)
1238	{
1239	tmp = gfc_class_data_get (decl: parmse->expr);
1240	gfc_add_modify (&parmse->post, tmp,
1241	fold_convert (TREE_TYPE (tmp),
1242	gfc_conv_descriptor_data_get (ctree)));
1243	}
1244	else
1245	class_array_data_assign (block: &parmse->post, lhs_desc: parmse->expr, rhs_desc: ctree, lhs_type: true);
1246	}
1247	else
1248	gfc_add_modify (&parmse->post, parmse->expr, ctree);
1249	}
1250
1251	/* Set the vptr. */
1252	ctree = gfc_class_vptr_get (decl: var);
1253
1254	/* The vptr is the second field of the actual argument.
1255	First we have to find the corresponding class reference. */
1256
1257	tmp = NULL_TREE;
1258	if (gfc_is_class_array_function (e)
1259	&& parmse->class_vptr != NULL_TREE)
1260	tmp = parmse->class_vptr;
1261	else if (class_ref == NULL
1262	&& e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1263	{
1264	tmp = e->symtree->n.sym->backend_decl;
1265
1266	if (TREE_CODE (tmp) == FUNCTION_DECL)
1267	tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1268
1269	if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1270	tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1271
1272	slen = build_zero_cst (size_type_node);
1273	}
1274	else if (parmse->class_container != NULL_TREE)
1275	/* Don't redundantly evaluate the expression if the required information
1276	is already available. */
1277	tmp = parmse->class_container;
1278	else
1279	{
1280	/* Remove everything after the last class reference, convert the
1281	expression and then recover its tailend once more. */
1282	gfc_se tmpse;
1283	ref = class_ref->next;
1284	class_ref->next = NULL;
1285	gfc_init_se (&tmpse, NULL);
1286	gfc_conv_expr (se: &tmpse, expr: e);
1287	class_ref->next = ref;
1288	tmp = tmpse.expr;
1289	slen = tmpse.string_length;
1290	}
1291
1292	gcc_assert (tmp != NULL_TREE);
1293
1294	/* Dereference if needs be. */
1295	if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1296	tmp = build_fold_indirect_ref_loc (input_location, tmp);
1297
1298	if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1299	vptr = gfc_class_vptr_get (decl: tmp);
1300	else
1301	vptr = tmp;
1302
1303	gfc_add_modify (&block, ctree,
1304	fold_convert (TREE_TYPE (ctree), vptr));
1305
1306	/* Return the vptr component, except in the case of scalarized array
1307	references, where the dynamic type cannot change. */
1308	if (!elemental && full_array && copyback)
1309	gfc_add_modify (&parmse->post, vptr,
1310	fold_convert (TREE_TYPE (vptr), ctree));
1311
1312	/* For unlimited polymorphic objects also set the _len component. */
1313	if (class_ts.type == BT_CLASS
1314	&& class_ts.u.derived->components
1315	&& class_ts.u.derived->components->ts.u
1316	.derived->attr.unlimited_polymorphic)
1317	{
1318	ctree = gfc_class_len_get (decl: var);
1319	if (UNLIMITED_POLY (e))
1320	tmp = gfc_class_len_get (decl: tmp);
1321	else if (e->ts.type == BT_CHARACTER)
1322	{
1323	gcc_assert (slen != NULL_TREE);
1324	tmp = slen;
1325	}
1326	else
1327	tmp = build_zero_cst (size_type_node);
1328	gfc_add_modify (&parmse->pre, ctree,
1329	fold_convert (TREE_TYPE (ctree), tmp));
1330
1331	/* Return the len component, except in the case of scalarized array
1332	references, where the dynamic type cannot change. */
1333	if (!elemental && full_array && copyback
1334	&& (UNLIMITED_POLY (e) || VAR_P (tmp)))
1335	gfc_add_modify (&parmse->post, tmp,
1336	fold_convert (TREE_TYPE (tmp), ctree));
1337	}
1338
1339	if (optional)
1340	{
1341	tree tmp2;
1342
1343	cond = gfc_conv_expr_present (e->symtree->n.sym);
1344	/* parmse->pre may contain some preparatory instructions for the
1345	temporary array descriptor. Those may only be executed when the
1346	optional argument is set, therefore add parmse->pre's instructions
1347	to block, which is later guarded by an if (optional_arg_given). */
1348	gfc_add_block_to_block (&parmse->pre, &block);
1349	block.head = parmse->pre.head;
1350	parmse->pre.head = NULL_TREE;
1351	tmp = gfc_finish_block (&block);
1352
1353	if (optional_alloc_ptr)
1354	tmp2 = build_empty_stmt (input_location);
1355	else
1356	{
1357	gfc_init_block (&block);
1358
1359	tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (decl: var));
1360	gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1361	null_pointer_node));
1362	tmp2 = gfc_finish_block (&block);
1363	}
1364
1365	tmp = build3_loc (loc: input_location, code: COND_EXPR, void_type_node,
1366	arg0: cond, arg1: tmp, arg2: tmp2);
1367	gfc_add_expr_to_block (&parmse->pre, tmp);
1368	}
1369	else
1370	gfc_add_block_to_block (&parmse->pre, &block);
1371
1372	/* Pass the address of the class object. */
1373	parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1374
1375	if (optional && optional_alloc_ptr)
1376	parmse->expr = build3_loc (loc: input_location, code: COND_EXPR,
1377	TREE_TYPE (parmse->expr),
1378	arg0: cond, arg1: parmse->expr,
1379	fold_convert (TREE_TYPE (parmse->expr),
1380	null_pointer_node));
1381	}
1382
1383
1384	/* Given a class array declaration and an index, returns the address
1385	of the referenced element. */
1386
1387	static tree
1388	gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1389	bool unlimited)
1390	{
1391	tree data, size, tmp, ctmp, offset, ptr;
1392
1393	data = data_comp != NULL_TREE ? data_comp :
1394	gfc_class_data_get (decl: class_decl);
1395	size = gfc_class_vtab_size_get (cl: class_decl);
1396
1397	if (unlimited)
1398	{
1399	tmp = fold_convert (gfc_array_index_type,
1400	gfc_class_len_get (class_decl));
1401	ctmp = fold_build2_loc (input_location, MULT_EXPR,
1402	gfc_array_index_type, size, tmp);
1403	tmp = fold_build2_loc (input_location, GT_EXPR,
1404	logical_type_node, tmp,
1405	build_zero_cst (TREE_TYPE (tmp)));
1406	size = fold_build3_loc (input_location, COND_EXPR,
1407	gfc_array_index_type, tmp, ctmp, size);
1408	}
1409
1410	offset = fold_build2_loc (input_location, MULT_EXPR,
1411	gfc_array_index_type,
1412	index, size);
1413
1414	data = gfc_conv_descriptor_data_get (data);
1415	ptr = fold_convert (pvoid_type_node, data);
1416	ptr = fold_build_pointer_plus_loc (loc: input_location, ptr, off: offset);
1417	return fold_convert (TREE_TYPE (data), ptr);
1418	}
1419
1420
1421	/* Copies one class expression to another, assuming that if either
1422	'to' or 'from' are arrays they are packed. Should 'from' be
1423	NULL_TREE, the initialization expression for 'to' is used, assuming
1424	that the _vptr is set. */
1425
1426	tree
1427	gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1428	{
1429	tree fcn;
1430	tree fcn_type;
1431	tree from_data;
1432	tree from_len;
1433	tree to_data;
1434	tree to_len;
1435	tree to_ref;
1436	tree from_ref;
1437	vec<tree, va_gc> *args;
1438	tree tmp;
1439	tree stdcopy;
1440	tree extcopy;
1441	tree index;
1442	bool is_from_desc = false, is_to_class = false;
1443
1444	args = NULL;
1445	/* To prevent warnings on uninitialized variables. */
1446	from_len = to_len = NULL_TREE;
1447
1448	if (from != NULL_TREE)
1449	fcn = gfc_class_vtab_copy_get (cl: from);
1450	else
1451	fcn = gfc_class_vtab_copy_get (cl: to);
1452
1453	fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1454
1455	if (from != NULL_TREE)
1456	{
1457	is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1458	if (is_from_desc)
1459	{
1460	from_data = from;
1461	from = GFC_DECL_SAVED_DESCRIPTOR (from);
1462	}
1463	else
1464	{
1465	/* Check that from is a class. When the class is part of a coarray,
1466	then from is a common pointer and is to be used as is. */
1467	tmp = POINTER_TYPE_P (TREE_TYPE (from))
1468	? build_fold_indirect_ref (from) : from;
1469	from_data =
1470	(GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1471	|| (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1472	? gfc_class_data_get (decl: from) : from;
1473	is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1474	}
1475	}
1476	else
1477	from_data = gfc_class_vtab_def_init_get (cl: to);
1478
1479	if (unlimited)
1480	{
1481	if (from != NULL_TREE && unlimited)
1482	from_len = gfc_class_len_or_zero_get (decl: from);
1483	else
1484	from_len = build_zero_cst (size_type_node);
1485	}
1486
1487	if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1488	{
1489	is_to_class = true;
1490	to_data = gfc_class_data_get (decl: to);
1491	if (unlimited)
1492	to_len = gfc_class_len_get (decl: to);
1493	}
1494	else
1495	/* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1496	to_data = to;
1497
1498	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1499	{
1500	stmtblock_t loopbody;
1501	stmtblock_t body;
1502	stmtblock_t ifbody;
1503	gfc_loopinfo loop;
1504	tree orig_nelems = nelems; /* Needed for bounds check. */
1505
1506	gfc_init_block (&body);
1507	tmp = fold_build2_loc (input_location, MINUS_EXPR,
1508	gfc_array_index_type, nelems,
1509	gfc_index_one_node);
1510	nelems = gfc_evaluate_now (tmp, &body);
1511	index = gfc_create_var (gfc_array_index_type, "S");
1512
1513	if (is_from_desc)
1514	{
1515	from_ref = gfc_get_class_array_ref (index, class_decl: from, data_comp: from_data,
1516	unlimited);
1517	vec_safe_push (v&: args, obj: from_ref);
1518	}
1519	else
1520	vec_safe_push (v&: args, obj: from_data);
1521
1522	if (is_to_class)
1523	to_ref = gfc_get_class_array_ref (index, class_decl: to, data_comp: to_data, unlimited);
1524	else
1525	{
1526	tmp = gfc_conv_array_data (to);
1527	tmp = build_fold_indirect_ref_loc (input_location, tmp);
1528	to_ref = gfc_build_addr_expr (NULL_TREE,
1529	gfc_build_array_ref (tmp, index, to));
1530	}
1531	vec_safe_push (v&: args, obj: to_ref);
1532
1533	/* Add bounds check. */
1534	if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1535	{
1536	char *msg;
1537	const char *name = "<<unknown>>";
1538	tree from_len;
1539
1540	if (DECL_P (to))
1541	name = (const char *)(DECL_NAME (to)->identifier.id.str);
1542
1543	from_len = gfc_conv_descriptor_size (from_data, 1);
1544	from_len = fold_convert (TREE_TYPE (orig_nelems), from_len);
1545	tmp = fold_build2_loc (input_location, NE_EXPR,
1546	logical_type_node, from_len, orig_nelems);
1547	msg = xasprintf ("Array bound mismatch for dimension %d "
1548	"of array '%s' (%%ld/%%ld)",
1549	1, name);
1550
1551	gfc_trans_runtime_check (true, false, tmp, &body,
1552	&gfc_current_locus, msg,
1553	fold_convert (long_integer_type_node, orig_nelems),
1554	fold_convert (long_integer_type_node, from_len));
1555
1556	free (ptr: msg);
1557	}
1558
1559	tmp = build_call_vec (fcn_type, fcn, args);
1560
1561	/* Build the body of the loop. */
1562	gfc_init_block (&loopbody);
1563	gfc_add_expr_to_block (&loopbody, tmp);
1564
1565	/* Build the loop and return. */
1566	gfc_init_loopinfo (&loop);
1567	loop.dimen = 1;
1568	loop.from[0] = gfc_index_zero_node;
1569	loop.loopvar[0] = index;
1570	loop.to[0] = nelems;
1571	gfc_trans_scalarizing_loops (&loop, &loopbody);
1572	gfc_init_block (&ifbody);
1573	gfc_add_block_to_block (&ifbody, &loop.pre);
1574	stdcopy = gfc_finish_block (&ifbody);
1575	/* In initialization mode from_len is a constant zero. */
1576	if (unlimited && !integer_zerop (from_len))
1577	{
1578	vec_safe_push (v&: args, obj: from_len);
1579	vec_safe_push (v&: args, obj: to_len);
1580	tmp = build_call_vec (fcn_type, fcn, args);
1581	/* Build the body of the loop. */
1582	gfc_init_block (&loopbody);
1583	gfc_add_expr_to_block (&loopbody, tmp);
1584
1585	/* Build the loop and return. */
1586	gfc_init_loopinfo (&loop);
1587	loop.dimen = 1;
1588	loop.from[0] = gfc_index_zero_node;
1589	loop.loopvar[0] = index;
1590	loop.to[0] = nelems;
1591	gfc_trans_scalarizing_loops (&loop, &loopbody);
1592	gfc_init_block (&ifbody);
1593	gfc_add_block_to_block (&ifbody, &loop.pre);
1594	extcopy = gfc_finish_block (&ifbody);
1595
1596	tmp = fold_build2_loc (input_location, GT_EXPR,
1597	logical_type_node, from_len,
1598	build_zero_cst (TREE_TYPE (from_len)));
1599	tmp = fold_build3_loc (input_location, COND_EXPR,
1600	void_type_node, tmp, extcopy, stdcopy);
1601	gfc_add_expr_to_block (&body, tmp);
1602	tmp = gfc_finish_block (&body);
1603	}
1604	else
1605	{
1606	gfc_add_expr_to_block (&body, stdcopy);
1607	tmp = gfc_finish_block (&body);
1608	}
1609	gfc_cleanup_loop (&loop);
1610	}
1611	else
1612	{
1613	gcc_assert (!is_from_desc);
1614	vec_safe_push (v&: args, obj: from_data);
1615	vec_safe_push (v&: args, obj: to_data);
1616	stdcopy = build_call_vec (fcn_type, fcn, args);
1617
1618	/* In initialization mode from_len is a constant zero. */
1619	if (unlimited && !integer_zerop (from_len))
1620	{
1621	vec_safe_push (v&: args, obj: from_len);
1622	vec_safe_push (v&: args, obj: to_len);
1623	extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args);
1624	tmp = fold_build2_loc (input_location, GT_EXPR,
1625	logical_type_node, from_len,
1626	build_zero_cst (TREE_TYPE (from_len)));
1627	tmp = fold_build3_loc (input_location, COND_EXPR,
1628	void_type_node, tmp, extcopy, stdcopy);
1629	}
1630	else
1631	tmp = stdcopy;
1632	}
1633
1634	/* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1635	if (from == NULL_TREE)
1636	{
1637	tree cond;
1638	cond = fold_build2_loc (input_location, NE_EXPR,
1639	logical_type_node,
1640	from_data, null_pointer_node);
1641	tmp = fold_build3_loc (input_location, COND_EXPR,
1642	void_type_node, cond,
1643	tmp, build_empty_stmt (input_location));
1644	}
1645
1646	return tmp;
1647	}
1648
1649
1650	static tree
1651	gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1652	{
1653	gfc_actual_arglist *actual;
1654	gfc_expr *ppc;
1655	gfc_code *ppc_code;
1656	tree res;
1657
1658	actual = gfc_get_actual_arglist ();
1659	actual->expr = gfc_copy_expr (rhs);
1660	actual->next = gfc_get_actual_arglist ();
1661	actual->next->expr = gfc_copy_expr (lhs);
1662	ppc = gfc_copy_expr (obj);
1663	gfc_add_vptr_component (ppc);
1664	gfc_add_component_ref (ppc, "_copy");
1665	ppc_code = gfc_get_code (EXEC_CALL);
1666	ppc_code->resolved_sym = ppc->symtree->n.sym;
1667	/* Although '_copy' is set to be elemental in class.cc, it is
1668	not staying that way. Find out why, sometime.... */
1669	ppc_code->resolved_sym->attr.elemental = 1;
1670	ppc_code->ext.actual = actual;
1671	ppc_code->expr1 = ppc;
1672	/* Since '_copy' is elemental, the scalarizer will take care
1673	of arrays in gfc_trans_call. */
1674	res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1675	gfc_free_statements (ppc_code);
1676
1677	if (UNLIMITED_POLY(obj))
1678	{
1679	/* Check if rhs is non-NULL. */
1680	gfc_se src;
1681	gfc_init_se (&src, NULL);
1682	gfc_conv_expr (se: &src, expr: rhs);
1683	src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1684	tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1685	src.expr, fold_convert (TREE_TYPE (src.expr),
1686	null_pointer_node));
1687	res = build3_loc (loc: input_location, code: COND_EXPR, TREE_TYPE (res), arg0: cond, arg1: res,
1688	arg2: build_empty_stmt (input_location));
1689	}
1690
1691	return res;
1692	}
1693
1694	/* Special case for initializing a polymorphic dummy with INTENT(OUT).
1695	A MEMCPY is needed to copy the full data from the default initializer
1696	of the dynamic type. */
1697
1698	tree
1699	gfc_trans_class_init_assign (gfc_code *code)
1700	{
1701	stmtblock_t block;
1702	tree tmp;
1703	gfc_se dst,src,memsz;
1704	gfc_expr *lhs, *rhs, *sz;
1705
1706	gfc_start_block (&block);
1707
1708	lhs = gfc_copy_expr (code->expr1);
1709
1710	rhs = gfc_copy_expr (code->expr1);
1711	gfc_add_vptr_component (rhs);
1712
1713	/* Make sure that the component backend_decls have been built, which
1714	will not have happened if the derived types concerned have not
1715	been referenced. */
1716	gfc_get_derived_type (derived: rhs->ts.u.derived);
1717	gfc_add_def_init_component (rhs);
1718	/* The _def_init is always scalar. */
1719	rhs->rank = 0;
1720
1721	if (code->expr1->ts.type == BT_CLASS
1722	&& CLASS_DATA (code->expr1)->attr.dimension)
1723	{
1724	gfc_array_spec *tmparr = gfc_get_array_spec ();
1725	*tmparr = *CLASS_DATA (code->expr1)->as;
1726	/* Adding the array ref to the class expression results in correct
1727	indexing to the dynamic type. */
1728	gfc_add_full_array_ref (lhs, tmparr);
1729	tmp = gfc_trans_class_array_init_assign (rhs, lhs, obj: code->expr1);
1730	}
1731	else
1732	{
1733	/* Scalar initialization needs the _data component. */
1734	gfc_add_data_component (lhs);
1735	sz = gfc_copy_expr (code->expr1);
1736	gfc_add_vptr_component (sz);
1737	gfc_add_size_component (sz);
1738
1739	gfc_init_se (&dst, NULL);
1740	gfc_init_se (&src, NULL);
1741	gfc_init_se (&memsz, NULL);
1742	gfc_conv_expr (se: &dst, expr: lhs);
1743	gfc_conv_expr (se: &src, expr: rhs);
1744	gfc_conv_expr (se: &memsz, expr: sz);
1745	gfc_add_block_to_block (&block, &src.pre);
1746	src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1747
1748	tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1749
1750	if (UNLIMITED_POLY(code->expr1))
1751	{
1752	/* Check if _def_init is non-NULL. */
1753	tree cond = fold_build2_loc (input_location, NE_EXPR,
1754	logical_type_node, src.expr,
1755	fold_convert (TREE_TYPE (src.expr),
1756	null_pointer_node));
1757	tmp = build3_loc (loc: input_location, code: COND_EXPR, TREE_TYPE (tmp), arg0: cond,
1758	arg1: tmp, arg2: build_empty_stmt (input_location));
1759	}
1760	}
1761
1762	if (code->expr1->symtree->n.sym->attr.dummy
1763	&& (code->expr1->symtree->n.sym->attr.optional
1764	|| code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master))
1765	{
1766	tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1767	tmp = build3_loc (loc: input_location, code: COND_EXPR, TREE_TYPE (tmp),
1768	arg0: present, arg1: tmp,
1769	arg2: build_empty_stmt (input_location));
1770	}
1771
1772	gfc_add_expr_to_block (&block, tmp);
1773
1774	return gfc_finish_block (&block);
1775	}
1776
1777
1778	/* Class valued elemental function calls or class array elements arriving
1779	in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
1780	is used to ensure that the rhs dynamic type is assigned to the lhs. */
1781
1782	static bool
1783	trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
1784	{
1785	tree fcn;
1786	tree rse_expr;
1787	tree class_data;
1788	tree tmp;
1789	tree zero;
1790	tree cond;
1791	tree final_cond;
1792	stmtblock_t inner_block;
1793	bool is_descriptor;
1794	bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR;
1795	bool not_lhs_array_type;
1796
1797	/* Temporaries arising from dependencies in assignment get cast as a
1798	character type of the dynamic size of the rhs. Use the vptr copy
1799	for this case. */
1800	tmp = TREE_TYPE (lse->expr);
1801	not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE
1802	&& TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE);
1803
1804	/* Use ordinary assignment if the rhs is not a call expression or
1805	the lhs is not a class entity or an array(ie. character) type. */
1806	if ((not_call_expr && gfc_get_class_from_expr (expr: lse->expr) == NULL_TREE)
1807	&& not_lhs_array_type)
1808	return false;
1809
1810	/* Ordinary assignment can be used if both sides are class expressions
1811	since the dynamic type is preserved by copying the vptr. This
1812	should only occur, where temporaries are involved. */
1813	if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
1814	&& GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
1815	return false;
1816
1817	/* Fix the class expression and the class data of the rhs. */
1818	if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
1819	|| not_call_expr)
1820	{
1821	tmp = gfc_get_class_from_expr (expr: rse->expr);
1822	if (tmp == NULL_TREE)
1823	return false;
1824	rse_expr = gfc_evaluate_now (tmp, block);
1825	}
1826	else
1827	rse_expr = gfc_evaluate_now (rse->expr, block);
1828
1829	class_data = gfc_class_data_get (decl: rse_expr);
1830
1831	/* Check that the rhs data is not null. */
1832	is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data));
1833	if (is_descriptor)
1834	class_data = gfc_conv_descriptor_data_get (class_data);
1835	class_data = gfc_evaluate_now (class_data, block);
1836
1837	zero = build_int_cst (TREE_TYPE (class_data), 0);
1838	cond = fold_build2_loc (input_location, NE_EXPR,
1839	logical_type_node,
1840	class_data, zero);
1841
1842	/* Copy the rhs to the lhs. */
1843	fcn = gfc_vptr_copy_get (vptr: gfc_class_vptr_get (decl: rse_expr));
1844	fcn = build_fold_indirect_ref_loc (input_location, fcn);
1845	tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block);
1846	tmp = is_descriptor ? tmp : class_data;
1847	tmp = build_call_expr_loc (input_location, fcn, 2, tmp,
1848	gfc_build_addr_expr (NULL, lse->expr));
1849	gfc_add_expr_to_block (block, tmp);
1850
1851	/* Only elemental function results need to be finalised and freed. */
1852	if (not_call_expr)
1853	return true;
1854
1855	/* Finalize the class data if needed. */
1856	gfc_init_block (&inner_block);
1857	fcn = gfc_vptr_final_get (vptr: gfc_class_vptr_get (decl: rse_expr));
1858	zero = build_int_cst (TREE_TYPE (fcn), 0);
1859	final_cond = fold_build2_loc (input_location, NE_EXPR,
1860	logical_type_node, fcn, zero);
1861	fcn = build_fold_indirect_ref_loc (input_location, fcn);
1862	tmp = build_call_expr_loc (input_location, fcn, 1, class_data);
1863	tmp = build3_v (COND_EXPR, final_cond,
1864	tmp, build_empty_stmt (input_location));
1865	gfc_add_expr_to_block (&inner_block, tmp);
1866
1867	/* Free the class data. */
1868	tmp = gfc_call_free (class_data);
1869	tmp = build3_v (COND_EXPR, cond, tmp,
1870	build_empty_stmt (input_location));
1871	gfc_add_expr_to_block (&inner_block, tmp);
1872
1873	/* Finish the inner block and subject it to the condition on the
1874	class data being non-zero. */
1875	tmp = gfc_finish_block (&inner_block);
1876	tmp = build3_v (COND_EXPR, cond, tmp,
1877	build_empty_stmt (input_location));
1878	gfc_add_expr_to_block (block, tmp);
1879
1880	return true;
1881	}
1882
1883	/* End of prototype trans-class.c */
1884
1885
1886	static void
1887	realloc_lhs_warning (bt type, bool array, locus *where)
1888	{
1889	if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
1890	gfc_warning (opt: OPT_Wrealloc_lhs,
1891	"Code for reallocating the allocatable array at %L will "
1892	"be added", where);
1893	else if (warn_realloc_lhs_all)
1894	gfc_warning (opt: OPT_Wrealloc_lhs_all,
1895	"Code for reallocating the allocatable variable at %L "
1896	"will be added", where);
1897	}
1898
1899
1900	static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
1901	gfc_expr *);
1902
1903	/* Copy the scalarization loop variables. */
1904
1905	static void
1906	gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
1907	{
1908	dest->ss = src->ss;
1909	dest->loop = src->loop;
1910	}
1911
1912
1913	/* Initialize a simple expression holder.
1914
1915	Care must be taken when multiple se are created with the same parent.
1916	The child se must be kept in sync. The easiest way is to delay creation
1917	of a child se until after the previous se has been translated. */
1918
1919	void
1920	gfc_init_se (gfc_se * se, gfc_se * parent)
1921	{
1922	memset (s: se, c: 0, n: sizeof (gfc_se));
1923	gfc_init_block (&se->pre);
1924	gfc_init_block (&se->finalblock);
1925	gfc_init_block (&se->post);
1926
1927	se->parent = parent;
1928
1929	if (parent)
1930	gfc_copy_se_loopvars (dest: se, src: parent);
1931	}
1932
1933
1934	/* Advances to the next SS in the chain. Use this rather than setting
1935	se->ss = se->ss->next because all the parents needs to be kept in sync.
1936	See gfc_init_se. */
1937
1938	void
1939	gfc_advance_se_ss_chain (gfc_se * se)
1940	{
1941	gfc_se *p;
1942	gfc_ss *ss;
1943
1944	gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
1945
1946	p = se;
1947	/* Walk down the parent chain. */
1948	while (p != NULL)
1949	{
1950	/* Simple consistency check. */
1951	gcc_assert (p->parent == NULL || p->parent->ss == p->ss
1952	|| p->parent->ss->nested_ss == p->ss);
1953
1954	/* If we were in a nested loop, the next scalarized expression can be
1955	on the parent ss' next pointer. Thus we should not take the next
1956	pointer blindly, but rather go up one nest level as long as next
1957	is the end of chain. */
1958	ss = p->ss;
1959	while (ss->next == gfc_ss_terminator && ss->parent != NULL)
1960	ss = ss->parent;
1961
1962	p->ss = ss->next;
1963
1964	p = p->parent;
1965	}
1966	}
1967
1968
1969	/* Ensures the result of the expression as either a temporary variable
1970	or a constant so that it can be used repeatedly. */
1971
1972	void
1973	gfc_make_safe_expr (gfc_se * se)
1974	{
1975	tree var;
1976
1977	if (CONSTANT_CLASS_P (se->expr))
1978	return;
1979
1980	/* We need a temporary for this result. */
1981	var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1982	gfc_add_modify (&se->pre, var, se->expr);
1983	se->expr = var;
1984	}
1985
1986
1987	/* Return an expression which determines if a dummy parameter is present.
1988	Also used for arguments to procedures with multiple entry points. */
1989
1990	tree
1991	gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
1992	{
1993	tree decl, orig_decl, cond;
1994
1995	gcc_assert (sym->attr.dummy);
1996	orig_decl = decl = gfc_get_symbol_decl (sym);
1997
1998	/* Intrinsic scalars with VALUE attribute which are passed by value
1999	use a hidden argument to denote the present status. */
2000	if (sym->attr.value && !sym->attr.dimension
2001	&& sym->ts.type != BT_CLASS && !gfc_bt_struct (sym->ts.type))
2002	{
2003	char name[GFC_MAX_SYMBOL_LEN + 2];
2004	tree tree_name;
2005
2006	gcc_assert (TREE_CODE (decl) == PARM_DECL);
2007	name[0] = '.';
2008	strcpy (dest: &name[1], src: sym->name);
2009	tree_name = get_identifier (name);
2010
2011	/* Walk function argument list to find hidden arg. */
2012	cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
2013	for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
2014	if (DECL_NAME (cond) == tree_name
2015	&& DECL_ARTIFICIAL (cond))
2016	break;
2017
2018	gcc_assert (cond);
2019	return cond;
2020	}
2021
2022	/* Assumed-shape arrays use a local variable for the array data;
2023	the actual PARAM_DECL is in a saved decl. As the local variable
2024	is NULL, it can be checked instead, unless use_saved_desc is
2025	requested. */
2026
2027	if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
2028	{
2029	gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
2030	|| GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
2031	decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
2032	}
2033
2034	cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
2035	fold_convert (TREE_TYPE (decl), null_pointer_node));
2036
2037	/* Fortran 2008 allows to pass null pointers and non-associated pointers
2038	as actual argument to denote absent dummies. For array descriptors,
2039	we thus also need to check the array descriptor. For BT_CLASS, it
2040	can also occur for scalars and F2003 due to type->class wrapping and
2041	class->class wrapping. Note further that BT_CLASS always uses an
2042	array descriptor for arrays, also for explicit-shape/assumed-size.
2043	For assumed-rank arrays, no local variable is generated, hence,
2044	the following also applies with !use_saved_desc. */
2045
2046	if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
2047	&& !sym->attr.allocatable
2048	&& ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
2049	|| (sym->ts.type == BT_CLASS
2050	&& !CLASS_DATA (sym)->attr.allocatable
2051	&& !CLASS_DATA (sym)->attr.class_pointer))
2052	&& ((gfc_option.allow_std & GFC_STD_F2008) != 0
2053	|| sym->ts.type == BT_CLASS))
2054	{
2055	tree tmp;
2056
2057	if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
2058	|| sym->as->type == AS_ASSUMED_RANK
2059	|| sym->attr.codimension))
2060	|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
2061	{
2062	tmp = build_fold_indirect_ref_loc (input_location, decl);
2063	if (sym->ts.type == BT_CLASS)
2064	tmp = gfc_class_data_get (decl: tmp);
2065	tmp = gfc_conv_array_data (tmp);
2066	}
2067	else if (sym->ts.type == BT_CLASS)
2068	tmp = gfc_class_data_get (decl);
2069	else
2070	tmp = NULL_TREE;
2071
2072	if (tmp != NULL_TREE)
2073	{
2074	tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
2075	fold_convert (TREE_TYPE (tmp), null_pointer_node));
2076	cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2077	logical_type_node, cond, tmp);
2078	}
2079	}
2080
2081	return cond;
2082	}
2083
2084
2085	/* Converts a missing, dummy argument into a null or zero. */
2086
2087	void
2088	gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
2089	{
2090	tree present;
2091	tree tmp;
2092
2093	present = gfc_conv_expr_present (sym: arg->symtree->n.sym);
2094
2095	if (kind > 0)
2096	{
2097	/* Create a temporary and convert it to the correct type. */
2098	tmp = gfc_get_int_type (kind);
2099	tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
2100	se->expr));
2101
2102	/* Test for a NULL value. */
2103	tmp = build3_loc (loc: input_location, code: COND_EXPR, TREE_TYPE (tmp), arg0: present,
2104	arg1: tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
2105	tmp = gfc_evaluate_now (tmp, &se->pre);
2106	se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
2107	}
2108	else
2109	{
2110	tmp = build3_loc (loc: input_location, code: COND_EXPR, TREE_TYPE (se->expr),
2111	arg0: present, arg1: se->expr,
2112	arg2: build_zero_cst (TREE_TYPE (se->expr)));
2113	tmp = gfc_evaluate_now (tmp, &se->pre);
2114	se->expr = tmp;
2115	}
2116
2117	if (ts.type == BT_CHARACTER)
2118	{
2119	tmp = build_int_cst (gfc_charlen_type_node, 0);
2120	tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
2121	present, se->string_length, tmp);
2122	tmp = gfc_evaluate_now (tmp, &se->pre);
2123	se->string_length = tmp;
2124	}
2125	return;
2126	}
2127
2128
2129	/* Get the character length of an expression, looking through gfc_refs
2130	if necessary. */
2131
2132	tree
2133	gfc_get_expr_charlen (gfc_expr *e)
2134	{
2135	gfc_ref *r;
2136	tree length;
2137	tree previous = NULL_TREE;
2138	gfc_se se;
2139
2140	gcc_assert (e->expr_type == EXPR_VARIABLE
2141	&& e->ts.type == BT_CHARACTER);
2142
2143	length = NULL; /* To silence compiler warning. */
2144
2145	if (is_subref_array (e) && e->ts.u.cl->length)
2146	{
2147	gfc_se tmpse;
2148	gfc_init_se (se: &tmpse, NULL);
2149	gfc_conv_expr_type (se: &tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
2150	e->ts.u.cl->backend_decl = tmpse.expr;
2151	return tmpse.expr;
2152	}
2153
2154	/* First candidate: if the variable is of type CHARACTER, the
2155	expression's length could be the length of the character
2156	variable. */
2157	if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2158	length = e->symtree->n.sym->ts.u.cl->backend_decl;
2159
2160	/* Look through the reference chain for component references. */
2161	for (r = e->ref; r; r = r->next)
2162	{
2163	previous = length;
2164	switch (r->type)
2165	{
2166	case REF_COMPONENT:
2167	if (r->u.c.component->ts.type == BT_CHARACTER)
2168	length = r->u.c.component->ts.u.cl->backend_decl;
2169	break;
2170
2171	case REF_ARRAY:
2172	/* Do nothing. */
2173	break;
2174
2175	case REF_SUBSTRING:
2176	gfc_init_se (se: &se, NULL);
2177	gfc_conv_expr_type (se: &se, r->u.ss.start, gfc_charlen_type_node);
2178	length = se.expr;
2179	if (r->u.ss.end)
2180	gfc_conv_expr_type (se: &se, r->u.ss.end, gfc_charlen_type_node);
2181	else
2182	se.expr = previous;
2183	length = fold_build2_loc (input_location, MINUS_EXPR,
2184	gfc_charlen_type_node,
2185	se.expr, length);
2186	length = fold_build2_loc (input_location, PLUS_EXPR,
2187	gfc_charlen_type_node, length,
2188	gfc_index_one_node);
2189	break;
2190
2191	default:
2192	gcc_unreachable ();
2193	break;
2194	}
2195	}
2196
2197	gcc_assert (length != NULL);
2198	return length;
2199	}
2200
2201
2202	/* Return for an expression the backend decl of the coarray. */
2203
2204	tree
2205	gfc_get_tree_for_caf_expr (gfc_expr *expr)
2206	{
2207	tree caf_decl;
2208	bool found = false;
2209	gfc_ref *ref;
2210
2211	gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
2212
2213	/* Not-implemented diagnostic. */
2214	if (expr->symtree->n.sym->ts.type == BT_CLASS
2215	&& UNLIMITED_POLY (expr->symtree->n.sym)
2216	&& CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2217	gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
2218	"%L is not supported", &expr->where);
2219
2220	for (ref = expr->ref; ref; ref = ref->next)
2221	if (ref->type == REF_COMPONENT)
2222	{
2223	if (ref->u.c.component->ts.type == BT_CLASS
2224	&& UNLIMITED_POLY (ref->u.c.component)
2225	&& CLASS_DATA (ref->u.c.component)->attr.codimension)
2226	gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
2227	"component at %L is not supported", &expr->where);
2228	}
2229
2230	/* Make sure the backend_decl is present before accessing it. */
2231	caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
2232	? gfc_get_symbol_decl (expr->symtree->n.sym)
2233	: expr->symtree->n.sym->backend_decl;
2234
2235	if (expr->symtree->n.sym->ts.type == BT_CLASS)
2236	{
2237	if (expr->ref && expr->ref->type == REF_ARRAY)
2238	{
2239	caf_decl = gfc_class_data_get (decl: caf_decl);
2240	if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2241	return caf_decl;
2242	}
2243	for (ref = expr->ref; ref; ref = ref->next)
2244	{
2245	if (ref->type == REF_COMPONENT
2246	&& strcmp (s1: ref->u.c.component->name, s2: "_data") != 0)
2247	{
2248	caf_decl = gfc_class_data_get (decl: caf_decl);
2249	if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2250	return caf_decl;
2251	break;
2252	}
2253	else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
2254	break;
2255	}
2256	}
2257	if (expr->symtree->n.sym->attr.codimension)
2258	return caf_decl;
2259
2260	/* The following code assumes that the coarray is a component reachable via
2261	only scalar components/variables; the Fortran standard guarantees this. */
2262
2263	for (ref = expr->ref; ref; ref = ref->next)
2264	if (ref->type == REF_COMPONENT)
2265	{
2266	gfc_component *comp = ref->u.c.component;
2267
2268	if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
2269	caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2270	caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
2271	TREE_TYPE (comp->backend_decl), caf_decl,
2272	comp->backend_decl, NULL_TREE);
2273	if (comp->ts.type == BT_CLASS)
2274	{
2275	caf_decl = gfc_class_data_get (decl: caf_decl);
2276	if (CLASS_DATA (comp)->attr.codimension)
2277	{
2278	found = true;
2279	break;
2280	}
2281	}
2282	if (comp->attr.codimension)
2283	{
2284	found = true;
2285	break;
2286	}
2287	}
2288	gcc_assert (found && caf_decl);
2289	return caf_decl;
2290	}
2291
2292
2293	/* Obtain the Coarray token - and optionally also the offset. */
2294
2295	void
2296	gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
2297	tree se_expr, gfc_expr *expr)
2298	{
2299	tree tmp;
2300
2301	/* Coarray token. */
2302	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2303	{
2304	gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
2305	== GFC_ARRAY_ALLOCATABLE
2306	|| expr->symtree->n.sym->attr.select_type_temporary);
2307	*token = gfc_conv_descriptor_token (caf_decl);
2308	}
2309	else if (DECL_LANG_SPECIFIC (caf_decl)
2310	&& GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
2311	*token = GFC_DECL_TOKEN (caf_decl);
2312	else
2313	{
2314	gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
2315	&& GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
2316	*token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
2317	}
2318
2319	if (offset == NULL)
2320	return;
2321
2322	/* Offset between the coarray base address and the address wanted. */
2323	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
2324	&& (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
2325	|| GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
2326	*offset = build_int_cst (gfc_array_index_type, 0);
2327	else if (DECL_LANG_SPECIFIC (caf_decl)
2328	&& GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
2329	*offset = GFC_DECL_CAF_OFFSET (caf_decl);
2330	else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2331	*offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2332	else
2333	*offset = build_int_cst (gfc_array_index_type, 0);
2334
2335	if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2336	&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2337	{
2338	tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2339	tmp = gfc_conv_descriptor_data_get (tmp);
2340	}
2341	else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2342	tmp = gfc_conv_descriptor_data_get (se_expr);
2343	else
2344	{
2345	gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2346	tmp = se_expr;
2347	}
2348
2349	*offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2350	*offset, fold_convert (gfc_array_index_type, tmp));
2351
2352	if (expr->symtree->n.sym->ts.type == BT_DERIVED
2353	&& expr->symtree->n.sym->attr.codimension
2354	&& expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2355	{
2356	gfc_expr *base_expr = gfc_copy_expr (expr);
2357	gfc_ref *ref = base_expr->ref;
2358	gfc_se base_se;
2359
2360	// Iterate through the refs until the last one.
2361	while (ref->next)
2362	ref = ref->next;
2363
2364	if (ref->type == REF_ARRAY
2365	&& ref->u.ar.type != AR_FULL)
2366	{
2367	const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2368	int i;
2369	for (i = 0; i < ranksum; ++i)
2370	{
2371	ref->u.ar.start[i] = NULL;
2372	ref->u.ar.end[i] = NULL;
2373	}
2374	ref->u.ar.type = AR_FULL;
2375	}
2376	gfc_init_se (se: &base_se, NULL);
2377	if (gfc_caf_attr (base_expr).dimension)
2378	{
2379	gfc_conv_expr_descriptor (&base_se, base_expr);
2380	tmp = gfc_conv_descriptor_data_get (base_se.expr);
2381	}
2382	else
2383	{
2384	gfc_conv_expr (se: &base_se, expr: base_expr);
2385	tmp = base_se.expr;
2386	}
2387
2388	gfc_free_expr (base_expr);
2389	gfc_add_block_to_block (&se->pre, &base_se.pre);
2390	gfc_add_block_to_block (&se->post, &base_se.post);
2391	}
2392	else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2393	tmp = gfc_conv_descriptor_data_get (caf_decl);
2394	else
2395	{
2396	gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2397	tmp = caf_decl;
2398	}
2399
2400	*offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2401	fold_convert (gfc_array_index_type, *offset),
2402	fold_convert (gfc_array_index_type, tmp));
2403	}
2404
2405
2406	/* Convert the coindex of a coarray into an image index; the result is
2407	image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2408	+ (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2409
2410	tree
2411	gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2412	{
2413	gfc_ref *ref;
2414	tree lbound, ubound, extent, tmp, img_idx;
2415	gfc_se se;
2416	int i;
2417
2418	for (ref = e->ref; ref; ref = ref->next)
2419	if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2420	break;
2421	gcc_assert (ref != NULL);
2422
2423	if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2424	{
2425	return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2426	integer_zero_node);
2427	}
2428
2429	img_idx = build_zero_cst (gfc_array_index_type);
2430	extent = build_one_cst (gfc_array_index_type);
2431	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2432	for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2433	{
2434	gfc_init_se (se: &se, NULL);
2435	gfc_conv_expr_type (se: &se, ref->u.ar.start[i], gfc_array_index_type);
2436	gfc_add_block_to_block (block, &se.pre);
2437	lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2438	tmp = fold_build2_loc (input_location, MINUS_EXPR,
2439	TREE_TYPE (lbound), se.expr, lbound);
2440	tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2441	extent, tmp);
2442	img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2443	TREE_TYPE (tmp), img_idx, tmp);
2444	if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2445	{
2446	ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2447	tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2448	extent = fold_build2_loc (input_location, MULT_EXPR,
2449	TREE_TYPE (tmp), extent, tmp);
2450	}
2451	}
2452	else
2453	for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2454	{
2455	gfc_init_se (se: &se, NULL);
2456	gfc_conv_expr_type (se: &se, ref->u.ar.start[i], gfc_array_index_type);
2457	gfc_add_block_to_block (block, &se.pre);
2458	lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2459	tmp = fold_build2_loc (input_location, MINUS_EXPR,
2460	TREE_TYPE (lbound), se.expr, lbound);
2461	tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2462	extent, tmp);
2463	img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2464	img_idx, tmp);
2465	if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2466	{
2467	ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2468	tmp = fold_build2_loc (input_location, MINUS_EXPR,
2469	TREE_TYPE (ubound), ubound, lbound);
2470	tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2471	tmp, build_one_cst (TREE_TYPE (tmp)));
2472	extent = fold_build2_loc (input_location, MULT_EXPR,
2473	TREE_TYPE (tmp), extent, tmp);
2474	}
2475	}
2476	img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2477	img_idx, build_one_cst (TREE_TYPE (img_idx)));
2478	return fold_convert (integer_type_node, img_idx);
2479	}
2480
2481
2482	/* For each character array constructor subexpression without a ts.u.cl->length,
2483	replace it by its first element (if there aren't any elements, the length
2484	should already be set to zero). */
2485
2486	static void
2487	flatten_array_ctors_without_strlen (gfc_expr* e)
2488	{
2489	gfc_actual_arglist* arg;
2490	gfc_constructor* c;
2491
2492	if (!e)
2493	return;
2494
2495	switch (e->expr_type)
2496	{
2497
2498	case EXPR_OP:
2499	flatten_array_ctors_without_strlen (e: e->value.op.op1);
2500	flatten_array_ctors_without_strlen (e: e->value.op.op2);
2501	break;
2502
2503	case EXPR_COMPCALL:
2504	/* TODO: Implement as with EXPR_FUNCTION when needed. */
2505	gcc_unreachable ();
2506
2507	case EXPR_FUNCTION:
2508	for (arg = e->value.function.actual; arg; arg = arg->next)
2509	flatten_array_ctors_without_strlen (e: arg->expr);
2510	break;
2511
2512	case EXPR_ARRAY:
2513
2514	/* We've found what we're looking for. */
2515	if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2516	{
2517	gfc_constructor *c;
2518	gfc_expr* new_expr;
2519
2520	gcc_assert (e->value.constructor);
2521
2522	c = gfc_constructor_first (base: e->value.constructor);
2523	new_expr = c->expr;
2524	c->expr = NULL;
2525
2526	flatten_array_ctors_without_strlen (e: new_expr);
2527	gfc_replace_expr (e, new_expr);
2528	break;
2529	}
2530
2531	/* Otherwise, fall through to handle constructor elements. */
2532	gcc_fallthrough ();
2533	case EXPR_STRUCTURE:
2534	for (c = gfc_constructor_first (base: e->value.constructor);
2535	c; c = gfc_constructor_next (ctor: c))
2536	flatten_array_ctors_without_strlen (e: c->expr);
2537	break;
2538
2539	default:
2540	break;
2541
2542	}
2543	}
2544
2545
2546	/* Generate code to initialize a string length variable. Returns the
2547	value. For array constructors, cl->length might be NULL and in this case,
2548	the first element of the constructor is needed. expr is the original
2549	expression so we can access it but can be NULL if this is not needed. */
2550
2551	void
2552	gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2553	{
2554	gfc_se se;
2555
2556	gfc_init_se (se: &se, NULL);
2557
2558	if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2559	return;
2560
2561	/* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2562	"flatten" array constructors by taking their first element; all elements
2563	should be the same length or a cl->length should be present. */
2564	if (!cl->length)
2565	{
2566	gfc_expr* expr_flat;
2567	if (!expr)
2568	return;
2569	expr_flat = gfc_copy_expr (expr);
2570	flatten_array_ctors_without_strlen (e: expr_flat);
2571	gfc_resolve_expr (expr_flat);
2572	if (expr_flat->rank)
2573	gfc_conv_expr_descriptor (&se, expr_flat);
2574	else
2575	gfc_conv_expr (se: &se, expr: expr_flat);
2576	if (expr_flat->expr_type != EXPR_VARIABLE)
2577	gfc_add_block_to_block (pblock, &se.pre);
2578	se.expr = convert (gfc_charlen_type_node, se.string_length);
2579	gfc_add_block_to_block (pblock, &se.post);
2580	gfc_free_expr (expr_flat);
2581	}
2582	else
2583	{
2584	/* Convert cl->length. */
2585	gfc_conv_expr_type (se: &se, cl->length, gfc_charlen_type_node);
2586	se.expr = fold_build2_loc (input_location, MAX_EXPR,
2587	gfc_charlen_type_node, se.expr,
2588	build_zero_cst (TREE_TYPE (se.expr)));
2589	gfc_add_block_to_block (pblock, &se.pre);
2590	}
2591
2592	if (cl->backend_decl && VAR_P (cl->backend_decl))
2593	gfc_add_modify (pblock, cl->backend_decl, se.expr);
2594	else
2595	cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2596	}
2597
2598
2599	static void
2600	gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2601	const char *name, locus *where)
2602	{
2603	tree tmp;
2604	tree type;
2605	tree fault;
2606	gfc_se start;
2607	gfc_se end;
2608	char *msg;
2609	mpz_t length;
2610
2611	type = gfc_get_character_type (kind, ref->u.ss.length);
2612	type = build_pointer_type (type);
2613
2614	gfc_init_se (se: &start, parent: se);
2615	gfc_conv_expr_type (se: &start, ref->u.ss.start, gfc_charlen_type_node);
2616	gfc_add_block_to_block (&se->pre, &start.pre);
2617
2618	if (integer_onep (start.expr))
2619	gfc_conv_string_parameter (se);
2620	else
2621	{
2622	tmp = start.expr;
2623	STRIP_NOPS (tmp);
2624	/* Avoid multiple evaluation of substring start. */
2625	if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2626	start.expr = gfc_evaluate_now (start.expr, &se->pre);
2627
2628	/* Change the start of the string. */
2629	if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
2630	|| TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
2631	&& TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2632	tmp = se->expr;
2633	else
2634	tmp = build_fold_indirect_ref_loc (input_location,
2635	se->expr);
2636	/* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2637	if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
2638	{
2639	tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, non_negative_offset: true);
2640	se->expr = gfc_build_addr_expr (type, tmp);
2641	}
2642	}
2643
2644	/* Length = end + 1 - start. */
2645	gfc_init_se (se: &end, parent: se);
2646	if (ref->u.ss.end == NULL)
2647	end.expr = se->string_length;
2648	else
2649	{
2650	gfc_conv_expr_type (se: &end, ref->u.ss.end, gfc_charlen_type_node);
2651	gfc_add_block_to_block (&se->pre, &end.pre);
2652	}
2653	tmp = end.expr;
2654	STRIP_NOPS (tmp);
2655	if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2656	end.expr = gfc_evaluate_now (end.expr, &se->pre);
2657
2658	if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2659	&& (ref->u.ss.start->symtree
2660	&& !ref->u.ss.start->symtree->n.sym->attr.implied_index))
2661	{
2662	tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2663	logical_type_node, start.expr,
2664	end.expr);
2665
2666	/* Check lower bound. */
2667	fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2668	start.expr,
2669	build_one_cst (TREE_TYPE (start.expr)));
2670	fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2671	logical_type_node, nonempty, fault);
2672	if (name)
2673	msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2674	"is less than one", name);
2675	else
2676	msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2677	"is less than one");
2678	gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2679	fold_convert (long_integer_type_node,
2680	start.expr));
2681	free (ptr: msg);
2682
2683	/* Check upper bound. */
2684	fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2685	end.expr, se->string_length);
2686	fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2687	logical_type_node, nonempty, fault);
2688	if (name)
2689	msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2690	"exceeds string length (%%ld)", name);
2691	else
2692	msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2693	"exceeds string length (%%ld)");
2694	gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2695	fold_convert (long_integer_type_node, end.expr),
2696	fold_convert (long_integer_type_node,
2697	se->string_length));
2698	free (ptr: msg);
2699	}
2700
2701	/* Try to calculate the length from the start and end expressions. */
2702	if (ref->u.ss.end
2703	&& gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2704	{
2705	HOST_WIDE_INT i_len;
2706
2707	i_len = gfc_mpz_get_hwi (length) + 1;
2708	if (i_len < 0)
2709	i_len = 0;
2710
2711	tmp = build_int_cst (gfc_charlen_type_node, i_len);
2712	mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2713	}
2714	else
2715	{
2716	tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2717	fold_convert (gfc_charlen_type_node, end.expr),
2718	fold_convert (gfc_charlen_type_node, start.expr));
2719	tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2720	build_int_cst (gfc_charlen_type_node, 1), tmp);
2721	tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2722	tmp, build_int_cst (gfc_charlen_type_node, 0));
2723	}
2724
2725	se->string_length = tmp;
2726	}
2727
2728
2729	/* Convert a derived type component reference. */
2730
2731	void
2732	gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2733	{
2734	gfc_component *c;
2735	tree tmp;
2736	tree decl;
2737	tree field;
2738	tree context;
2739
2740	c = ref->u.c.component;
2741
2742	if (c->backend_decl == NULL_TREE
2743	&& ref->u.c.sym != NULL)
2744	gfc_get_derived_type (derived: ref->u.c.sym);
2745
2746	field = c->backend_decl;
2747	gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2748	decl = se->expr;
2749	context = DECL_FIELD_CONTEXT (field);
2750
2751	/* Components can correspond to fields of different containing
2752	types, as components are created without context, whereas
2753	a concrete use of a component has the type of decl as context.
2754	So, if the type doesn't match, we search the corresponding
2755	FIELD_DECL in the parent type. To not waste too much time
2756	we cache this result in norestrict_decl.
2757	On the other hand, if the context is a UNION or a MAP (a
2758	RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2759
2760	if (context != TREE_TYPE (decl)
2761	&& !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2762	|| TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2763	{
2764	tree f2 = c->norestrict_decl;
2765	if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2766	for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
2767	if (TREE_CODE (f2) == FIELD_DECL
2768	&& DECL_NAME (f2) == DECL_NAME (field))
2769	break;
2770	gcc_assert (f2);
2771	c->norestrict_decl = f2;
2772	field = f2;
2773	}
2774
2775	if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
2776	&& strcmp (s1: "_data", s2: c->name) == 0)
2777	{
2778	/* Found a ref to the _data component. Store the associated ref to
2779	the vptr in se->class_vptr. */
2780	se->class_vptr = gfc_class_vptr_get (decl);
2781	}
2782	else
2783	se->class_vptr = NULL_TREE;
2784
2785	tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
2786	decl, field, NULL_TREE);
2787
2788	se->expr = tmp;
2789
2790	/* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2791	strlen () conditional below. */
2792	if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
2793	&& !c->ts.deferred
2794	&& !c->attr.pdt_string)
2795	{
2796	tmp = c->ts.u.cl->backend_decl;
2797	/* Components must always be constant length. */
2798	gcc_assert (tmp && INTEGER_CST_P (tmp));
2799	se->string_length = tmp;
2800	}
2801
2802	if (gfc_deferred_strlen (c, &field))
2803	{
2804	tmp = fold_build3_loc (input_location, COMPONENT_REF,
2805	TREE_TYPE (field),
2806	decl, field, NULL_TREE);
2807	se->string_length = tmp;
2808	}
2809
2810	if (((c->attr.pointer || c->attr.allocatable)
2811	&& (!c->attr.dimension && !c->attr.codimension)
2812	&& c->ts.type != BT_CHARACTER)
2813	|| c->attr.proc_pointer)
2814	se->expr = build_fold_indirect_ref_loc (input_location,
2815	se->expr);
2816	}
2817
2818
2819	/* This function deals with component references to components of the
2820	parent type for derived type extensions. */
2821	void
2822	conv_parent_component_references (gfc_se * se, gfc_ref * ref)
2823	{
2824	gfc_component *c;
2825	gfc_component *cmp;
2826	gfc_symbol *dt;
2827	gfc_ref parent;
2828
2829	dt = ref->u.c.sym;
2830	c = ref->u.c.component;
2831
2832	/* Return if the component is in this type, i.e. not in the parent type. */
2833	for (cmp = dt->components; cmp; cmp = cmp->next)
2834	if (c == cmp)
2835	return;
2836
2837	/* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2838	parent.type = REF_COMPONENT;
2839	parent.next = NULL;
2840	parent.u.c.sym = dt;
2841	parent.u.c.component = dt->components;
2842
2843	if (dt->backend_decl == NULL)
2844	gfc_get_derived_type (derived: dt);
2845
2846	/* Build the reference and call self. */
2847	gfc_conv_component_ref (se, ref: &parent);
2848	parent.u.c.sym = dt->components->ts.u.derived;
2849	parent.u.c.component = c;
2850	conv_parent_component_references (se, ref: &parent);
2851	}
2852
2853
2854	static void
2855	conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
2856	{
2857	tree res = se->expr;
2858
2859	switch (ref->u.i)
2860	{
2861	case INQUIRY_RE:
2862	res = fold_build1_loc (input_location, REALPART_EXPR,
2863	TREE_TYPE (TREE_TYPE (res)), res);
2864	break;
2865
2866	case INQUIRY_IM:
2867	res = fold_build1_loc (input_location, IMAGPART_EXPR,
2868	TREE_TYPE (TREE_TYPE (res)), res);
2869	break;
2870
2871	case INQUIRY_KIND:
2872	res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
2873	ts->kind);
2874	se->string_length = NULL_TREE;
2875	break;
2876
2877	case INQUIRY_LEN:
2878	res = fold_convert (gfc_typenode_for_spec (&expr->ts),
2879	se->string_length);
2880	se->string_length = NULL_TREE;
2881	break;
2882
2883	default:
2884	gcc_unreachable ();
2885	}
2886	se->expr = res;
2887	}
2888
2889	/* Dereference VAR where needed if it is a pointer, reference, etc.
2890	according to Fortran semantics. */
2891
2892	tree
2893	gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
2894	bool is_classarray)
2895	{
2896	if (!POINTER_TYPE_P (TREE_TYPE (var)))
2897	return var;
2898	if (is_CFI_desc (sym, NULL))
2899	return build_fold_indirect_ref_loc (input_location, var);
2900
2901	/* Characters are entirely different from other types, they are treated
2902	separately. */
2903	if (sym->ts.type == BT_CHARACTER)
2904	{
2905	/* Dereference character pointer dummy arguments
2906	or results. */
2907	if ((sym->attr.pointer || sym->attr.allocatable
2908	|| (sym->as && sym->as->type == AS_ASSUMED_RANK))
2909	&& (sym->attr.dummy
2910	|| sym->attr.function
2911	|| sym->attr.result))
2912	var = build_fold_indirect_ref_loc (input_location, var);
2913	}
2914	else if (!sym->attr.value)
2915	{
2916	/* Dereference temporaries for class array dummy arguments. */
2917	if (sym->attr.dummy && is_classarray
2918	&& GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
2919	{
2920	if (!descriptor_only_p)
2921	var = GFC_DECL_SAVED_DESCRIPTOR (var);
2922
2923	var = build_fold_indirect_ref_loc (input_location, var);
2924	}
2925
2926	/* Dereference non-character scalar dummy arguments. */
2927	if (sym->attr.dummy && !sym->attr.dimension
2928	&& !(sym->attr.codimension && sym->attr.allocatable)
2929	&& (sym->ts.type != BT_CLASS
2930	|| (!CLASS_DATA (sym)->attr.dimension
2931	&& !(CLASS_DATA (sym)->attr.codimension
2932	&& CLASS_DATA (sym)->attr.allocatable))))
2933	var = build_fold_indirect_ref_loc (input_location, var);
2934
2935	/* Dereference scalar hidden result. */
2936	if (flag_f2c && sym->ts.type == BT_COMPLEX
2937	&& (sym->attr.function || sym->attr.result)
2938	&& !sym->attr.dimension && !sym->attr.pointer
2939	&& !sym->attr.always_explicit)
2940	var = build_fold_indirect_ref_loc (input_location, var);
2941
2942	/* Dereference non-character, non-class pointer variables.
2943	These must be dummies, results, or scalars. */
2944	if (!is_classarray
2945	&& (sym->attr.pointer || sym->attr.allocatable
2946	|| gfc_is_associate_pointer (sym)
2947	|| (sym->as && sym->as->type == AS_ASSUMED_RANK))
2948	&& (sym->attr.dummy
2949	|| sym->attr.function
2950	|| sym->attr.result
2951	|| (!sym->attr.dimension
2952	&& (!sym->attr.codimension || !sym->attr.allocatable))))
2953	var = build_fold_indirect_ref_loc (input_location, var);
2954	/* Now treat the class array pointer variables accordingly. */
2955	else if (sym->ts.type == BT_CLASS
2956	&& sym->attr.dummy
2957	&& (CLASS_DATA (sym)->attr.dimension
2958	|| CLASS_DATA (sym)->attr.codimension)
2959	&& ((CLASS_DATA (sym)->as
2960	&& CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
2961	|| CLASS_DATA (sym)->attr.allocatable
2962	|| CLASS_DATA (sym)->attr.class_pointer))
2963	var = build_fold_indirect_ref_loc (input_location, var);
2964	/* And the case where a non-dummy, non-result, non-function,
2965	non-allocable and non-pointer classarray is present. This case was
2966	previously covered by the first if, but with introducing the
2967	condition !is_classarray there, that case has to be covered
2968	explicitly. */
2969	else if (sym->ts.type == BT_CLASS
2970	&& !sym->attr.dummy
2971	&& !sym->attr.function
2972	&& !sym->attr.result
2973	&& (CLASS_DATA (sym)->attr.dimension
2974	|| CLASS_DATA (sym)->attr.codimension)
2975	&& (sym->assoc
2976	|| !CLASS_DATA (sym)->attr.allocatable)
2977	&& !CLASS_DATA (sym)->attr.class_pointer)
2978	var = build_fold_indirect_ref_loc (input_location, var);
2979	}
2980
2981	return var;
2982	}
2983
2984	/* Return the contents of a variable. Also handles reference/pointer
2985	variables (all Fortran pointer references are implicit). */
2986
2987	static void
2988	gfc_conv_variable (gfc_se * se, gfc_expr * expr)
2989	{
2990	gfc_ss *ss;
2991	gfc_ref *ref;
2992	gfc_symbol *sym;
2993	tree parent_decl = NULL_TREE;
2994	int parent_flag;
2995	bool return_value;
2996	bool alternate_entry;
2997	bool entry_master;
2998	bool is_classarray;
2999	bool first_time = true;
3000
3001	sym = expr->symtree->n.sym;
3002	is_classarray = IS_CLASS_ARRAY (sym);
3003	ss = se->ss;
3004	if (ss != NULL)
3005	{
3006	gfc_ss_info *ss_info = ss->info;
3007
3008	/* Check that something hasn't gone horribly wrong. */
3009	gcc_assert (ss != gfc_ss_terminator);
3010	gcc_assert (ss_info->expr == expr);
3011
3012	/* A scalarized term. We already know the descriptor. */
3013	se->expr = ss_info->data.array.descriptor;
3014	se->string_length = ss_info->string_length;
3015	ref = ss_info->data.array.ref;
3016	if (ref)
3017	gcc_assert (ref->type == REF_ARRAY
3018	&& ref->u.ar.type != AR_ELEMENT);
3019	else
3020	gfc_conv_tmp_array_ref (se);
3021	}
3022	else
3023	{
3024	tree se_expr = NULL_TREE;
3025
3026	se->expr = gfc_get_symbol_decl (sym);
3027
3028	/* Deal with references to a parent results or entries by storing
3029	the current_function_decl and moving to the parent_decl. */
3030	return_value = sym->attr.function && sym->result == sym;
3031	alternate_entry = sym->attr.function && sym->attr.entry
3032	&& sym->result == sym;
3033	entry_master = sym->attr.result
3034	&& sym->ns->proc_name->attr.entry_master
3035	&& !gfc_return_by_reference (sym->ns->proc_name);
3036	if (current_function_decl)
3037	parent_decl = DECL_CONTEXT (current_function_decl);
3038
3039	if ((se->expr == parent_decl && return_value)
3040	|| (sym->ns && sym->ns->proc_name
3041	&& parent_decl
3042	&& sym->ns->proc_name->backend_decl == parent_decl
3043	&& (alternate_entry || entry_master)))
3044	parent_flag = 1;
3045	else
3046	parent_flag = 0;
3047
3048	/* Special case for assigning the return value of a function.
3049	Self recursive functions must have an explicit return value. */
3050	if (return_value && (se->expr == current_function_decl || parent_flag))
3051	se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3052
3053	/* Similarly for alternate entry points. */
3054	else if (alternate_entry
3055	&& (sym->ns->proc_name->backend_decl == current_function_decl
3056	|| parent_flag))
3057	{
3058	gfc_entry_list *el = NULL;
3059
3060	for (el = sym->ns->entries; el; el = el->next)
3061	if (sym == el->sym)
3062	{
3063	se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3064	break;
3065	}
3066	}
3067
3068	else if (entry_master
3069	&& (sym->ns->proc_name->backend_decl == current_function_decl
3070	|| parent_flag))
3071	se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3072
3073	if (se_expr)
3074	se->expr = se_expr;
3075
3076	/* Procedure actual arguments. Look out for temporary variables
3077	with the same attributes as function values. */
3078	else if (!sym->attr.temporary
3079	&& sym->attr.flavor == FL_PROCEDURE
3080	&& se->expr != current_function_decl)
3081	{
3082	if (!sym->attr.dummy && !sym->attr.proc_pointer)
3083	{
3084	gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
3085	se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3086	}
3087	return;
3088	}
3089
3090	if (sym->ts.type == BT_CLASS
3091	&& sym->attr.class_ok
3092	&& sym->ts.u.derived->attr.is_class)
3093	se->class_container = se->expr;
3094
3095	/* Dereference the expression, where needed. */
3096	se->expr = gfc_maybe_dereference_var (sym, var: se->expr, descriptor_only_p: se->descriptor_only,
3097	is_classarray);
3098
3099	ref = expr->ref;
3100	}
3101
3102	/* For character variables, also get the length. */
3103	if (sym->ts.type == BT_CHARACTER)
3104	{
3105	/* If the character length of an entry isn't set, get the length from
3106	the master function instead. */
3107	if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
3108	se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
3109	else
3110	se->string_length = sym->ts.u.cl->backend_decl;
3111	gcc_assert (se->string_length);
3112	}
3113
3114	gfc_typespec *ts = &sym->ts;
3115	while (ref)
3116	{
3117	switch (ref->type)
3118	{
3119	case REF_ARRAY:
3120	/* Return the descriptor if that's what we want and this is an array
3121	section reference. */
3122	if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
3123	return;
3124	/* TODO: Pointers to single elements of array sections, eg elemental subs. */
3125	/* Return the descriptor for array pointers and allocations. */
3126	if (se->want_pointer
3127	&& ref->next == NULL && (se->descriptor_only))
3128	return;
3129
3130	gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
3131	/* Return a pointer to an element. */
3132	break;
3133
3134	case REF_COMPONENT:
3135	ts = &ref->u.c.component->ts;
3136	if (first_time && is_classarray && sym->attr.dummy
3137	&& se->descriptor_only
3138	&& !CLASS_DATA (sym)->attr.allocatable
3139	&& !CLASS_DATA (sym)->attr.class_pointer
3140	&& CLASS_DATA (sym)->as
3141	&& CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
3142	&& strcmp (s1: "_data", s2: ref->u.c.component->name) == 0)
3143	/* Skip the first ref of a _data component, because for class
3144	arrays that one is already done by introducing a temporary
3145	array descriptor. */
3146	break;
3147
3148	if (ref->u.c.sym->attr.extension)
3149	conv_parent_component_references (se, ref);
3150
3151	gfc_conv_component_ref (se, ref);
3152
3153	if (ref->u.c.component->ts.type == BT_CLASS
3154	&& ref->u.c.component->attr.class_ok
3155	&& ref->u.c.component->ts.u.derived->attr.is_class)
3156	se->class_container = se->expr;
3157	else if (!(ref->u.c.sym->attr.flavor == FL_DERIVED
3158	&& ref->u.c.sym->attr.is_class))
3159	se->class_container = NULL_TREE;
3160
3161	if (!ref->next && ref->u.c.sym->attr.codimension
3162	&& se->want_pointer && se->descriptor_only)
3163	return;
3164
3165	break;
3166
3167	case REF_SUBSTRING:
3168	gfc_conv_substring (se, ref, kind: expr->ts.kind,
3169	name: expr->symtree->name, where: &expr->where);
3170	break;
3171
3172	case REF_INQUIRY:
3173	conv_inquiry (se, ref, expr, ts);
3174	break;
3175
3176	default:
3177	gcc_unreachable ();
3178	break;
3179	}
3180	first_time = false;
3181	ref = ref->next;
3182	}
3183	/* Pointer assignment, allocation or pass by reference. Arrays are handled
3184	separately. */
3185	if (se->want_pointer)
3186	{
3187	if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
3188	gfc_conv_string_parameter (se);
3189	else
3190	se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3191	}
3192	}
3193
3194
3195	/* Unary ops are easy... Or they would be if ! was a valid op. */
3196
3197	static void
3198	gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
3199	{
3200	gfc_se operand;
3201	tree type;
3202
3203	gcc_assert (expr->ts.type != BT_CHARACTER);
3204	/* Initialize the operand. */
3205	gfc_init_se (se: &operand, parent: se);
3206	gfc_conv_expr_val (se: &operand, expr: expr->value.op.op1);
3207	gfc_add_block_to_block (&se->pre, &operand.pre);
3208
3209	type = gfc_typenode_for_spec (&expr->ts);
3210
3211	/* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
3212	We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
3213	All other unary operators have an equivalent GIMPLE unary operator. */
3214	if (code == TRUTH_NOT_EXPR)
3215	se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
3216	build_int_cst (type, 0));
3217	else
3218	se->expr = fold_build1_loc (input_location, code, type, operand.expr);
3219
3220	}
3221
3222	/* Expand power operator to optimal multiplications when a value is raised
3223	to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
3224	Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
3225	Programming", 3rd Edition, 1998. */
3226
3227	/* This code is mostly duplicated from expand_powi in the backend.
3228	We establish the "optimal power tree" lookup table with the defined size.
3229	The items in the table are the exponents used to calculate the index
3230	exponents. Any integer n less than the value can get an "addition chain",
3231	with the first node being one. */
3232	#define POWI_TABLE_SIZE 256
3233
3234	/* The table is from builtins.cc. */
3235	static const unsigned char powi_table[POWI_TABLE_SIZE] =
3236	{
3237	0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
3238	4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
3239	8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
3240	12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
3241	16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
3242	20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
3243	24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
3244	28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
3245	32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
3246	36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
3247	40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
3248	44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
3249	48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
3250	52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
3251	56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
3252	60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
3253	64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
3254	68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
3255	72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
3256	76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
3257	80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
3258	84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
3259	88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
3260	92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
3261	96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
3262	100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
3263	104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
3264	108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
3265	112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
3266	116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
3267	120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
3268	124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
3269	};
3270
3271	/* If n is larger than lookup table's max index, we use the "window
3272	method". */
3273	#define POWI_WINDOW_SIZE 3
3274
3275	/* Recursive function to expand the power operator. The temporary
3276	values are put in tmpvar. The function returns tmpvar[1] ** n. */
3277	static tree
3278	gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
3279	{
3280	tree op0;
3281	tree op1;
3282	tree tmp;
3283	int digit;
3284
3285	if (n < POWI_TABLE_SIZE)
3286	{
3287	if (tmpvar[n])
3288	return tmpvar[n];
3289
3290	op0 = gfc_conv_powi (se, n: n - powi_table[n], tmpvar);
3291	op1 = gfc_conv_powi (se, n: powi_table[n], tmpvar);
3292	}
3293	else if (n & 1)
3294	{
3295	digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
3296	op0 = gfc_conv_powi (se, n: n - digit, tmpvar);
3297	op1 = gfc_conv_powi (se, n: digit, tmpvar);
3298	}
3299	else
3300	{
3301	op0 = gfc_conv_powi (se, n: n >> 1, tmpvar);
3302	op1 = op0;
3303	}
3304
3305	tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
3306	tmp = gfc_evaluate_now (tmp, &se->pre);
3307
3308	if (n < POWI_TABLE_SIZE)
3309	tmpvar[n] = tmp;
3310
3311	return tmp;
3312	}
3313
3314
3315	/* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
3316	return 1. Else return 0 and a call to runtime library functions
3317	will have to be built. */
3318	static int
3319	gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
3320	{
3321	tree cond;
3322	tree tmp;
3323	tree type;
3324	tree vartmp[POWI_TABLE_SIZE];
3325	HOST_WIDE_INT m;
3326	unsigned HOST_WIDE_INT n;
3327	int sgn;
3328	wi::tree_to_wide_ref wrhs = wi::to_wide (t: rhs);
3329
3330	/* If exponent is too large, we won't expand it anyway, so don't bother
3331	with large integer values. */
3332	if (!wi::fits_shwi_p (x: wrhs))
3333	return 0;
3334
3335	m = wrhs.to_shwi ();
3336	/* Use the wide_int's routine to reliably get the absolute value on all
3337	platforms. Then convert it to a HOST_WIDE_INT like above. */
3338	n = wi::abs (x: wrhs).to_shwi ();
3339
3340	type = TREE_TYPE (lhs);
3341	sgn = tree_int_cst_sgn (rhs);
3342
3343	if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
3344	|| optimize_size) && (m > 2 || m < -1))
3345	return 0;
3346
3347	/* rhs == 0 */
3348	if (sgn == 0)
3349	{
3350	se->expr = gfc_build_const (type, integer_one_node);
3351	return 1;
3352	}
3353
3354	/* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3355	if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
3356	{
3357	tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3358	lhs, build_int_cst (TREE_TYPE (lhs), -1));
3359	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3360	lhs, build_int_cst (TREE_TYPE (lhs), 1));
3361
3362	/* If rhs is even,
3363	result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3364	if ((n & 1) == 0)
3365	{
3366	tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3367	logical_type_node, tmp, cond);
3368	se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3369	tmp, build_int_cst (type, 1),
3370	build_int_cst (type, 0));
3371	return 1;
3372	}
3373	/* If rhs is odd,
3374	result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3375	tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
3376	build_int_cst (type, -1),
3377	build_int_cst (type, 0));
3378	se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3379	cond, build_int_cst (type, 1), tmp);
3380	return 1;
3381	}
3382
3383	memset (s: vartmp, c: 0, n: sizeof (vartmp));
3384	vartmp[1] = lhs;
3385	if (sgn == -1)
3386	{
3387	tmp = gfc_build_const (type, integer_one_node);
3388	vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
3389	vartmp[1]);
3390	}
3391
3392	se->expr = gfc_conv_powi (se, n, tmpvar: vartmp);
3393
3394	return 1;
3395	}
3396
3397
3398	/* Power op (**). Constant integer exponent has special handling. */
3399
3400	static void
3401	gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3402	{
3403	tree gfc_int4_type_node;
3404	int kind;
3405	int ikind;
3406	int res_ikind_1, res_ikind_2;
3407	gfc_se lse;
3408	gfc_se rse;
3409	tree fndecl = NULL;
3410
3411	gfc_init_se (se: &lse, parent: se);
3412	gfc_conv_expr_val (se: &lse, expr: expr->value.op.op1);
3413	lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3414	gfc_add_block_to_block (&se->pre, &lse.pre);
3415
3416	gfc_init_se (se: &rse, parent: se);
3417	gfc_conv_expr_val (se: &rse, expr: expr->value.op.op2);
3418	gfc_add_block_to_block (&se->pre, &rse.pre);
3419
3420	if (expr->value.op.op2->ts.type == BT_INTEGER
3421	&& expr->value.op.op2->expr_type == EXPR_CONSTANT)
3422	if (gfc_conv_cst_int_power (se, lhs: lse.expr, rhs: rse.expr))
3423	return;
3424
3425	if (INTEGER_CST_P (lse.expr)
3426	&& TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE)
3427	{
3428	wi::tree_to_wide_ref wlhs = wi::to_wide (t: lse.expr);
3429	HOST_WIDE_INT v;
3430	unsigned HOST_WIDE_INT w;
3431	int kind, ikind, bit_size;
3432
3433	v = wlhs.to_shwi ();
3434	w = absu_hwi (x: v);
3435
3436	kind = expr->value.op.op1->ts.kind;
3437	ikind = gfc_validate_kind (BT_INTEGER, kind, false);
3438	bit_size = gfc_integer_kinds[ikind].bit_size;
3439
3440	if (v == 1)
3441	{
3442	/* 1**something is always 1. */
3443	se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
3444	return;
3445	}
3446	else if (v == -1)
3447	{
3448	/* (-1)**n is 1 - ((n & 1) << 1) */
3449	tree type;
3450	tree tmp;
3451
3452	type = TREE_TYPE (lse.expr);
3453	tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3454	rse.expr, build_int_cst (type, 1));
3455	tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3456	tmp, build_int_cst (type, 1));
3457	tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
3458	build_int_cst (type, 1), tmp);
3459	se->expr = tmp;
3460	return;
3461	}
3462	else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
3463	{
3464	/* Here v is +/- 2**e. The further simplification uses
3465	2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3466	1<<(4*n), etc., but we have to make sure to return zero
3467	if the number of bits is too large. */
3468	tree lshift;
3469	tree type;
3470	tree shift;
3471	tree ge;
3472	tree cond;
3473	tree num_bits;
3474	tree cond2;
3475	tree tmp1;
3476
3477	type = TREE_TYPE (lse.expr);
3478
3479	if (w == 2)
3480	shift = rse.expr;
3481	else if (w == 4)
3482	shift = fold_build2_loc (input_location, PLUS_EXPR,
3483	TREE_TYPE (rse.expr),
3484	rse.expr, rse.expr);
3485	else
3486	{
3487	/* use popcount for fast log2(w) */
3488	int e = wi::popcount (w-1);
3489	shift = fold_build2_loc (input_location, MULT_EXPR,
3490	TREE_TYPE (rse.expr),
3491	build_int_cst (TREE_TYPE (rse.expr), e),
3492	rse.expr);
3493	}
3494
3495	lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3496	build_int_cst (type, 1), shift);
3497	ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3498	rse.expr, build_int_cst (type, 0));
3499	cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3500	build_int_cst (type, 0));
3501	num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
3502	cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3503	rse.expr, num_bits);
3504	tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3505	build_int_cst (type, 0), cond);
3506	if (v > 0)
3507	{
3508	se->expr = tmp1;
3509	}
3510	else
3511	{
3512	/* for v < 0, calculate v**n = |v|**n * (-1)**n */
3513	tree tmp2;
3514	tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3515	rse.expr, build_int_cst (type, 1));
3516	tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3517	tmp2, build_int_cst (type, 1));
3518	tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
3519	build_int_cst (type, 1), tmp2);
3520	se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
3521	tmp1, tmp2);
3522	}
3523	return;
3524	}
3525	}
3526
3527	gfc_int4_type_node = gfc_get_int_type (4);
3528
3529	/* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3530	library routine. But in the end, we have to convert the result back
3531	if this case applies -- with res_ikind_K, we keep track whether operand K
3532	falls into this case. */
3533	res_ikind_1 = -1;
3534	res_ikind_2 = -1;
3535
3536	kind = expr->value.op.op1->ts.kind;
3537	switch (expr->value.op.op2->ts.type)
3538	{
3539	case BT_INTEGER:
3540	ikind = expr->value.op.op2->ts.kind;
3541	switch (ikind)
3542	{
3543	case 1:
3544	case 2:
3545	rse.expr = convert (gfc_int4_type_node, rse.expr);
3546	res_ikind_2 = ikind;
3547	/* Fall through. */
3548
3549	case 4:
3550	ikind = 0;
3551	break;
3552
3553	case 8:
3554	ikind = 1;
3555	break;
3556
3557	case 16:
3558	ikind = 2;
3559	break;
3560
3561	default:
3562	gcc_unreachable ();
3563	}
3564	switch (kind)
3565	{
3566	case 1:
3567	case 2:
3568	if (expr->value.op.op1->ts.type == BT_INTEGER)
3569	{
3570	lse.expr = convert (gfc_int4_type_node, lse.expr);
3571	res_ikind_1 = kind;
3572	}
3573	else
3574	gcc_unreachable ();
3575	/* Fall through. */
3576
3577	case 4:
3578	kind = 0;
3579	break;
3580
3581	case 8:
3582	kind = 1;
3583	break;
3584
3585	case 10:
3586	kind = 2;
3587	break;
3588
3589	case 16:
3590	kind = 3;
3591	break;
3592
3593	default:
3594	gcc_unreachable ();
3595	}
3596
3597	switch (expr->value.op.op1->ts.type)
3598	{
3599	case BT_INTEGER:
3600	if (kind == 3) /* Case 16 was not handled properly above. */
3601	kind = 2;
3602	fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3603	break;
3604
3605	case BT_REAL:
3606	/* Use builtins for real ** int4. */
3607	if (ikind == 0)
3608	{
3609	switch (kind)
3610	{
3611	case 0:
3612	fndecl = builtin_decl_explicit (fncode: BUILT_IN_POWIF);
3613	break;
3614
3615	case 1:
3616	fndecl = builtin_decl_explicit (fncode: BUILT_IN_POWI);
3617	break;
3618
3619	case 2:
3620	fndecl = builtin_decl_explicit (fncode: BUILT_IN_POWIL);
3621	break;
3622
3623	case 3:
3624	/* Use the __builtin_powil() only if real(kind=16) is
3625	actually the C long double type. */
3626	if (!gfc_real16_is_float128)
3627	fndecl = builtin_decl_explicit (fncode: BUILT_IN_POWIL);
3628	break;
3629
3630	default:
3631	gcc_unreachable ();
3632	}
3633	}
3634
3635	/* If we don't have a good builtin for this, go for the
3636	library function. */
3637	if (!fndecl)
3638	fndecl = gfor_fndecl_math_powi[kind][ikind].real;
3639	break;
3640
3641	case BT_COMPLEX:
3642	fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
3643	break;
3644
3645	default:
3646	gcc_unreachable ();
3647	}
3648	break;
3649
3650	case BT_REAL:
3651	fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
3652	break;
3653
3654	case BT_COMPLEX:
3655	fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
3656	break;
3657
3658	default:
3659	gcc_unreachable ();
3660	break;
3661	}
3662
3663	se->expr = build_call_expr_loc (input_location,
3664	fndecl, 2, lse.expr, rse.expr);
3665
3666	/* Convert the result back if it is of wrong integer kind. */
3667	if (res_ikind_1 != -1 && res_ikind_2 != -1)
3668	{
3669	/* We want the maximum of both operand kinds as result. */
3670	if (res_ikind_1 < res_ikind_2)
3671	res_ikind_1 = res_ikind_2;
3672	se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
3673	}
3674	}
3675
3676
3677	/* Generate code to allocate a string temporary. */
3678
3679	tree
3680	gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
3681	{
3682	tree var;
3683	tree tmp;
3684
3685	if (gfc_can_put_var_on_stack (len))
3686	{
3687	/* Create a temporary variable to hold the result. */
3688	tmp = fold_build2_loc (input_location, MINUS_EXPR,
3689	TREE_TYPE (len), len,
3690	build_int_cst (TREE_TYPE (len), 1));
3691	tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
3692
3693	if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
3694	tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
3695	else
3696	tmp = build_array_type (TREE_TYPE (type), tmp);
3697
3698	var = gfc_create_var (tmp, "str");
3699	var = gfc_build_addr_expr (type, var);
3700	}
3701	else
3702	{
3703	/* Allocate a temporary to hold the result. */
3704	var = gfc_create_var (type, "pstr");
3705	gcc_assert (POINTER_TYPE_P (type));
3706	tmp = TREE_TYPE (type);
3707	if (TREE_CODE (tmp) == ARRAY_TYPE)
3708	tmp = TREE_TYPE (tmp);
3709	tmp = TYPE_SIZE_UNIT (tmp);
3710	tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3711	fold_convert (size_type_node, len),
3712	fold_convert (size_type_node, tmp));
3713	tmp = gfc_call_malloc (&se->pre, type, tmp);
3714	gfc_add_modify (&se->pre, var, tmp);
3715
3716	/* Free the temporary afterwards. */
3717	tmp = gfc_call_free (var);
3718	gfc_add_expr_to_block (&se->post, tmp);
3719	}
3720
3721	return var;
3722	}
3723
3724
3725	/* Handle a string concatenation operation. A temporary will be allocated to
3726	hold the result. */
3727
3728	static void
3729	gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
3730	{
3731	gfc_se lse, rse;
3732	tree len, type, var, tmp, fndecl;
3733
3734	gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
3735	&& expr->value.op.op2->ts.type == BT_CHARACTER);
3736	gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
3737
3738	gfc_init_se (se: &lse, parent: se);
3739	gfc_conv_expr (se: &lse, expr: expr->value.op.op1);
3740	gfc_conv_string_parameter (se: &lse);
3741	gfc_init_se (se: &rse, parent: se);
3742	gfc_conv_expr (se: &rse, expr: expr->value.op.op2);
3743	gfc_conv_string_parameter (se: &rse);
3744
3745	gfc_add_block_to_block (&se->pre, &lse.pre);
3746	gfc_add_block_to_block (&se->pre, &rse.pre);
3747
3748	type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
3749	len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3750	if (len == NULL_TREE)
3751	{
3752	len = fold_build2_loc (input_location, PLUS_EXPR,
3753	gfc_charlen_type_node,
3754	fold_convert (gfc_charlen_type_node,
3755	lse.string_length),
3756	fold_convert (gfc_charlen_type_node,
3757	rse.string_length));
3758	}
3759
3760	type = build_pointer_type (type);
3761
3762	var = gfc_conv_string_tmp (se, type, len);
3763
3764	/* Do the actual concatenation. */
3765	if (expr->ts.kind == 1)
3766	fndecl = gfor_fndecl_concat_string;
3767	else if (expr->ts.kind == 4)
3768	fndecl = gfor_fndecl_concat_string_char4;
3769	else
3770	gcc_unreachable ();
3771
3772	tmp = build_call_expr_loc (input_location,
3773	fndecl, 6, len, var, lse.string_length, lse.expr,
3774	rse.string_length, rse.expr);
3775	gfc_add_expr_to_block (&se->pre, tmp);
3776
3777	/* Add the cleanup for the operands. */
3778	gfc_add_block_to_block (&se->pre, &rse.post);
3779	gfc_add_block_to_block (&se->pre, &lse.post);
3780
3781	se->expr = var;
3782	se->string_length = len;
3783	}
3784
3785	/* Translates an op expression. Common (binary) cases are handled by this
3786	function, others are passed on. Recursion is used in either case.
3787	We use the fact that (op1.ts == op2.ts) (except for the power
3788	operator **).
3789	Operators need no special handling for scalarized expressions as long as
3790	they call gfc_conv_simple_val to get their operands.
3791	Character strings get special handling. */
3792
3793	static void
3794	gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
3795	{
3796	enum tree_code code;
3797	gfc_se lse;
3798	gfc_se rse;
3799	tree tmp, type;
3800	int lop;
3801	int checkstring;
3802
3803	checkstring = 0;
3804	lop = 0;
3805	switch (expr->value.op.op)
3806	{
3807	case INTRINSIC_PARENTHESES:
3808	if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
3809	&& flag_protect_parens)
3810	{
3811	gfc_conv_unary_op (code: PAREN_EXPR, se, expr);
3812	gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
3813	return;
3814	}
3815
3816	/* Fallthrough. */
3817	case INTRINSIC_UPLUS:
3818	gfc_conv_expr (se, expr: expr->value.op.op1);
3819	return;
3820
3821	case INTRINSIC_UMINUS:
3822	gfc_conv_unary_op (code: NEGATE_EXPR, se, expr);
3823	return;
3824
3825	case INTRINSIC_NOT:
3826	gfc_conv_unary_op (code: TRUTH_NOT_EXPR, se, expr);
3827	return;
3828
3829	case INTRINSIC_PLUS:
3830	code = PLUS_EXPR;
3831	break;
3832
3833	case INTRINSIC_MINUS:
3834	code = MINUS_EXPR;
3835	break;
3836
3837	case INTRINSIC_TIMES:
3838	code = MULT_EXPR;
3839	break;
3840
3841	case INTRINSIC_DIVIDE:
3842	/* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3843	an integer, we must round towards zero, so we use a
3844	TRUNC_DIV_EXPR. */
3845	if (expr->ts.type == BT_INTEGER)
3846	code = TRUNC_DIV_EXPR;
3847	else
3848	code = RDIV_EXPR;
3849	break;
3850
3851	case INTRINSIC_POWER:
3852	gfc_conv_power_op (se, expr);
3853	return;
3854
3855	case INTRINSIC_CONCAT:
3856	gfc_conv_concat_op (se, expr);
3857	return;
3858
3859	case INTRINSIC_AND:
3860	code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
3861	lop = 1;
3862	break;
3863
3864	case INTRINSIC_OR:
3865	code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
3866	lop = 1;
3867	break;
3868
3869	/* EQV and NEQV only work on logicals, but since we represent them
3870	as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3871	case INTRINSIC_EQ:
3872	case INTRINSIC_EQ_OS:
3873	case INTRINSIC_EQV:
3874	code = EQ_EXPR;
3875	checkstring = 1;
3876	lop = 1;
3877	break;
3878
3879	case INTRINSIC_NE:
3880	case INTRINSIC_NE_OS:
3881	case INTRINSIC_NEQV:
3882	code = NE_EXPR;
3883	checkstring = 1;
3884	lop = 1;
3885	break;
3886
3887	case INTRINSIC_GT:
3888	case INTRINSIC_GT_OS:
3889	code = GT_EXPR;
3890	checkstring = 1;
3891	lop = 1;
3892	break;
3893
3894	case INTRINSIC_GE:
3895	case INTRINSIC_GE_OS:
3896	code = GE_EXPR;
3897	checkstring = 1;
3898	lop = 1;
3899	break;
3900
3901	case INTRINSIC_LT:
3902	case INTRINSIC_LT_OS:
3903	code = LT_EXPR;
3904	checkstring = 1;
3905	lop = 1;
3906	break;
3907
3908	case INTRINSIC_LE:
3909	case INTRINSIC_LE_OS:
3910	code = LE_EXPR;
3911	checkstring = 1;
3912	lop = 1;
3913	break;
3914
3915	case INTRINSIC_USER:
3916	case INTRINSIC_ASSIGN:
3917	/* These should be converted into function calls by the frontend. */
3918	gcc_unreachable ();
3919
3920	default:
3921	fatal_error (input_location, "Unknown intrinsic op");
3922	return;
3923	}
3924
3925	/* The only exception to this is **, which is handled separately anyway. */
3926	gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
3927
3928	if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
3929	checkstring = 0;
3930
3931	/* lhs */
3932	gfc_init_se (se: &lse, parent: se);
3933	gfc_conv_expr (se: &lse, expr: expr->value.op.op1);
3934	gfc_add_block_to_block (&se->pre, &lse.pre);
3935
3936	/* rhs */
3937	gfc_init_se (se: &rse, parent: se);
3938	gfc_conv_expr (se: &rse, expr: expr->value.op.op2);
3939	gfc_add_block_to_block (&se->pre, &rse.pre);
3940
3941	if (checkstring)
3942	{
3943	gfc_conv_string_parameter (se: &lse);
3944	gfc_conv_string_parameter (se: &rse);
3945
3946	lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
3947	rse.string_length, rse.expr,
3948	expr->value.op.op1->ts.kind,
3949	code);
3950	rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
3951	gfc_add_block_to_block (&lse.post, &rse.post);
3952	}
3953
3954	type = gfc_typenode_for_spec (&expr->ts);
3955
3956	if (lop)
3957	{
3958	/* The result of logical ops is always logical_type_node. */
3959	tmp = fold_build2_loc (input_location, code, logical_type_node,
3960	lse.expr, rse.expr);
3961	se->expr = convert (type, tmp);
3962	}
3963	else
3964	se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
3965
3966	/* Add the post blocks. */
3967	gfc_add_block_to_block (&se->post, &rse.post);
3968	gfc_add_block_to_block (&se->post, &lse.post);
3969	}
3970
3971	/* If a string's length is one, we convert it to a single character. */
3972
3973	tree
3974	gfc_string_to_single_character (tree len, tree str, int kind)
3975	{
3976
3977	if (len == NULL
3978	|| !tree_fits_uhwi_p (len)
3979	|| !POINTER_TYPE_P (TREE_TYPE (str)))
3980	return NULL_TREE;
3981
3982	if (TREE_INT_CST_LOW (len) == 1)
3983	{
3984	str = fold_convert (gfc_get_pchar_type (kind), str);
3985	return build_fold_indirect_ref_loc (input_location, str);
3986	}
3987
3988	if (kind == 1
3989	&& TREE_CODE (str) == ADDR_EXPR
3990	&& TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3991	&& TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3992	&& array_ref_low_bound (TREE_OPERAND (str, 0))
3993	== TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3994	&& TREE_INT_CST_LOW (len) > 1
3995	&& TREE_INT_CST_LOW (len)
3996	== (unsigned HOST_WIDE_INT)
3997	TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3998	{
3999	tree ret = fold_convert (gfc_get_pchar_type (kind), str);
4000	ret = build_fold_indirect_ref_loc (input_location, ret);
4001	if (TREE_CODE (ret) == INTEGER_CST)
4002	{
4003	tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4004	int i, length = TREE_STRING_LENGTH (string_cst);
4005	const char *ptr = TREE_STRING_POINTER (string_cst);
4006
4007	for (i = 1; i < length; i++)
4008	if (ptr[i] != ' ')
4009	return NULL_TREE;
4010
4011	return ret;
4012	}
4013	}
4014
4015	return NULL_TREE;
4016	}
4017
4018
4019	static void
4020	conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
4021	{
4022	gcc_assert (expr);
4023
4024	/* We used to modify the tree here. Now it is done earlier in
4025	the front-end, so we only check it here to avoid regressions. */
4026	if (sym->backend_decl)
4027	{
4028	gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE);
4029	gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1);
4030	gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE);
4031	gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0);
4032	}
4033
4034	/* If we have a constant character expression, make it into an
4035	integer of type C char. */
4036	if ((*expr)->expr_type == EXPR_CONSTANT)
4037	{
4038	gfc_typespec ts;
4039	gfc_clear_ts (&ts);
4040
4041	gfc_expr *tmp = gfc_get_int_expr (gfc_default_character_kind, NULL,
4042	(*expr)->value.character.string[0]);
4043	gfc_replace_expr (*expr, tmp);
4044	}
4045	else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
4046	{
4047	if ((*expr)->ref == NULL)
4048	{
4049	se->expr = gfc_string_to_single_character
4050	(len: build_int_cst (integer_type_node, 1),
4051	str: gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4052	gfc_get_symbol_decl
4053	((*expr)->symtree->n.sym)),
4054	kind: (*expr)->ts.kind);
4055	}
4056	else
4057	{
4058	gfc_conv_variable (se, expr: *expr);
4059	se->expr = gfc_string_to_single_character
4060	(len: build_int_cst (integer_type_node, 1),
4061	str: gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4062	se->expr),
4063	kind: (*expr)->ts.kind);
4064	}
4065	}
4066	}
4067
4068	/* Helper function for gfc_build_compare_string. Return LEN_TRIM value
4069	if STR is a string literal, otherwise return -1. */
4070
4071	static int
4072	gfc_optimize_len_trim (tree len, tree str, int kind)
4073	{
4074	if (kind == 1
4075	&& TREE_CODE (str) == ADDR_EXPR
4076	&& TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4077	&& TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4078	&& array_ref_low_bound (TREE_OPERAND (str, 0))
4079	== TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4080	&& tree_fits_uhwi_p (len)
4081	&& tree_to_uhwi (len) >= 1
4082	&& tree_to_uhwi (len)
4083	== (unsigned HOST_WIDE_INT)
4084	TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4085	{
4086	tree folded = fold_convert (gfc_get_pchar_type (kind), str);
4087	folded = build_fold_indirect_ref_loc (input_location, folded);
4088	if (TREE_CODE (folded) == INTEGER_CST)
4089	{
4090	tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4091	int length = TREE_STRING_LENGTH (string_cst);
4092	const char *ptr = TREE_STRING_POINTER (string_cst);
4093
4094	for (; length > 0; length--)
4095	if (ptr[length - 1] != ' ')
4096	break;
4097
4098	return length;
4099	}
4100	}
4101	return -1;
4102	}
4103
4104	/* Helper to build a call to memcmp. */
4105
4106	static tree
4107	build_memcmp_call (tree s1, tree s2, tree n)
4108	{
4109	tree tmp;
4110
4111	if (!POINTER_TYPE_P (TREE_TYPE (s1)))
4112	s1 = gfc_build_addr_expr (pvoid_type_node, s1);
4113	else
4114	s1 = fold_convert (pvoid_type_node, s1);
4115
4116	if (!POINTER_TYPE_P (TREE_TYPE (s2)))
4117	s2 = gfc_build_addr_expr (pvoid_type_node, s2);
4118	else
4119	s2 = fold_convert (pvoid_type_node, s2);
4120
4121	n = fold_convert (size_type_node, n);
4122
4123	tmp = build_call_expr_loc (input_location,
4124	builtin_decl_explicit (fncode: BUILT_IN_MEMCMP),
4125	3, s1, s2, n);
4126
4127	return fold_convert (integer_type_node, tmp);
4128	}
4129
4130	/* Compare two strings. If they are all single characters, the result is the
4131	subtraction of them. Otherwise, we build a library call. */
4132
4133	tree
4134	gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
4135	enum tree_code code)
4136	{
4137	tree sc1;
4138	tree sc2;
4139	tree fndecl;
4140
4141	gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
4142	gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
4143
4144	sc1 = gfc_string_to_single_character (len: len1, str: str1, kind);
4145	sc2 = gfc_string_to_single_character (len: len2, str: str2, kind);
4146
4147	if (sc1 != NULL_TREE && sc2 != NULL_TREE)
4148	{
4149	/* Deal with single character specially. */
4150	sc1 = fold_convert (integer_type_node, sc1);
4151	sc2 = fold_convert (integer_type_node, sc2);
4152	return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4153	sc1, sc2);
4154	}
4155
4156	if ((code == EQ_EXPR || code == NE_EXPR)
4157	&& optimize
4158	&& INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
4159	{
4160	/* If one string is a string literal with LEN_TRIM longer
4161	than the length of the second string, the strings
4162	compare unequal. */
4163	int len = gfc_optimize_len_trim (len: len1, str: str1, kind);
4164	if (len > 0 && compare_tree_int (len2, len) < 0)
4165	return integer_one_node;
4166	len = gfc_optimize_len_trim (len: len2, str: str2, kind);
4167	if (len > 0 && compare_tree_int (len1, len) < 0)
4168	return integer_one_node;
4169	}
4170
4171	/* We can compare via memcpy if the strings are known to be equal
4172	in length and they are
4173	- kind=1
4174	- kind=4 and the comparison is for (in)equality. */
4175
4176	if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
4177	&& tree_int_cst_equal (len1, len2)
4178	&& (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
4179	{
4180	tree tmp;
4181	tree chartype;
4182
4183	chartype = gfc_get_char_type (kind);
4184	tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
4185	fold_convert (TREE_TYPE(len1),
4186	TYPE_SIZE_UNIT(chartype)),
4187	len1);
4188	return build_memcmp_call (s1: str1, s2: str2, n: tmp);
4189	}
4190
4191	/* Build a call for the comparison. */
4192	if (kind == 1)
4193	fndecl = gfor_fndecl_compare_string;
4194	else if (kind == 4)
4195	fndecl = gfor_fndecl_compare_string_char4;
4196	else
4197	gcc_unreachable ();
4198
4199	return build_call_expr_loc (input_location, fndecl, 4,
4200	len1, str1, len2, str2);
4201	}
4202
4203
4204	/* Return the backend_decl for a procedure pointer component. */
4205
4206	static tree
4207	get_proc_ptr_comp (gfc_expr *e)
4208	{
4209	gfc_se comp_se;
4210	gfc_expr *e2;
4211	expr_t old_type;
4212
4213	gfc_init_se (se: &comp_se, NULL);
4214	e2 = gfc_copy_expr (e);
4215	/* We have to restore the expr type later so that gfc_free_expr frees
4216	the exact same thing that was allocated.
4217	TODO: This is ugly. */
4218	old_type = e2->expr_type;
4219	e2->expr_type = EXPR_VARIABLE;
4220	gfc_conv_expr (se: &comp_se, expr: e2);
4221	e2->expr_type = old_type;
4222	gfc_free_expr (e2);
4223	return build_fold_addr_expr_loc (input_location, comp_se.expr);
4224	}
4225
4226
4227	/* Convert a typebound function reference from a class object. */
4228	static void
4229	conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
4230	{
4231	gfc_ref *ref;
4232	tree var;
4233
4234	if (!VAR_P (base_object))
4235	{
4236	var = gfc_create_var (TREE_TYPE (base_object), NULL);
4237	gfc_add_modify (&se->pre, var, base_object);
4238	}
4239	se->expr = gfc_class_vptr_get (decl: base_object);
4240	se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4241	ref = expr->ref;
4242	while (ref && ref->next)
4243	ref = ref->next;
4244	gcc_assert (ref && ref->type == REF_COMPONENT);
4245	if (ref->u.c.sym->attr.extension)
4246	conv_parent_component_references (se, ref);
4247	gfc_conv_component_ref (se, ref);
4248	se->expr = build_fold_addr_expr_loc (input_location, se->expr);
4249	}
4250
4251
4252	static void
4253	conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr,
4254	gfc_actual_arglist *actual_args)
4255	{
4256	tree tmp;
4257
4258	if (gfc_is_proc_ptr_comp (expr))
4259	tmp = get_proc_ptr_comp (e: expr);
4260	else if (sym->attr.dummy)
4261	{
4262	tmp = gfc_get_symbol_decl (sym);
4263	if (sym->attr.proc_pointer)
4264	tmp = build_fold_indirect_ref_loc (input_location,
4265	tmp);
4266	gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
4267	&& TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
4268	}
4269	else
4270	{
4271	if (!sym->backend_decl)
4272	sym->backend_decl = gfc_get_extern_function_decl (sym, args: actual_args);
4273
4274	TREE_USED (sym->backend_decl) = 1;
4275
4276	tmp = sym->backend_decl;
4277
4278	if (sym->attr.cray_pointee)
4279	{
4280	/* TODO - make the cray pointee a pointer to a procedure,
4281	assign the pointer to it and use it for the call. This
4282	will do for now! */
4283	tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
4284	gfc_get_symbol_decl (sym->cp_pointer));
4285	tmp = gfc_evaluate_now (tmp, &se->pre);
4286	}
4287
4288	if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
4289	{
4290	gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
4291	tmp = gfc_build_addr_expr (NULL_TREE, tmp);
4292	}
4293	}
4294	se->expr = tmp;
4295	}
4296
4297
4298	/* Initialize MAPPING. */
4299
4300	void
4301	gfc_init_interface_mapping (gfc_interface_mapping * mapping)
4302	{
4303	mapping->syms = NULL;
4304	mapping->charlens = NULL;
4305	}
4306
4307
4308	/* Free all memory held by MAPPING (but not MAPPING itself). */
4309
4310	void
4311	gfc_free_interface_mapping (gfc_interface_mapping * mapping)
4312	{
4313	gfc_interface_sym_mapping *sym;
4314	gfc_interface_sym_mapping *nextsym;
4315	gfc_charlen *cl;
4316	gfc_charlen *nextcl;
4317
4318	for (sym = mapping->syms; sym; sym = nextsym)
4319	{
4320	nextsym = sym->next;
4321	sym->new_sym->n.sym->formal = NULL;
4322	gfc_free_symbol (sym->new_sym->n.sym);
4323	gfc_free_expr (sym->expr);
4324	free (ptr: sym->new_sym);
4325	free (ptr: sym);
4326	}
4327	for (cl = mapping->charlens; cl; cl = nextcl)
4328	{
4329	nextcl = cl->next;
4330	gfc_free_expr (cl->length);
4331	free (ptr: cl);
4332	}
4333	}
4334
4335
4336	/* Return a copy of gfc_charlen CL. Add the returned structure to
4337	MAPPING so that it will be freed by gfc_free_interface_mapping. */
4338
4339	static gfc_charlen *
4340	gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
4341	gfc_charlen * cl)
4342	{
4343	gfc_charlen *new_charlen;
4344
4345	new_charlen = gfc_get_charlen ();
4346	new_charlen->next = mapping->charlens;
4347	new_charlen->length = gfc_copy_expr (cl->length);
4348
4349	mapping->charlens = new_charlen;
4350	return new_charlen;
4351	}
4352
4353
4354	/* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4355	array variable that can be used as the actual argument for dummy
4356	argument SYM. Add any initialization code to BLOCK. PACKED is as
4357	for gfc_get_nodesc_array_type and DATA points to the first element
4358	in the passed array. */
4359
4360	static tree
4361	gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4362	gfc_packed packed, tree data)
4363	{
4364	tree type;
4365	tree var;
4366
4367	type = gfc_typenode_for_spec (&sym->ts);
4368	type = gfc_get_nodesc_array_type (type, sym->as, packed,
4369	!sym->attr.target && !sym->attr.pointer
4370	&& !sym->attr.proc_pointer);
4371
4372	var = gfc_create_var (type, "ifm");
4373	gfc_add_modify (block, var, fold_convert (type, data));
4374
4375	return var;
4376	}
4377
4378
4379	/* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4380	and offset of descriptorless array type TYPE given that it has the same
4381	size as DESC. Add any set-up code to BLOCK. */
4382
4383	static void
4384	gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4385	{
4386	int n;
4387	tree dim;
4388	tree offset;
4389	tree tmp;
4390
4391	offset = gfc_index_zero_node;
4392	for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
4393	{
4394	dim = gfc_rank_cst[n];
4395	GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
4396	if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
4397	{
4398	GFC_TYPE_ARRAY_LBOUND (type, n)
4399	= gfc_conv_descriptor_lbound_get (desc, dim);
4400	GFC_TYPE_ARRAY_UBOUND (type, n)
4401	= gfc_conv_descriptor_ubound_get (desc, dim);
4402	}
4403	else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
4404	{
4405	tmp = fold_build2_loc (input_location, MINUS_EXPR,
4406	gfc_array_index_type,
4407	gfc_conv_descriptor_ubound_get (desc, dim),
4408	gfc_conv_descriptor_lbound_get (desc, dim));
4409	tmp = fold_build2_loc (input_location, PLUS_EXPR,
4410	gfc_array_index_type,
4411	GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
4412	tmp = gfc_evaluate_now (tmp, block);
4413	GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
4414	}
4415	tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4416	GFC_TYPE_ARRAY_LBOUND (type, n),
4417	GFC_TYPE_ARRAY_STRIDE (type, n));
4418	offset = fold_build2_loc (input_location, MINUS_EXPR,
4419	gfc_array_index_type, offset, tmp);
4420	}
4421	offset = gfc_evaluate_now (offset, block);
4422	GFC_TYPE_ARRAY_OFFSET (type) = offset;
4423	}
4424
4425
4426	/* Extend MAPPING so that it maps dummy argument SYM to the value stored
4427	in SE. The caller may still use se->expr and se->string_length after
4428	calling this function. */
4429
4430	void
4431	gfc_add_interface_mapping (gfc_interface_mapping * mapping,
4432	gfc_symbol * sym, gfc_se * se,
4433	gfc_expr *expr)
4434	{
4435	gfc_interface_sym_mapping *sm;
4436	tree desc;
4437	tree tmp;
4438	tree value;
4439	gfc_symbol *new_sym;
4440	gfc_symtree *root;
4441	gfc_symtree *new_symtree;
4442
4443	/* Create a new symbol to represent the actual argument. */
4444	new_sym = gfc_new_symbol (sym->name, NULL);
4445	new_sym->ts = sym->ts;
4446	new_sym->as = gfc_copy_array_spec (sym->as);
4447	new_sym->attr.referenced = 1;
4448	new_sym->attr.dimension = sym->attr.dimension;
4449	new_sym->attr.contiguous = sym->attr.contiguous;
4450	new_sym->attr.codimension = sym->attr.codimension;
4451	new_sym->attr.pointer = sym->attr.pointer;
4452	new_sym->attr.allocatable = sym->attr.allocatable;
4453	new_sym->attr.flavor = sym->attr.flavor;
4454	new_sym->attr.function = sym->attr.function;
4455
4456	/* Ensure that the interface is available and that
4457	descriptors are passed for array actual arguments. */
4458	if (sym->attr.flavor == FL_PROCEDURE)
4459	{
4460	new_sym->formal = expr->symtree->n.sym->formal;
4461	new_sym->attr.always_explicit
4462	= expr->symtree->n.sym->attr.always_explicit;
4463	}
4464
4465	/* Create a fake symtree for it. */
4466	root = NULL;
4467	new_symtree = gfc_new_symtree (&root, sym->name);
4468	new_symtree->n.sym = new_sym;
4469	gcc_assert (new_symtree == root);
4470
4471	/* Create a dummy->actual mapping. */
4472	sm = XCNEW (gfc_interface_sym_mapping);
4473	sm->next = mapping->syms;
4474	sm->old = sym;
4475	sm->new_sym = new_symtree;
4476	sm->expr = gfc_copy_expr (expr);
4477	mapping->syms = sm;
4478
4479	/* Stabilize the argument's value. */
4480	if (!sym->attr.function && se)
4481	se->expr = gfc_evaluate_now (se->expr, &se->pre);
4482
4483	if (sym->ts.type == BT_CHARACTER)
4484	{
4485	/* Create a copy of the dummy argument's length. */
4486	new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, cl: sym->ts.u.cl);
4487	sm->expr->ts.u.cl = new_sym->ts.u.cl;
4488
4489	/* If the length is specified as "*", record the length that
4490	the caller is passing. We should use the callee's length
4491	in all other cases. */
4492	if (!new_sym->ts.u.cl->length && se)
4493	{
4494	se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
4495	new_sym->ts.u.cl->backend_decl = se->string_length;
4496	}
4497	}
4498
4499	if (!se)
4500	return;
4501
4502	/* Use the passed value as-is if the argument is a function. */
4503	if (sym->attr.flavor == FL_PROCEDURE)
4504	value = se->expr;
4505
4506	/* If the argument is a pass-by-value scalar, use the value as is. */
4507	else if (!sym->attr.dimension && sym->attr.value)
4508	value = se->expr;
4509
4510	/* If the argument is either a string or a pointer to a string,
4511	convert it to a boundless character type. */
4512	else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
4513	{
4514	tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
4515	tmp = build_pointer_type (tmp);
4516	if (sym->attr.pointer)
4517	value = build_fold_indirect_ref_loc (input_location,
4518	se->expr);
4519	else
4520	value = se->expr;
4521	value = fold_convert (tmp, value);
4522	}
4523
4524	/* If the argument is a scalar, a pointer to an array or an allocatable,
4525	dereference it. */
4526	else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
4527	value = build_fold_indirect_ref_loc (input_location,
4528	se->expr);
4529
4530	/* For character(*), use the actual argument's descriptor. */
4531	else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
4532	value = build_fold_indirect_ref_loc (input_location,
4533	se->expr);
4534
4535	/* If the argument is an array descriptor, use it to determine
4536	information about the actual argument's shape. */
4537	else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
4538	&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4539	{
4540	/* Get the actual argument's descriptor. */
4541	desc = build_fold_indirect_ref_loc (input_location,
4542	se->expr);
4543
4544	/* Create the replacement variable. */
4545	tmp = gfc_conv_descriptor_data_get (desc);
4546	value = gfc_get_interface_mapping_array (block: &se->pre, sym,
4547	packed: PACKED_NO, data: tmp);
4548
4549	/* Use DESC to work out the upper bounds, strides and offset. */
4550	gfc_set_interface_mapping_bounds (block: &se->pre, TREE_TYPE (value), desc);
4551	}
4552	else
4553	/* Otherwise we have a packed array. */
4554	value = gfc_get_interface_mapping_array (block: &se->pre, sym,
4555	packed: PACKED_FULL, data: se->expr);
4556
4557	new_sym->backend_decl = value;
4558	}
4559
4560
4561	/* Called once all dummy argument mappings have been added to MAPPING,
4562	but before the mapping is used to evaluate expressions. Pre-evaluate
4563	the length of each argument, adding any initialization code to PRE and
4564	any finalization code to POST. */
4565
4566	static void
4567	gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
4568	stmtblock_t * pre, stmtblock_t * post)
4569	{
4570	gfc_interface_sym_mapping *sym;
4571	gfc_expr *expr;
4572	gfc_se se;
4573
4574	for (sym = mapping->syms; sym; sym = sym->next)
4575	if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
4576	&& !sym->new_sym->n.sym->ts.u.cl->backend_decl)
4577	{
4578	expr = sym->new_sym->n.sym->ts.u.cl->length;
4579	gfc_apply_interface_mapping_to_expr (mapping, expr);
4580	gfc_init_se (se: &se, NULL);
4581	gfc_conv_expr (se: &se, expr);
4582	se.expr = fold_convert (gfc_charlen_type_node, se.expr);
4583	se.expr = gfc_evaluate_now (se.expr, &se.pre);
4584	gfc_add_block_to_block (pre, &se.pre);
4585	gfc_add_block_to_block (post, &se.post);
4586
4587	sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
4588	}
4589	}
4590
4591
4592	/* Like gfc_apply_interface_mapping_to_expr, but applied to
4593	constructor C. */
4594
4595	static void
4596	gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
4597	gfc_constructor_base base)
4598	{
4599	gfc_constructor *c;
4600	for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (ctor: c))
4601	{
4602	gfc_apply_interface_mapping_to_expr (mapping, c->expr);
4603	if (c->iterator)
4604	{
4605	gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
4606	gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
4607	gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
4608	}
4609	}
4610	}
4611
4612
4613	/* Like gfc_apply_interface_mapping_to_expr, but applied to
4614	reference REF. */
4615
4616	static void
4617	gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
4618	gfc_ref * ref)
4619	{
4620	int n;
4621
4622	for (; ref; ref = ref->next)
4623	switch (ref->type)
4624	{
4625	case REF_ARRAY:
4626	for (n = 0; n < ref->u.ar.dimen; n++)
4627	{
4628	gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
4629	gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
4630	gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
4631	}
4632	break;
4633
4634	case REF_COMPONENT:
4635	case REF_INQUIRY:
4636	break;
4637
4638	case REF_SUBSTRING:
4639	gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
4640	gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
4641	break;
4642	}
4643	}
4644
4645
4646	/* Convert intrinsic function calls into result expressions. */
4647
4648	static bool
4649	gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
4650	{
4651	gfc_symbol *sym;
4652	gfc_expr *new_expr;
4653	gfc_expr *arg1;
4654	gfc_expr *arg2;
4655	int d, dup;
4656
4657	arg1 = expr->value.function.actual->expr;
4658	if (expr->value.function.actual->next)
4659	arg2 = expr->value.function.actual->next->expr;
4660	else
4661	arg2 = NULL;
4662
4663	sym = arg1->symtree->n.sym;
4664
4665	if (sym->attr.dummy)
4666	return false;
4667
4668	new_expr = NULL;
4669
4670	switch (expr->value.function.isym->id)
4671	{
4672	case GFC_ISYM_LEN:
4673	/* TODO figure out why this condition is necessary. */
4674	if (sym->attr.function
4675	&& (arg1->ts.u.cl->length == NULL
4676	|| (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
4677	&& arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
4678	return false;
4679
4680	new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
4681	break;
4682
4683	case GFC_ISYM_LEN_TRIM:
4684	new_expr = gfc_copy_expr (arg1);
4685	gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4686
4687	if (!new_expr)
4688	return false;
4689
4690	gfc_replace_expr (arg1, new_expr);
4691	return true;
4692
4693	case GFC_ISYM_SIZE:
4694	if (!sym->as || sym->as->rank == 0)
4695	return false;
4696
4697	if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4698	{
4699	dup = mpz_get_si (arg2->value.integer);
4700	d = dup - 1;
4701	}
4702	else
4703	{
4704	dup = sym->as->rank;
4705	d = 0;
4706	}
4707
4708	for (; d < dup; d++)
4709	{
4710	gfc_expr *tmp;
4711
4712	if (!sym->as->upper[d] || !sym->as->lower[d])
4713	{
4714	gfc_free_expr (new_expr);
4715	return false;
4716	}
4717
4718	tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
4719	gfc_get_int_expr (gfc_default_integer_kind,
4720	NULL, 1));
4721	tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
4722	if (new_expr)
4723	new_expr = gfc_multiply (new_expr, tmp);
4724	else
4725	new_expr = tmp;
4726	}
4727	break;
4728
4729	case GFC_ISYM_LBOUND:
4730	case GFC_ISYM_UBOUND:
4731	/* TODO These implementations of lbound and ubound do not limit if
4732	the size < 0, according to F95's 13.14.53 and 13.14.113. */
4733
4734	if (!sym->as || sym->as->rank == 0)
4735	return false;
4736
4737	if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4738	d = mpz_get_si (arg2->value.integer) - 1;
4739	else
4740	return false;
4741
4742	if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
4743	{
4744	if (sym->as->lower[d])
4745	new_expr = gfc_copy_expr (sym->as->lower[d]);
4746	}
4747	else
4748	{
4749	if (sym->as->upper[d])
4750	new_expr = gfc_copy_expr (sym->as->upper[d]);
4751	}
4752	break;
4753
4754	default:
4755	break;
4756	}
4757
4758	gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4759	if (!new_expr)
4760	return false;
4761
4762	gfc_replace_expr (expr, new_expr);
4763	return true;
4764	}
4765
4766
4767	static void
4768	gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
4769	gfc_interface_mapping * mapping)
4770	{
4771	gfc_formal_arglist *f;
4772	gfc_actual_arglist *actual;
4773
4774	actual = expr->value.function.actual;
4775	f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
4776
4777	for (; f && actual; f = f->next, actual = actual->next)
4778	{
4779	if (!actual->expr)
4780	continue;
4781
4782	gfc_add_interface_mapping (mapping, sym: f->sym, NULL, expr: actual->expr);
4783	}
4784
4785	if (map_expr->symtree->n.sym->attr.dimension)
4786	{
4787	int d;
4788	gfc_array_spec *as;
4789
4790	as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
4791
4792	for (d = 0; d < as->rank; d++)
4793	{
4794	gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
4795	gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
4796	}
4797
4798	expr->value.function.esym->as = as;
4799	}
4800
4801	if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
4802	{
4803	expr->value.function.esym->ts.u.cl->length
4804	= gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
4805
4806	gfc_apply_interface_mapping_to_expr (mapping,
4807	expr->value.function.esym->ts.u.cl->length);
4808	}
4809	}
4810
4811
4812	/* EXPR is a copy of an expression that appeared in the interface
4813	associated with MAPPING. Walk it recursively looking for references to
4814	dummy arguments that MAPPING maps to actual arguments. Replace each such
4815	reference with a reference to the associated actual argument. */
4816
4817	static void
4818	gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
4819	gfc_expr * expr)
4820	{
4821	gfc_interface_sym_mapping *sym;
4822	gfc_actual_arglist *actual;
4823
4824	if (!expr)
4825	return;
4826
4827	/* Copying an expression does not copy its length, so do that here. */
4828	if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
4829	{
4830	expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, cl: expr->ts.u.cl);
4831	gfc_apply_interface_mapping_to_expr (mapping, expr: expr->ts.u.cl->length);
4832	}
4833
4834	/* Apply the mapping to any references. */
4835	gfc_apply_interface_mapping_to_ref (mapping, ref: expr->ref);
4836
4837	/* ...and to the expression's symbol, if it has one. */
4838	/* TODO Find out why the condition on expr->symtree had to be moved into
4839	the loop rather than being outside it, as originally. */
4840	for (sym = mapping->syms; sym; sym = sym->next)
4841	if (expr->symtree && sym->old == expr->symtree->n.sym)
4842	{
4843	if (sym->new_sym->n.sym->backend_decl)
4844	expr->symtree = sym->new_sym;
4845	else if (sym->expr)
4846	gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
4847	}
4848
4849	/* ...and to subexpressions in expr->value. */
4850	switch (expr->expr_type)
4851	{
4852	case EXPR_VARIABLE:
4853	case EXPR_CONSTANT:
4854	case EXPR_NULL:
4855	case EXPR_SUBSTRING:
4856	break;
4857
4858	case EXPR_OP:
4859	gfc_apply_interface_mapping_to_expr (mapping, expr: expr->value.op.op1);
4860	gfc_apply_interface_mapping_to_expr (mapping, expr: expr->value.op.op2);
4861	break;
4862
4863	case EXPR_FUNCTION:
4864	for (actual = expr->value.function.actual; actual; actual = actual->next)
4865	gfc_apply_interface_mapping_to_expr (mapping, expr: actual->expr);
4866
4867	if (expr->value.function.esym == NULL
4868	&& expr->value.function.isym != NULL
4869	&& expr->value.function.actual
4870	&& expr->value.function.actual->expr
4871	&& expr->value.function.actual->expr->symtree
4872	&& gfc_map_intrinsic_function (expr, mapping))
4873	break;
4874
4875	for (sym = mapping->syms; sym; sym = sym->next)
4876	if (sym->old == expr->value.function.esym)
4877	{
4878	expr->value.function.esym = sym->new_sym->n.sym;
4879	gfc_map_fcn_formal_to_actual (expr, map_expr: sym->expr, mapping);
4880	expr->value.function.esym->result = sym->new_sym->n.sym;
4881	}
4882	break;
4883
4884	case EXPR_ARRAY:
4885	case EXPR_STRUCTURE:
4886	gfc_apply_interface_mapping_to_cons (mapping, base: expr->value.constructor);
4887	break;
4888
4889	case EXPR_COMPCALL:
4890	case EXPR_PPC:
4891	case EXPR_UNKNOWN:
4892	gcc_unreachable ();
4893	break;
4894	}
4895
4896	return;
4897	}
4898
4899
4900	/* Evaluate interface expression EXPR using MAPPING. Store the result
4901	in SE. */
4902
4903	void
4904	gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
4905	gfc_se * se, gfc_expr * expr)
4906	{
4907	expr = gfc_copy_expr (expr);
4908	gfc_apply_interface_mapping_to_expr (mapping, expr);
4909	gfc_conv_expr (se, expr);
4910	se->expr = gfc_evaluate_now (se->expr, &se->pre);
4911	gfc_free_expr (expr);
4912	}
4913
4914
4915	/* Returns a reference to a temporary array into which a component of
4916	an actual argument derived type array is copied and then returned
4917	after the function call. */
4918	void
4919	gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
4920	sym_intent intent, bool formal_ptr,
4921	const gfc_symbol *fsym, const char *proc_name,
4922	gfc_symbol *sym, bool check_contiguous)
4923	{
4924	gfc_se lse;
4925	gfc_se rse;
4926	gfc_ss *lss;
4927	gfc_ss *rss;
4928	gfc_loopinfo loop;
4929	gfc_loopinfo loop2;
4930	gfc_array_info *info;
4931	tree offset;
4932	tree tmp_index;
4933	tree tmp;
4934	tree base_type;
4935	tree size;
4936	stmtblock_t body;
4937	int n;
4938	int dimen;
4939	gfc_se work_se;
4940	gfc_se *parmse;
4941	bool pass_optional;
4942
4943	pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
4944
4945	if (pass_optional || check_contiguous)
4946	{
4947	gfc_init_se (se: &work_se, NULL);
4948	parmse = &work_se;
4949	}
4950	else
4951	parmse = se;
4952
4953	if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
4954	{
4955	/* We will create a temporary array, so let us warn. */
4956	char * msg;
4957
4958	if (fsym && proc_name)
4959	msg = xasprintf ("An array temporary was created for argument "
4960	"'%s' of procedure '%s'", fsym->name, proc_name);
4961	else
4962	msg = xasprintf ("An array temporary was created");
4963
4964	tmp = build_int_cst (logical_type_node, 1);
4965	gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
4966	&expr->where, msg);
4967	free (ptr: msg);
4968	}
4969
4970	gfc_init_se (se: &lse, NULL);
4971	gfc_init_se (se: &rse, NULL);
4972
4973	/* Walk the argument expression. */
4974	rss = gfc_walk_expr (expr);
4975
4976	gcc_assert (rss != gfc_ss_terminator);
4977
4978	/* Initialize the scalarizer. */
4979	gfc_init_loopinfo (&loop);
4980	gfc_add_ss_to_loop (&loop, rss);
4981
4982	/* Calculate the bounds of the scalarization. */
4983	gfc_conv_ss_startstride (&loop);
4984
4985	/* Build an ss for the temporary. */
4986	if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
4987	gfc_conv_string_length (cl: expr->ts.u.cl, expr, pblock: &parmse->pre);
4988
4989	base_type = gfc_typenode_for_spec (&expr->ts);
4990	if (GFC_ARRAY_TYPE_P (base_type)
4991	|| GFC_DESCRIPTOR_TYPE_P (base_type))
4992	base_type = gfc_get_element_type (base_type);
4993
4994	if (expr->ts.type == BT_CLASS)
4995	base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
4996
4997	loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
4998	? expr->ts.u.cl->backend_decl
4999	: NULL),
5000	loop.dimen);
5001
5002	parmse->string_length = loop.temp_ss->info->string_length;
5003
5004	/* Associate the SS with the loop. */
5005	gfc_add_ss_to_loop (&loop, loop.temp_ss);
5006
5007	/* Setup the scalarizing loops. */
5008	gfc_conv_loop_setup (&loop, &expr->where);
5009
5010	/* Pass the temporary descriptor back to the caller. */
5011	info = &loop.temp_ss->info->data.array;
5012	parmse->expr = info->descriptor;
5013
5014	/* Setup the gfc_se structures. */
5015	gfc_copy_loopinfo_to_se (&lse, &loop);
5016	gfc_copy_loopinfo_to_se (&rse, &loop);
5017
5018	rse.ss = rss;
5019	lse.ss = loop.temp_ss;
5020	gfc_mark_ss_chain_used (rss, 1);
5021	gfc_mark_ss_chain_used (loop.temp_ss, 1);
5022
5023	/* Start the scalarized loop body. */
5024	gfc_start_scalarized_body (&loop, &body);
5025
5026	/* Translate the expression. */
5027	gfc_conv_expr (se: &rse, expr);
5028
5029	/* Reset the offset for the function call since the loop
5030	is zero based on the data pointer. Note that the temp
5031	comes first in the loop chain since it is added second. */
5032	if (gfc_is_class_array_function (expr))
5033	{
5034	tmp = loop.ss->loop_chain->info->data.array.descriptor;
5035	gfc_conv_descriptor_offset_set (&loop.pre, tmp,
5036	gfc_index_zero_node);
5037	}
5038
5039	gfc_conv_tmp_array_ref (se: &lse);
5040
5041	if (intent != INTENT_OUT)
5042	{
5043	tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
5044	gfc_add_expr_to_block (&body, tmp);
5045	gcc_assert (rse.ss == gfc_ss_terminator);
5046	gfc_trans_scalarizing_loops (&loop, &body);
5047	}
5048	else
5049	{
5050	/* Make sure that the temporary declaration survives by merging
5051	all the loop declarations into the current context. */
5052	for (n = 0; n < loop.dimen; n++)
5053	{
5054	gfc_merge_block_scope (block: &body);
5055	body = loop.code[loop.order[n]];
5056	}
5057	gfc_merge_block_scope (block: &body);
5058	}
5059
5060	/* Add the post block after the second loop, so that any
5061	freeing of allocated memory is done at the right time. */
5062	gfc_add_block_to_block (&parmse->pre, &loop.pre);
5063
5064	/**********Copy the temporary back again.*********/
5065
5066	gfc_init_se (se: &lse, NULL);
5067	gfc_init_se (se: &rse, NULL);
5068
5069	/* Walk the argument expression. */
5070	lss = gfc_walk_expr (expr);
5071	rse.ss = loop.temp_ss;
5072	lse.ss = lss;
5073
5074	/* Initialize the scalarizer. */
5075	gfc_init_loopinfo (&loop2);
5076	gfc_add_ss_to_loop (&loop2, lss);
5077
5078	dimen = rse.ss->dimen;
5079
5080	/* Skip the write-out loop for this case. */
5081	if (gfc_is_class_array_function (expr))
5082	goto class_array_fcn;
5083
5084	/* Calculate the bounds of the scalarization. */
5085	gfc_conv_ss_startstride (&loop2);
5086
5087	/* Setup the scalarizing loops. */
5088	gfc_conv_loop_setup (&loop2, &expr->where);
5089
5090	gfc_copy_loopinfo_to_se (&lse, &loop2);
5091	gfc_copy_loopinfo_to_se (&rse, &loop2);
5092
5093	gfc_mark_ss_chain_used (lss, 1);
5094	gfc_mark_ss_chain_used (loop.temp_ss, 1);
5095
5096	/* Declare the variable to hold the temporary offset and start the
5097	scalarized loop body. */
5098	offset = gfc_create_var (gfc_array_index_type, NULL);
5099	gfc_start_scalarized_body (&loop2, &body);
5100
5101	/* Build the offsets for the temporary from the loop variables. The
5102	temporary array has lbounds of zero and strides of one in all
5103	dimensions, so this is very simple. The offset is only computed
5104	outside the innermost loop, so the overall transfer could be
5105	optimized further. */
5106	info = &rse.ss->info->data.array;
5107
5108	tmp_index = gfc_index_zero_node;
5109	for (n = dimen - 1; n > 0; n--)
5110	{
5111	tree tmp_str;
5112	tmp = rse.loop->loopvar[n];
5113	tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5114	tmp, rse.loop->from[n]);
5115	tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5116	tmp, tmp_index);
5117
5118	tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
5119	gfc_array_index_type,
5120	rse.loop->to[n-1], rse.loop->from[n-1]);
5121	tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
5122	gfc_array_index_type,
5123	tmp_str, gfc_index_one_node);
5124
5125	tmp_index = fold_build2_loc (input_location, MULT_EXPR,
5126	gfc_array_index_type, tmp, tmp_str);
5127	}
5128
5129	tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
5130	gfc_array_index_type,
5131	tmp_index, rse.loop->from[0]);
5132	gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
5133
5134	tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
5135	gfc_array_index_type,
5136	rse.loop->loopvar[0], offset);
5137
5138	/* Now use the offset for the reference. */
5139	tmp = build_fold_indirect_ref_loc (input_location,
5140	info->data);
5141	rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
5142
5143	if (expr->ts.type == BT_CHARACTER)
5144	rse.string_length = expr->ts.u.cl->backend_decl;
5145
5146	gfc_conv_expr (se: &lse, expr);
5147
5148	gcc_assert (lse.ss == gfc_ss_terminator);
5149
5150	tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
5151	gfc_add_expr_to_block (&body, tmp);
5152
5153	/* Generate the copying loops. */
5154	gfc_trans_scalarizing_loops (&loop2, &body);
5155
5156	/* Wrap the whole thing up by adding the second loop to the post-block
5157	and following it by the post-block of the first loop. In this way,
5158	if the temporary needs freeing, it is done after use! */
5159	if (intent != INTENT_IN)
5160	{
5161	gfc_add_block_to_block (&parmse->post, &loop2.pre);
5162	gfc_add_block_to_block (&parmse->post, &loop2.post);
5163	}
5164
5165	class_array_fcn:
5166
5167	gfc_add_block_to_block (&parmse->post, &loop.post);
5168
5169	gfc_cleanup_loop (&loop);
5170	gfc_cleanup_loop (&loop2);
5171
5172	/* Pass the string length to the argument expression. */
5173	if (expr->ts.type == BT_CHARACTER)
5174	parmse->string_length = expr->ts.u.cl->backend_decl;
5175
5176	/* Determine the offset for pointer formal arguments and set the
5177	lbounds to one. */
5178	if (formal_ptr)
5179	{
5180	size = gfc_index_one_node;
5181	offset = gfc_index_zero_node;
5182	for (n = 0; n < dimen; n++)
5183	{
5184	tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
5185	gfc_rank_cst[n]);
5186	tmp = fold_build2_loc (input_location, PLUS_EXPR,
5187	gfc_array_index_type, tmp,
5188	gfc_index_one_node);
5189	gfc_conv_descriptor_ubound_set (&parmse->pre,
5190	parmse->expr,
5191	gfc_rank_cst[n],
5192	tmp);
5193	gfc_conv_descriptor_lbound_set (&parmse->pre,
5194	parmse->expr,
5195	gfc_rank_cst[n],
5196	gfc_index_one_node);
5197	size = gfc_evaluate_now (size, &parmse->pre);
5198	offset = fold_build2_loc (input_location, MINUS_EXPR,
5199	gfc_array_index_type,
5200	offset, size);
5201	offset = gfc_evaluate_now (offset, &parmse->pre);
5202	tmp = fold_build2_loc (input_location, MINUS_EXPR,
5203	gfc_array_index_type,
5204	rse.loop->to[n], rse.loop->from[n]);
5205	tmp = fold_build2_loc (input_location, PLUS_EXPR,
5206	gfc_array_index_type,
5207	tmp, gfc_index_one_node);
5208	size = fold_build2_loc (input_location, MULT_EXPR,
5209	gfc_array_index_type, size, tmp);
5210	}
5211
5212	gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
5213	offset);
5214	}
5215
5216	/* We want either the address for the data or the address of the descriptor,
5217	depending on the mode of passing array arguments. */
5218	if (g77)
5219	parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
5220	else
5221	parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5222
5223	/* Basically make this into
5224
5225	if (present)
5226	{
5227	if (contiguous)
5228	{
5229	pointer = a;
5230	}
5231	else
5232	{
5233	parmse->pre();
5234	pointer = parmse->expr;
5235	}
5236	}
5237	else
5238	pointer = NULL;
5239
5240	foo (pointer);
5241	if (present && !contiguous)
5242	se->post();
5243
5244	*/
5245
5246	if (pass_optional || check_contiguous)
5247	{
5248	tree type;
5249	stmtblock_t else_block;
5250	tree pre_stmts, post_stmts;
5251	tree pointer;
5252	tree else_stmt;
5253	tree present_var = NULL_TREE;
5254	tree cont_var = NULL_TREE;
5255	tree post_cond;
5256
5257	type = TREE_TYPE (parmse->expr);
5258	if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
5259	type = TREE_TYPE (type);
5260	pointer = gfc_create_var (type, "arg_ptr");
5261
5262	if (check_contiguous)
5263	{
5264	gfc_se cont_se, array_se;
5265	stmtblock_t if_block, else_block;
5266	tree if_stmt, else_stmt;
5267	mpz_t size;
5268	bool size_set;
5269
5270	cont_var = gfc_create_var (boolean_type_node, "contiguous");
5271
5272	/* If the size is known to be one at compile-time, set
5273	cont_var to true unconditionally. This may look
5274	inelegant, but we're only doing this during
5275	optimization, so the statements will be optimized away,
5276	and this saves complexity here. */
5277
5278	size_set = gfc_array_size (expr, &size);
5279	if (size_set && mpz_cmp_ui (size, 1) == 0)
5280	{
5281	gfc_add_modify (&se->pre, cont_var,
5282	build_one_cst (boolean_type_node));
5283	}
5284	else
5285	{
5286	/* cont_var = is_contiguous (expr); . */
5287	gfc_init_se (se: &cont_se, parent: parmse);
5288	gfc_conv_is_contiguous_expr (&cont_se, expr);
5289	gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
5290	gfc_add_modify (&se->pre, cont_var, cont_se.expr);
5291	gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
5292	}
5293
5294	if (size_set)
5295	mpz_clear (size);
5296
5297	/* arrayse->expr = descriptor of a. */
5298	gfc_init_se (se: &array_se, parent: se);
5299	gfc_conv_expr_descriptor (&array_se, expr);
5300	gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
5301	gfc_add_block_to_block (&se->pre, &(&array_se)->post);
5302
5303	/* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
5304	gfc_init_block (&if_block);
5305	if (GFC_DESCRIPTOR_TYPE_P (type))
5306	gfc_add_modify (&if_block, pointer, array_se.expr);
5307	else
5308	{
5309	tmp = gfc_conv_array_data (array_se.expr);
5310	tmp = fold_convert (type, tmp);
5311	gfc_add_modify (&if_block, pointer, tmp);
5312	}
5313	if_stmt = gfc_finish_block (&if_block);
5314
5315	/* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5316	gfc_init_block (&else_block);
5317	gfc_add_block_to_block (&else_block, &parmse->pre);
5318	tmp = (GFC_DESCRIPTOR_TYPE_P (type)
5319	? build_fold_indirect_ref_loc (input_location, parmse->expr)
5320	: parmse->expr);
5321	gfc_add_modify (&else_block, pointer, tmp);
5322	else_stmt = gfc_finish_block (&else_block);
5323
5324	/* And put the above into an if statement. */
5325	pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5326	gfc_likely (cont_var,
5327	PRED_FORTRAN_CONTIGUOUS),
5328	if_stmt, else_stmt);
5329	}
5330	else
5331	{
5332	/* pointer = pramse->expr; . */
5333	gfc_add_modify (&parmse->pre, pointer, parmse->expr);
5334	pre_stmts = gfc_finish_block (&parmse->pre);
5335	}
5336
5337	if (pass_optional)
5338	{
5339	present_var = gfc_create_var (boolean_type_node, "present");
5340
5341	/* present_var = present(sym); . */
5342	tmp = gfc_conv_expr_present (sym);
5343	tmp = fold_convert (boolean_type_node, tmp);
5344	gfc_add_modify (&se->pre, present_var, tmp);
5345
5346	/* else_stmt = { pointer = NULL; } . */
5347	gfc_init_block (&else_block);
5348	if (GFC_DESCRIPTOR_TYPE_P (type))
5349	gfc_conv_descriptor_data_set (&else_block, pointer,
5350	null_pointer_node);
5351	else
5352	gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
5353	else_stmt = gfc_finish_block (&else_block);
5354
5355	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5356	gfc_likely (present_var,
5357	PRED_FORTRAN_ABSENT_DUMMY),
5358	pre_stmts, else_stmt);
5359	gfc_add_expr_to_block (&se->pre, tmp);
5360	}
5361	else
5362	gfc_add_expr_to_block (&se->pre, pre_stmts);
5363
5364	post_stmts = gfc_finish_block (&parmse->post);
5365
5366	/* Put together the post stuff, plus the optional
5367	deallocation. */
5368	if (check_contiguous)
5369	{
5370	/* !cont_var. */
5371	tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5372	cont_var,
5373	build_zero_cst (boolean_type_node));
5374	tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
5375
5376	if (pass_optional)
5377	{
5378	tree present_likely = gfc_likely (present_var,
5379	PRED_FORTRAN_ABSENT_DUMMY);
5380	post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5381	boolean_type_node, present_likely,
5382	tmp);
5383	}
5384	else
5385	post_cond = tmp;
5386	}
5387	else
5388	{
5389	gcc_assert (pass_optional);
5390	post_cond = present_var;
5391	}
5392
5393	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
5394	post_stmts, build_empty_stmt (input_location));
5395	gfc_add_expr_to_block (&se->post, tmp);
5396	if (GFC_DESCRIPTOR_TYPE_P (type))
5397	{
5398	type = TREE_TYPE (parmse->expr);
5399	if (POINTER_TYPE_P (type))
5400	{
5401	pointer = gfc_build_addr_expr (type, pointer);
5402	if (pass_optional)
5403	{
5404	tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
5405	pointer = fold_build3_loc (input_location, COND_EXPR, type,
5406	tmp, pointer,
5407	fold_convert (type,
5408	null_pointer_node));
5409	}
5410	}
5411	else
5412	gcc_assert (!pass_optional);
5413	}
5414	se->expr = pointer;
5415	}
5416
5417	return;
5418	}
5419
5420
5421	/* Generate the code for argument list functions. */
5422
5423	static void
5424	conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
5425	{
5426	/* Pass by value for g77 %VAL(arg), pass the address
5427	indirectly for %LOC, else by reference. Thus %REF
5428	is a "do-nothing" and %LOC is the same as an F95
5429	pointer. */
5430	if (strcmp (s1: name, s2: "%VAL") == 0)
5431	gfc_conv_expr (se, expr);
5432	else if (strcmp (s1: name, s2: "%LOC") == 0)
5433	{
5434	gfc_conv_expr_reference (se, expr);
5435	se->expr = gfc_build_addr_expr (NULL, se->expr);
5436	}
5437	else if (strcmp (s1: name, s2: "%REF") == 0)
5438	gfc_conv_expr_reference (se, expr);
5439	else
5440	gfc_error ("Unknown argument list function at %L", &expr->where);
5441	}
5442
5443
5444	/* This function tells whether the middle-end representation of the expression
5445	E given as input may point to data otherwise accessible through a variable
5446	(sub-)reference.
5447	It is assumed that the only expressions that may alias are variables,
5448	and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
5449	may alias.
5450	This function is used to decide whether freeing an expression's allocatable
5451	components is safe or should be avoided.
5452
5453	If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
5454	its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
5455	is necessary because for array constructors, aliasing depends on how
5456	the array is used:
5457	- If E is an array constructor used as argument to an elemental procedure,
5458	the array, which is generated through shallow copy by the scalarizer,
5459	is used directly and can alias the expressions it was copied from.
5460	- If E is an array constructor used as argument to a non-elemental
5461	procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
5462	the array as in the previous case, but then that array is used
5463	to initialize a new descriptor through deep copy. There is no alias
5464	possible in that case.
5465	Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
5466	above. */
5467
5468	static bool
5469	expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
5470	{
5471	gfc_constructor *c;
5472
5473	if (e->expr_type == EXPR_VARIABLE)
5474	return true;
5475	else if (e->expr_type == EXPR_FUNCTION)
5476	{
5477	gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
5478
5479	if (proc_ifc->result != NULL
5480	&& ((proc_ifc->result->ts.type == BT_CLASS
5481	&& proc_ifc->result->ts.u.derived->attr.is_class
5482	&& CLASS_DATA (proc_ifc->result)->attr.class_pointer)
5483	|| proc_ifc->result->attr.pointer))
5484	return true;
5485	else
5486	return false;
5487	}
5488	else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
5489	return false;
5490
5491	for (c = gfc_constructor_first (base: e->value.constructor);
5492	c; c = gfc_constructor_next (ctor: c))
5493	if (c->expr
5494	&& expr_may_alias_variables (e: c->expr, array_may_alias))
5495	return true;
5496
5497	return false;
5498	}
5499
5500
5501	/* A helper function to set the dtype for unallocated or unassociated
5502	entities. */
5503
5504	static void
5505	set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
5506	{
5507	tree tmp;
5508	tree desc;
5509	tree cond;
5510	tree type;
5511	stmtblock_t block;
5512
5513	/* TODO Figure out how to handle optional dummies. */
5514	if (e && e->expr_type == EXPR_VARIABLE
5515	&& e->symtree->n.sym->attr.optional)
5516	return;
5517
5518	desc = parmse->expr;
5519	if (desc == NULL_TREE)
5520	return;
5521
5522	if (POINTER_TYPE_P (TREE_TYPE (desc)))
5523	desc = build_fold_indirect_ref_loc (input_location, desc);
5524	if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
5525	desc = gfc_class_data_get (decl: desc);
5526	if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
5527	return;
5528
5529	gfc_init_block (&block);
5530	tmp = gfc_conv_descriptor_data_get (desc);
5531	cond = fold_build2_loc (input_location, EQ_EXPR,
5532	logical_type_node, tmp,
5533	build_int_cst (TREE_TYPE (tmp), 0));
5534	tmp = gfc_conv_descriptor_dtype (desc);
5535	type = gfc_get_element_type (TREE_TYPE (desc));
5536	tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5537	TREE_TYPE (tmp), tmp,
5538	gfc_get_dtype_rank_type (e->rank, type));
5539	gfc_add_expr_to_block (&block, tmp);
5540	cond = build3_v (COND_EXPR, cond,
5541	gfc_finish_block (&block),
5542	build_empty_stmt (input_location));
5543	gfc_add_expr_to_block (&parmse->pre, cond);
5544	}
5545
5546
5547
5548	/* Provide an interface between gfortran array descriptors and the F2018:18.4
5549	ISO_Fortran_binding array descriptors. */
5550
5551	static void
5552	gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
5553	{
5554	stmtblock_t block, block2;
5555	tree cfi, gfc, tmp, tmp2;
5556	tree present = NULL;
5557	tree gfc_strlen = NULL;
5558	tree rank;
5559	gfc_se se;
5560
5561	if (fsym->attr.optional
5562	&& e->expr_type == EXPR_VARIABLE
5563	&& e->symtree->n.sym->attr.optional)
5564	present = gfc_conv_expr_present (sym: e->symtree->n.sym);
5565
5566	gfc_init_block (&block);
5567
5568	/* Convert original argument to a tree. */
5569	gfc_init_se (se: &se, NULL);
5570	if (e->rank == 0)
5571	{
5572	se.want_pointer = 1;
5573	gfc_conv_expr (se: &se, expr: e);
5574	gfc = se.expr;
5575	/* gfc_conv_constant ignores se.want_poiner, e.g. for string_cst. */
5576	if (!POINTER_TYPE_P (TREE_TYPE (gfc)))
5577	gfc = gfc_build_addr_expr (NULL, gfc);
5578	}
5579	else
5580	{
5581	/* If the actual argument can be noncontiguous, copy-in/out is required,
5582	if the dummy has either the CONTIGUOUS attribute or is an assumed-
5583	length assumed-length/assumed-size CHARACTER array. This only
5584	applies if the actual argument is a "variable"; if it's some
5585	non-lvalue expression, we are going to evaluate it to a
5586	temporary below anyway. */
5587	se.force_no_tmp = 1;
5588	if ((fsym->attr.contiguous
5589	|| (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
5590	&& (fsym->as->type == AS_ASSUMED_SIZE
5591	|| fsym->as->type == AS_EXPLICIT)))
5592	&& !gfc_is_simply_contiguous (e, false, true)
5593	&& gfc_expr_is_variable (e))
5594	{
5595	bool optional = fsym->attr.optional;
5596	fsym->attr.optional = 0;
5597	gfc_conv_subref_array_arg (se: &se, expr: e, g77: false, intent: fsym->attr.intent,
5598	formal_ptr: fsym->attr.pointer, fsym,
5599	proc_name: fsym->ns->proc_name->name, NULL,
5600	/* check_contiguous= */ true);
5601	fsym->attr.optional = optional;
5602	}
5603	else
5604	gfc_conv_expr_descriptor (&se, e);
5605	gfc = se.expr;
5606	/* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
5607	elem_len = sizeof(dt) and base_addr = dt(lb) instead.
5608	gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
5609	While sm is fine as it uses span*stride and not elem_len. */
5610	if (POINTER_TYPE_P (TREE_TYPE (gfc)))
5611	gfc = build_fold_indirect_ref_loc (input_location, gfc);
5612	else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
5613	gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
5614	}
5615	if (e->ts.type == BT_CHARACTER)
5616	{
5617	if (se.string_length)
5618	gfc_strlen = se.string_length;
5619	else if (e->ts.u.cl->backend_decl)
5620	gfc_strlen = e->ts.u.cl->backend_decl;
5621	else
5622	gcc_unreachable ();
5623	}
5624	gfc_add_block_to_block (&block, &se.pre);
5625
5626	/* Create array descriptor and set version, rank, attribute, type. */
5627	cfi = gfc_create_var (gfc_get_cfi_type (dimen: e->rank < 0
5628	? GFC_MAX_DIMENSIONS : e->rank,
5629	restricted: false), "cfi");
5630	/* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
5631	if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
5632	{
5633	tmp = gfc_get_cfi_type (dimen: -1, restricted: !fsym->attr.pointer && !fsym->attr.target);
5634	tmp = build_pointer_type (tmp);
5635	parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
5636	cfi = build_fold_indirect_ref_loc (input_location, cfi);
5637	}
5638	else
5639	parmse->expr = gfc_build_addr_expr (NULL, cfi);
5640
5641	tmp = gfc_get_cfi_desc_version (cfi);
5642	gfc_add_modify (&block, tmp,
5643	build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
5644	if (e->rank < 0)
5645	rank = fold_convert (signed_char_type_node, gfc_conv_descriptor_rank (gfc));
5646	else
5647	rank = build_int_cst (signed_char_type_node, e->rank);
5648	tmp = gfc_get_cfi_desc_rank (cfi);
5649	gfc_add_modify (&block, tmp, rank);
5650	int itype = CFI_type_other;
5651	if (e->ts.f90_type == BT_VOID)
5652	itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
5653	? CFI_type_cfunptr : CFI_type_cptr);
5654	else
5655	{
5656	if (e->expr_type == EXPR_NULL && e->ts.type == BT_UNKNOWN)
5657	e->ts = fsym->ts;
5658	switch (e->ts.type)
5659	{
5660	case BT_INTEGER:
5661	case BT_LOGICAL:
5662	case BT_REAL:
5663	case BT_COMPLEX:
5664	itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
5665	break;
5666	case BT_CHARACTER:
5667	itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind);
5668	break;
5669	case BT_DERIVED:
5670	itype = CFI_type_struct;
5671	break;
5672	case BT_VOID:
5673	itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
5674	? CFI_type_cfunptr : CFI_type_cptr);
5675	break;
5676	case BT_ASSUMED:
5677	itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
5678	break;
5679	case BT_CLASS:
5680	if (fsym->ts.type == BT_ASSUMED)
5681	{
5682	// F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
5683	// type specifier is assumed-type and is an unlimited polymorphic
5684	// entity." The actual argument _data component is passed.
5685	itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
5686	break;
5687	}
5688	else
5689	gcc_unreachable ();
5690	case BT_PROCEDURE:
5691	case BT_HOLLERITH:
5692	case BT_UNION:
5693	case BT_BOZ:
5694	case BT_UNKNOWN:
5695	// FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
5696	gcc_unreachable ();
5697	}
5698	}
5699
5700	tmp = gfc_get_cfi_desc_type (cfi);
5701	gfc_add_modify (&block, tmp,
5702	build_int_cst (TREE_TYPE (tmp), itype));
5703
5704	int attr = CFI_attribute_other;
5705	if (fsym->attr.pointer)
5706	attr = CFI_attribute_pointer;
5707	else if (fsym->attr.allocatable)
5708	attr = CFI_attribute_allocatable;
5709	tmp = gfc_get_cfi_desc_attribute (cfi);
5710	gfc_add_modify (&block, tmp,
5711	build_int_cst (TREE_TYPE (tmp), attr));
5712
5713	/* The cfi-base_addr assignment could be skipped for 'pointer, intent(out)'.
5714	That is very sensible for undefined pointers, but the C code might assume
5715	that the pointer retains the value, in particular, if it was NULL. */
5716	if (e->rank == 0)
5717	{
5718	tmp = gfc_get_cfi_desc_base_addr (cfi);
5719	gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
5720	}
5721	else
5722	{
5723	tmp = gfc_get_cfi_desc_base_addr (cfi);
5724	tmp2 = gfc_conv_descriptor_data_get (gfc);
5725	gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
5726	}
5727
5728	/* Set elem_len if known - must be before the next if block.
5729	Note that allocatable implies 'len=:'. */
5730	if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
5731	{
5732	/* Length is known at compile time; use 'block' for it. */
5733	tmp = size_in_bytes (t: gfc_typenode_for_spec (&e->ts));
5734	tmp2 = gfc_get_cfi_desc_elem_len (cfi);
5735	gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
5736	}
5737
5738	if (fsym->attr.pointer && fsym->attr.intent == INTENT_OUT)
5739	goto done;
5740
5741	/* When allocatable + intent out, free the cfi descriptor. */
5742	if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
5743	{
5744	tmp = gfc_get_cfi_desc_base_addr (cfi);
5745	tree call = builtin_decl_explicit (fncode: BUILT_IN_FREE);
5746	call = build_call_expr_loc (input_location, call, 1, tmp);
5747	gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
5748	gfc_add_modify (&block, tmp,
5749	fold_convert (TREE_TYPE (tmp), null_pointer_node));
5750	goto done;
5751	}
5752
5753	/* If not unallocated/unassociated. */
5754	gfc_init_block (&block2);
5755
5756	/* Set elem_len, which may be only known at run time. */
5757	if (e->ts.type == BT_CHARACTER
5758	&& (e->expr_type != EXPR_NULL || gfc_strlen != NULL_TREE))
5759	{
5760	gcc_assert (gfc_strlen);
5761	tmp = gfc_strlen;
5762	if (e->ts.kind != 1)
5763	tmp = fold_build2_loc (input_location, MULT_EXPR,
5764	gfc_charlen_type_node, tmp,
5765	build_int_cst (gfc_charlen_type_node,
5766	e->ts.kind));
5767	tmp2 = gfc_get_cfi_desc_elem_len (cfi);
5768	gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
5769	}
5770	else if (e->ts.type == BT_ASSUMED)
5771	{
5772	tmp = gfc_conv_descriptor_elem_len (gfc);
5773	tmp2 = gfc_get_cfi_desc_elem_len (cfi);
5774	gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
5775	}
5776
5777	if (e->ts.type == BT_ASSUMED)
5778	{
5779	/* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
5780	an CFI descriptor. Use the type in the descriptor as it provide
5781	mode information. (Quality of implementation feature.) */
5782	tree cond;
5783	tree ctype = gfc_get_cfi_desc_type (cfi);
5784	tree type = fold_convert (TREE_TYPE (ctype),
5785	gfc_conv_descriptor_type (gfc));
5786	tree kind = fold_convert (TREE_TYPE (ctype),
5787	gfc_conv_descriptor_elem_len (gfc));
5788	kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
5789	kind, build_int_cst (TREE_TYPE (type),
5790	CFI_type_kind_shift));
5791
5792	/* if (BT_VOID) CFI_type_cptr else CFI_type_other */
5793	/* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
5794	cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5795	build_int_cst (TREE_TYPE (type), BT_VOID));
5796	tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
5797	build_int_cst (TREE_TYPE (type), CFI_type_cptr));
5798	tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5799	ctype,
5800	build_int_cst (TREE_TYPE (type), CFI_type_other));
5801	tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5802	tmp, tmp2);
5803	/* if (BT_DERIVED) CFI_type_struct else < tmp2 > */
5804	cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5805	build_int_cst (TREE_TYPE (type), BT_DERIVED));
5806	tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
5807	build_int_cst (TREE_TYPE (type), CFI_type_struct));
5808	tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5809	tmp, tmp2);
5810	/* if (BT_CHARACTER) CFI_type_Character + kind=1 else < tmp2 > */
5811	/* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4. */
5812	cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5813	build_int_cst (TREE_TYPE (type), BT_CHARACTER));
5814	tmp = build_int_cst (TREE_TYPE (type),
5815	CFI_type_from_type_kind (CFI_type_Character, 1));
5816	tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5817	ctype, tmp);
5818	tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5819	tmp, tmp2);
5820	/* if (BT_COMPLEX) CFI_type_Complex + kind/2 else < tmp2 > */
5821	cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5822	build_int_cst (TREE_TYPE (type), BT_COMPLEX));
5823	tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
5824	kind, build_int_cst (TREE_TYPE (type), 2));
5825	tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
5826	build_int_cst (TREE_TYPE (type),
5827	CFI_type_Complex));
5828	tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5829	ctype, tmp);
5830	tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5831	tmp, tmp2);
5832	/* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */
5833	cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5834	build_int_cst (TREE_TYPE (type), BT_INTEGER));
5835	tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5836	build_int_cst (TREE_TYPE (type), BT_LOGICAL));
5837	cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
5838	cond, tmp);
5839	tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5840	build_int_cst (TREE_TYPE (type), BT_REAL));
5841	cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
5842	cond, tmp);
5843	tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
5844	type, kind);
5845	tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5846	ctype, tmp);
5847	tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5848	tmp, tmp2);
5849	gfc_add_expr_to_block (&block2, tmp2);
5850	}
5851
5852	if (e->rank != 0)
5853	{
5854	/* Loop: for (i = 0; i < rank; ++i). */
5855	tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
5856	/* Loop body. */
5857	stmtblock_t loop_body;
5858	gfc_init_block (&loop_body);
5859	/* cfi->dim[i].lower_bound = (allocatable/pointer)
5860	? gfc->dim[i].lbound : 0 */
5861	if (fsym->attr.pointer || fsym->attr.allocatable)
5862	tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
5863	else
5864	tmp = gfc_index_zero_node;
5865	gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
5866	/* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
5867	tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5868	gfc_conv_descriptor_ubound_get (gfc, idx),
5869	gfc_conv_descriptor_lbound_get (gfc, idx));
5870	tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5871	tmp, gfc_index_one_node);
5872	gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
5873	/* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
5874	tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5875	gfc_conv_descriptor_stride_get (gfc, idx),
5876	gfc_conv_descriptor_span_get (gfc));
5877	gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
5878
5879	/* Generate loop. */
5880	gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
5881	rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
5882	gfc_finish_block (&loop_body));
5883
5884	if (e->expr_type == EXPR_VARIABLE
5885	&& e->ref
5886	&& e->ref->u.ar.type == AR_FULL
5887	&& e->symtree->n.sym->attr.dummy
5888	&& e->symtree->n.sym->as
5889	&& e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
5890	{
5891	tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
5892	gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
5893	}
5894	}
5895
5896	if (fsym->attr.allocatable || fsym->attr.pointer)
5897	{
5898	tmp = gfc_get_cfi_desc_base_addr (cfi),
5899	tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5900	tmp, null_pointer_node);
5901	tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
5902	build_empty_stmt (input_location));
5903	gfc_add_expr_to_block (&block, tmp);
5904	}
5905	else
5906	gfc_add_block_to_block (&block, &block2);
5907
5908
5909	done:
5910	if (present)
5911	{
5912	parmse->expr = build3_loc (loc: input_location, code: COND_EXPR,
5913	TREE_TYPE (parmse->expr),
5914	arg0: present, arg1: parmse->expr, null_pointer_node);
5915	tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
5916	build_empty_stmt (input_location));
5917	gfc_add_expr_to_block (&parmse->pre, tmp);
5918	}
5919	else
5920	gfc_add_block_to_block (&parmse->pre, &block);
5921
5922	gfc_init_block (&block);
5923
5924	if ((!fsym->attr.allocatable && !fsym->attr.pointer)
5925	|| fsym->attr.intent == INTENT_IN)
5926	goto post_call;
5927
5928	gfc_init_block (&block2);
5929	if (e->rank == 0)
5930	{
5931	tmp = gfc_get_cfi_desc_base_addr (cfi);
5932	gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
5933	}
5934	else
5935	{
5936	tmp = gfc_get_cfi_desc_base_addr (cfi);
5937	gfc_conv_descriptor_data_set (&block, gfc, tmp);
5938
5939	if (fsym->attr.allocatable)
5940	{
5941	/* gfc->span = cfi->elem_len. */
5942	tmp = fold_convert (gfc_array_index_type,
5943	gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
5944	}
5945	else
5946	{
5947	/* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
5948	? cfi->dim[0].sm : cfi->elem_len). */
5949	tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
5950	tmp2 = fold_convert (gfc_array_index_type,
5951	gfc_get_cfi_desc_elem_len (cfi));
5952	tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
5953	gfc_array_index_type, tmp, tmp2);
5954	tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5955	tmp, gfc_index_zero_node);
5956	tmp = build3_loc (loc: input_location, code: COND_EXPR, type: gfc_array_index_type, arg0: tmp,
5957	arg1: gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), arg2: tmp2);
5958	}
5959	gfc_conv_descriptor_span_set (&block2, gfc, tmp);
5960
5961	/* Calculate offset + set lbound, ubound and stride. */
5962	gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
5963	/* Loop: for (i = 0; i < rank; ++i). */
5964	tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
5965	/* Loop body. */
5966	stmtblock_t loop_body;
5967	gfc_init_block (&loop_body);
5968	/* gfc->dim[i].lbound = ... */
5969	tmp = gfc_get_cfi_dim_lbound (cfi, idx);
5970	gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
5971
5972	/* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
5973	tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5974	gfc_conv_descriptor_lbound_get (gfc, idx),
5975	gfc_index_one_node);
5976	tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5977	gfc_get_cfi_dim_extent (cfi, idx), tmp);
5978	gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
5979
5980	/* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
5981	tmp = gfc_get_cfi_dim_sm (cfi, idx);
5982	tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
5983	gfc_array_index_type, tmp,
5984	fold_convert (gfc_array_index_type,
5985	gfc_get_cfi_desc_elem_len (cfi)));
5986	gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
5987
5988	/* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
5989	tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5990	gfc_conv_descriptor_stride_get (gfc, idx),
5991	gfc_conv_descriptor_lbound_get (gfc, idx));
5992	tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5993	gfc_conv_descriptor_offset_get (gfc), tmp);
5994	gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
5995	/* Generate loop. */
5996	gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
5997	rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
5998	gfc_finish_block (&loop_body));
5999	}
6000
6001	if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
6002	{
6003	tmp = fold_convert (gfc_charlen_type_node,
6004	gfc_get_cfi_desc_elem_len (cfi));
6005	if (e->ts.kind != 1)
6006	tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6007	gfc_charlen_type_node, tmp,
6008	build_int_cst (gfc_charlen_type_node,
6009	e->ts.kind));
6010	gfc_add_modify (&block2, gfc_strlen, tmp);
6011	}
6012
6013	tmp = gfc_get_cfi_desc_base_addr (cfi),
6014	tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6015	tmp, null_pointer_node);
6016	tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6017	build_empty_stmt (input_location));
6018	gfc_add_expr_to_block (&block, tmp);
6019
6020	post_call:
6021	gfc_add_block_to_block (&block, &se.post);
6022	if (present && block.head)
6023	{
6024	tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6025	build_empty_stmt (input_location));
6026	gfc_add_expr_to_block (&parmse->post, tmp);
6027	}
6028	else if (block.head)
6029	gfc_add_block_to_block (&parmse->post, &block);
6030	}
6031
6032
6033	/* Create "conditional temporary" to handle scalar dummy variables with the
6034	OPTIONAL+VALUE attribute that shall not be dereferenced. Use null value
6035	as fallback. Only instances of intrinsic basic type are supported. */
6036
6037	static void
6038	conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond)
6039	{
6040	tree temp;
6041	gcc_assert (e->ts.type != BT_DERIVED && e->ts.type != BT_CLASS);
6042	gcc_assert (e->rank == 0);
6043	temp = gfc_create_var (TREE_TYPE (parmse->expr), "condtemp");
6044	TREE_STATIC (temp) = 1;
6045	TREE_CONSTANT (temp) = 1;
6046	TREE_READONLY (temp) = 1;
6047	DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6048	parmse->expr = fold_build3_loc (input_location, COND_EXPR,
6049	TREE_TYPE (parmse->expr),
6050	cond, parmse->expr, temp);
6051	parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
6052	}
6053
6054
6055	/* Generate code for a procedure call. Note can return se->post != NULL.
6056	If se->direct_byref is set then se->expr contains the return parameter.
6057	Return nonzero, if the call has alternate specifiers.
6058	'expr' is only needed for procedure pointer components. */
6059
6060	int
6061	gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
6062	gfc_actual_arglist * args, gfc_expr * expr,
6063	vec<tree, va_gc> *append_args)
6064	{
6065	gfc_interface_mapping mapping;
6066	vec<tree, va_gc> *arglist;
6067	vec<tree, va_gc> *retargs;
6068	tree tmp;
6069	tree fntype;
6070	gfc_se parmse;
6071	gfc_array_info *info;
6072	int byref;
6073	int parm_kind;
6074	tree type;
6075	tree var;
6076	tree len;
6077	tree base_object;
6078	vec<tree, va_gc> *stringargs;
6079	vec<tree, va_gc> *optionalargs;
6080	tree result = NULL;
6081	gfc_formal_arglist *formal;
6082	gfc_actual_arglist *arg;
6083	int has_alternate_specifier = 0;
6084	bool need_interface_mapping;
6085	bool callee_alloc;
6086	bool ulim_copy;
6087	gfc_typespec ts;
6088	gfc_charlen cl;
6089	gfc_expr *e;
6090	gfc_symbol *fsym;
6091	enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
6092	gfc_component *comp = NULL;
6093	int arglen;
6094	unsigned int argc;
6095
6096	arglist = NULL;
6097	retargs = NULL;
6098	stringargs = NULL;
6099	optionalargs = NULL;
6100	var = NULL_TREE;
6101	len = NULL_TREE;
6102	gfc_clear_ts (&ts);
6103
6104	comp = gfc_get_proc_ptr_comp (expr);
6105
6106	bool elemental_proc = (comp
6107	&& comp->ts.interface
6108	&& comp->ts.interface->attr.elemental)
6109	|| (comp && comp->attr.elemental)
6110	|| sym->attr.elemental;
6111
6112	if (se->ss != NULL)
6113	{
6114	if (!elemental_proc)
6115	{
6116	gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
6117	if (se->ss->info->useflags)
6118	{
6119	gcc_assert ((!comp && gfc_return_by_reference (sym)
6120	&& sym->result->attr.dimension)
6121	|| (comp && comp->attr.dimension)
6122	|| gfc_is_class_array_function (expr));
6123	gcc_assert (se->loop != NULL);
6124	/* Access the previously obtained result. */
6125	gfc_conv_tmp_array_ref (se);
6126	return 0;
6127	}
6128	}
6129	info = &se->ss->info->data.array;
6130	}
6131	else
6132	info = NULL;
6133
6134	stmtblock_t post, clobbers, dealloc_blk;
6135	gfc_init_block (&post);
6136	gfc_init_block (&clobbers);
6137	gfc_init_block (&dealloc_blk);
6138	gfc_init_interface_mapping (mapping: &mapping);
6139	if (!comp)
6140	{
6141	formal = gfc_sym_get_dummy_args (sym);
6142	need_interface_mapping = sym->attr.dimension ||
6143	(sym->ts.type == BT_CHARACTER
6144	&& sym->ts.u.cl->length
6145	&& sym->ts.u.cl->length->expr_type
6146	!= EXPR_CONSTANT);
6147	}
6148	else
6149	{
6150	formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
6151	need_interface_mapping = comp->attr.dimension ||
6152	(comp->ts.type == BT_CHARACTER
6153	&& comp->ts.u.cl->length
6154	&& comp->ts.u.cl->length->expr_type
6155	!= EXPR_CONSTANT);
6156	}
6157
6158	base_object = NULL_TREE;
6159	/* For _vprt->_copy () routines no formal symbol is present. Nevertheless
6160	is the third and fourth argument to such a function call a value
6161	denoting the number of elements to copy (i.e., most of the time the
6162	length of a deferred length string). */
6163	ulim_copy = (formal == NULL)
6164	&& UNLIMITED_POLY (sym)
6165	&& comp && (strcmp (s1: "_copy", s2: comp->name) == 0);
6166
6167	/* Scan for allocatable actual arguments passed to allocatable dummy
6168	arguments with INTENT(OUT). As the corresponding actual arguments are
6169	deallocated before execution of the procedure, we evaluate actual
6170	argument expressions to avoid problems with possible dependencies. */
6171	bool force_eval_args = false;
6172	gfc_formal_arglist *tmp_formal;
6173	for (arg = args, tmp_formal = formal; arg != NULL;
6174	arg = arg->next, tmp_formal = tmp_formal ? tmp_formal->next : NULL)
6175	{
6176	e = arg->expr;
6177	fsym = tmp_formal ? tmp_formal->sym : NULL;
6178	if (e && fsym
6179	&& e->expr_type == EXPR_VARIABLE
6180	&& fsym->attr.intent == INTENT_OUT
6181	&& (fsym->ts.type == BT_CLASS && fsym->attr.class_ok
6182	? CLASS_DATA (fsym)->attr.allocatable
6183	: fsym->attr.allocatable)
6184	&& e->symtree
6185	&& e->symtree->n.sym
6186	&& gfc_variable_attr (e, NULL).allocatable)
6187	{
6188	force_eval_args = true;
6189	break;
6190	}
6191	}
6192
6193	/* Evaluate the arguments. */
6194	for (arg = args, argc = 0; arg != NULL;
6195	arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
6196	{
6197	bool finalized = false;
6198	tree derived_array = NULL_TREE;
6199
6200	e = arg->expr;
6201	fsym = formal ? formal->sym : NULL;
6202	parm_kind = MISSING;
6203
6204	/* If the procedure requires an explicit interface, the actual
6205	argument is passed according to the corresponding formal
6206	argument. If the corresponding formal argument is a POINTER,
6207	ALLOCATABLE or assumed shape, we do not use g77's calling
6208	convention, and pass the address of the array descriptor
6209	instead. Otherwise we use g77's calling convention, in other words
6210	pass the array data pointer without descriptor. */
6211	bool nodesc_arg = fsym != NULL
6212	&& !(fsym->attr.pointer || fsym->attr.allocatable)
6213	&& fsym->as
6214	&& fsym->as->type != AS_ASSUMED_SHAPE
6215	&& fsym->as->type != AS_ASSUMED_RANK;
6216	if (comp)
6217	nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
6218	else
6219	nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
6220
6221	/* Class array expressions are sometimes coming completely unadorned
6222	with either arrayspec or _data component. Correct that here.
6223	OOP-TODO: Move this to the frontend. */
6224	if (e && e->expr_type == EXPR_VARIABLE
6225	&& !e->ref
6226	&& e->ts.type == BT_CLASS
6227	&& (CLASS_DATA (e)->attr.codimension
6228	|| CLASS_DATA (e)->attr.dimension))
6229	{
6230	gfc_typespec temp_ts = e->ts;
6231	gfc_add_class_array_ref (e);
6232	e->ts = temp_ts;
6233	}
6234
6235	if (e == NULL)
6236	{
6237	if (se->ignore_optional)
6238	{
6239	/* Some intrinsics have already been resolved to the correct
6240	parameters. */
6241	continue;
6242	}
6243	else if (arg->label)
6244	{
6245	has_alternate_specifier = 1;
6246	continue;
6247	}
6248	else
6249	{
6250	gfc_init_se (se: &parmse, NULL);
6251
6252	/* For scalar arguments with VALUE attribute which are passed by
6253	value, pass "0" and a hidden argument gives the optional
6254	status. */
6255	if (fsym && fsym->attr.optional && fsym->attr.value
6256	&& !fsym->attr.dimension && fsym->ts.type != BT_CLASS
6257	&& !gfc_bt_struct (sym->ts.type))
6258	{
6259	if (fsym->ts.type == BT_CHARACTER)
6260	{
6261	/* Pass a NULL pointer for an absent CHARACTER arg
6262	and a length of zero. */
6263	parmse.expr = null_pointer_node;
6264	parmse.string_length
6265	= build_int_cst (gfc_charlen_type_node,
6266	0);
6267	}
6268	else
6269	parmse.expr = fold_convert (gfc_sym_type (fsym),
6270	integer_zero_node);
6271	vec_safe_push (v&: optionalargs, boolean_false_node);
6272	}
6273	else
6274	{
6275	/* Pass a NULL pointer for an absent arg. */
6276	parmse.expr = null_pointer_node;
6277	gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
6278	if (dummy_arg
6279	&& gfc_dummy_arg_get_typespec (*dummy_arg).type
6280	== BT_CHARACTER)
6281	parmse.string_length = build_int_cst (gfc_charlen_type_node,
6282	0);
6283	}
6284	}
6285	}
6286	else if (arg->expr->expr_type == EXPR_NULL
6287	&& fsym && !fsym->attr.pointer
6288	&& (fsym->ts.type != BT_CLASS
6289	|| !CLASS_DATA (fsym)->attr.class_pointer))
6290	{
6291	/* Pass a NULL pointer to denote an absent arg. */
6292	gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
6293	&& (fsym->ts.type != BT_CLASS
6294	|| !CLASS_DATA (fsym)->attr.allocatable));
6295	gfc_init_se (se: &parmse, NULL);
6296	parmse.expr = null_pointer_node;
6297	if (arg->associated_dummy
6298	&& gfc_dummy_arg_get_typespec (*arg->associated_dummy).type
6299	== BT_CHARACTER)
6300	parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
6301	}
6302	else if (fsym && fsym->ts.type == BT_CLASS
6303	&& e->ts.type == BT_DERIVED)
6304	{
6305	/* The derived type needs to be converted to a temporary
6306	CLASS object. */
6307	gfc_init_se (se: &parmse, parent: se);
6308	gfc_conv_derived_to_class (parmse: &parmse, e, class_ts: fsym->ts, NULL,
6309	optional: fsym->attr.optional
6310	&& e->expr_type == EXPR_VARIABLE
6311	&& e->symtree->n.sym->attr.optional,
6312	CLASS_DATA (fsym)->attr.class_pointer
6313	|| CLASS_DATA (fsym)->attr.allocatable,
6314	derived_array: &derived_array);
6315	}
6316	else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
6317	&& e->ts.type != BT_PROCEDURE
6318	&& (gfc_expr_attr (e).flavor != FL_PROCEDURE
6319	|| gfc_expr_attr (e).proc != PROC_UNKNOWN))
6320	{
6321	/* The intrinsic type needs to be converted to a temporary
6322	CLASS object for the unlimited polymorphic formal. */
6323	gfc_find_vtab (&e->ts);
6324	gfc_init_se (se: &parmse, parent: se);
6325	gfc_conv_intrinsic_to_class (parmse: &parmse, e, class_ts: fsym->ts);
6326
6327	}
6328	else if (se->ss && se->ss->info->useflags)
6329	{
6330	gfc_ss *ss;
6331
6332	ss = se->ss;
6333
6334	/* An elemental function inside a scalarized loop. */
6335	gfc_init_se (se: &parmse, parent: se);
6336	parm_kind = ELEMENTAL;
6337
6338	/* When no fsym is present, ulim_copy is set and this is a third or
6339	fourth argument, use call-by-value instead of by reference to
6340	hand the length properties to the copy routine (i.e., most of the
6341	time this will be a call to a __copy_character_* routine where the
6342	third and fourth arguments are the lengths of a deferred length
6343	char array). */
6344	if ((fsym && fsym->attr.value)
6345	|| (ulim_copy && (argc == 2 || argc == 3)))
6346	gfc_conv_expr (se: &parmse, expr: e);
6347	else
6348	gfc_conv_expr_reference (se: &parmse, expr: e);
6349
6350	if (e->ts.type == BT_CHARACTER && !e->rank
6351	&& e->expr_type == EXPR_FUNCTION)
6352	parmse.expr = build_fold_indirect_ref_loc (input_location,
6353	parmse.expr);
6354
6355	if (fsym && fsym->ts.type == BT_DERIVED
6356	&& gfc_is_class_container_ref (e))
6357	{
6358	parmse.expr = gfc_class_data_get (decl: parmse.expr);
6359
6360	if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
6361	&& e->symtree->n.sym->attr.optional)
6362	{
6363	tree cond = gfc_conv_expr_present (sym: e->symtree->n.sym);
6364	parmse.expr = build3_loc (loc: input_location, code: COND_EXPR,
6365	TREE_TYPE (parmse.expr),
6366	arg0: cond, arg1: parmse.expr,
6367	fold_convert (TREE_TYPE (parmse.expr),
6368	null_pointer_node));
6369	}
6370	}
6371
6372	/* If we are passing an absent array as optional dummy to an
6373	elemental procedure, make sure that we pass NULL when the data
6374	pointer is NULL. We need this extra conditional because of
6375	scalarization which passes arrays elements to the procedure,
6376	ignoring the fact that the array can be absent/unallocated/... */
6377	if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
6378	{
6379	tree descriptor_data;
6380
6381	descriptor_data = ss->info->data.array.data;
6382	tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
6383	descriptor_data,
6384	fold_convert (TREE_TYPE (descriptor_data),
6385	null_pointer_node));
6386	parmse.expr
6387	= fold_build3_loc (input_location, COND_EXPR,
6388	TREE_TYPE (parmse.expr),
6389	gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
6390	fold_convert (TREE_TYPE (parmse.expr),
6391	null_pointer_node),
6392	parmse.expr);
6393	}
6394
6395	/* The scalarizer does not repackage the reference to a class
6396	array - instead it returns a pointer to the data element. */
6397	if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
6398	gfc_conv_class_to_class (parmse: &parmse, e, class_ts: fsym->ts, elemental: true,
6399	copyback: fsym->attr.intent != INTENT_IN
6400	&& (CLASS_DATA (fsym)->attr.class_pointer
6401	|| CLASS_DATA (fsym)->attr.allocatable),
6402	optional: fsym->attr.optional
6403	&& e->expr_type == EXPR_VARIABLE
6404	&& e->symtree->n.sym->attr.optional,
6405	CLASS_DATA (fsym)->attr.class_pointer
6406	|| CLASS_DATA (fsym)->attr.allocatable);
6407	}
6408	else
6409	{
6410	bool scalar;
6411	gfc_ss *argss;
6412
6413	gfc_init_se (se: &parmse, NULL);
6414
6415	/* Check whether the expression is a scalar or not; we cannot use
6416	e->rank as it can be nonzero for functions arguments. */
6417	argss = gfc_walk_expr (e);
6418	scalar = argss == gfc_ss_terminator;
6419	if (!scalar)
6420	gfc_free_ss_chain (argss);
6421
6422	/* Special handling for passing scalar polymorphic coarrays;
6423	otherwise one passes "class->_data.data" instead of "&class". */
6424	if (e->rank == 0 && e->ts.type == BT_CLASS
6425	&& fsym && fsym->ts.type == BT_CLASS
6426	&& CLASS_DATA (fsym)->attr.codimension
6427	&& !CLASS_DATA (fsym)->attr.dimension)
6428	{
6429	gfc_add_class_array_ref (e);
6430	parmse.want_coarray = 1;
6431	scalar = false;
6432	}
6433
6434	/* A scalar or transformational function. */
6435	if (scalar)
6436	{
6437	if (e->expr_type == EXPR_VARIABLE
6438	&& e->symtree->n.sym->attr.cray_pointee
6439	&& fsym && fsym->attr.flavor == FL_PROCEDURE)
6440	{
6441	/* The Cray pointer needs to be converted to a pointer to
6442	a type given by the expression. */
6443	gfc_conv_expr (se: &parmse, expr: e);
6444	type = build_pointer_type (TREE_TYPE (parmse.expr));
6445	tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
6446	parmse.expr = convert (type, tmp);
6447	}
6448
6449	else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
6450	/* Implement F2018, 18.3.6, list item (5), bullet point 2. */
6451	gfc_conv_gfc_desc_to_cfi_desc (parmse: &parmse, e, fsym);
6452
6453	else if (fsym && fsym->attr.value)
6454	{
6455	if (fsym->ts.type == BT_CHARACTER
6456	&& fsym->ts.is_c_interop
6457	&& fsym->ns->proc_name != NULL
6458	&& fsym->ns->proc_name->attr.is_bind_c)
6459	{
6460	parmse.expr = NULL;
6461	conv_scalar_char_value (sym: fsym, se: &parmse, expr: &e);
6462	if (parmse.expr == NULL)
6463	gfc_conv_expr (se: &parmse, expr: e);
6464	}
6465	else
6466	{
6467	gfc_conv_expr (se: &parmse, expr: e);
6468
6469	/* ABI: actual arguments to CHARACTER(len=1),VALUE
6470	dummy arguments are actually passed by value.
6471	Strings are truncated to length 1. */
6472	if (gfc_length_one_character_type_p (ts: &fsym->ts))
6473	{
6474	if (e->expr_type == EXPR_CONSTANT
6475	&& e->value.character.length > 1)
6476	{
6477	e->value.character.length = 1;
6478	gfc_conv_expr (se: &parmse, expr: e);
6479	}
6480
6481	tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6482	gfc_conv_string_parameter (se: &parmse);
6483	parmse.expr
6484	= gfc_string_to_single_character (len: slen1,
6485	str: parmse.expr,
6486	kind: e->ts.kind);
6487	/* Truncate resulting string to length 1. */
6488	parmse.string_length = slen1;
6489	}
6490
6491	if (fsym->attr.optional
6492	&& fsym->ts.type != BT_CLASS
6493	&& fsym->ts.type != BT_DERIVED)
6494	{
6495	/* F2018:15.5.2.12 Argument presence and
6496	restrictions on arguments not present. */
6497	if (e->expr_type == EXPR_VARIABLE
6498	&& (gfc_expr_attr (e).allocatable
6499	|| gfc_expr_attr (e).pointer))
6500	{
6501	gfc_se argse;
6502	tree cond;
6503	gfc_init_se (se: &argse, NULL);
6504	argse.want_pointer = 1;
6505	gfc_conv_expr (se: &argse, expr: e);
6506	cond = fold_convert (TREE_TYPE (argse.expr),
6507	null_pointer_node);
6508	cond = fold_build2_loc (input_location, NE_EXPR,
6509	logical_type_node,
6510	argse.expr, cond);
6511	vec_safe_push (v&: optionalargs,
6512	fold_convert (boolean_type_node,
6513	cond));
6514	/* Create "conditional temporary". */
6515	conv_cond_temp (parmse: &parmse, e, cond);
6516	}
6517	else if (e->expr_type != EXPR_VARIABLE
6518	|| !e->symtree->n.sym->attr.optional
6519	|| e->ref != NULL)
6520	vec_safe_push (v&: optionalargs, boolean_true_node);
6521	else
6522	{
6523	tmp = gfc_conv_expr_present (sym: e->symtree->n.sym);
6524	if (!e->symtree->n.sym->attr.value)
6525	parmse.expr
6526	= fold_build3_loc (input_location, COND_EXPR,
6527	TREE_TYPE (parmse.expr),
6528	tmp, parmse.expr,
6529	fold_convert (TREE_TYPE (parmse.expr),
6530	integer_zero_node));
6531
6532	vec_safe_push (v&: optionalargs,
6533	fold_convert (boolean_type_node,
6534	tmp));
6535	}
6536	}
6537	}
6538	}
6539
6540	else if (arg->name && arg->name[0] == '%')
6541	/* Argument list functions %VAL, %LOC and %REF are signalled
6542	through arg->name. */
6543	conv_arglist_function (se: &parmse, expr: arg->expr, name: arg->name);
6544	else if ((e->expr_type == EXPR_FUNCTION)
6545	&& ((e->value.function.esym
6546	&& e->value.function.esym->result->attr.pointer)
6547	|| (!e->value.function.esym
6548	&& e->symtree->n.sym->attr.pointer))
6549	&& fsym && fsym->attr.target)
6550	/* Make sure the function only gets called once. */
6551	gfc_conv_expr_reference (se: &parmse, expr: e);
6552	else if (e->expr_type == EXPR_FUNCTION
6553	&& e->symtree->n.sym->result
6554	&& e->symtree->n.sym->result != e->symtree->n.sym
6555	&& e->symtree->n.sym->result->attr.proc_pointer)
6556	{
6557	/* Functions returning procedure pointers. */
6558	gfc_conv_expr (se: &parmse, expr: e);
6559	if (fsym && fsym->attr.proc_pointer)
6560	parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
6561	}
6562
6563	else
6564	{
6565	bool defer_to_dealloc_blk = false;
6566	if (e->ts.type == BT_CLASS && fsym
6567	&& fsym->ts.type == BT_CLASS
6568	&& (!CLASS_DATA (fsym)->as
6569	|| CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
6570	&& CLASS_DATA (e)->attr.codimension)
6571	{
6572	gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
6573	gcc_assert (!CLASS_DATA (fsym)->as);
6574	gfc_add_class_array_ref (e);
6575	parmse.want_coarray = 1;
6576	gfc_conv_expr_reference (se: &parmse, expr: e);
6577	class_scalar_coarray_to_class (parmse: &parmse, e, class_ts: fsym->ts,
6578	optional: fsym->attr.optional
6579	&& e->expr_type == EXPR_VARIABLE);
6580	}
6581	else if (e->ts.type == BT_CLASS && fsym
6582	&& fsym->ts.type == BT_CLASS
6583	&& !CLASS_DATA (fsym)->as
6584	&& !CLASS_DATA (e)->as
6585	&& strcmp (s1: fsym->ts.u.derived->name,
6586	s2: e->ts.u.derived->name))
6587	{
6588	type = gfc_typenode_for_spec (&fsym->ts);
6589	var = gfc_create_var (type, fsym->name);
6590	gfc_conv_expr (se: &parmse, expr: e);
6591	if (fsym->attr.optional
6592	&& e->expr_type == EXPR_VARIABLE
6593	&& e->symtree->n.sym->attr.optional)
6594	{
6595	stmtblock_t block;
6596	tree cond;
6597	tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
6598	cond = fold_build2_loc (input_location, NE_EXPR,
6599	logical_type_node, tmp,
6600	fold_convert (TREE_TYPE (tmp),
6601	null_pointer_node));
6602	gfc_start_block (&block);
6603	gfc_add_modify (&block, var,
6604	fold_build1_loc (input_location,
6605	VIEW_CONVERT_EXPR,
6606	type, parmse.expr));
6607	gfc_add_expr_to_block (&parmse.pre,
6608	fold_build3_loc (input_location,
6609	COND_EXPR, void_type_node,
6610	cond, gfc_finish_block (&block),
6611	build_empty_stmt (input_location)));
6612	parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
6613	parmse.expr = build3_loc (loc: input_location, code: COND_EXPR,
6614	TREE_TYPE (parmse.expr),
6615	arg0: cond, arg1: parmse.expr,
6616	fold_convert (TREE_TYPE (parmse.expr),
6617	null_pointer_node));
6618	}
6619	else
6620	{
6621	/* Since the internal representation of unlimited
6622	polymorphic expressions includes an extra field
6623	that other class objects do not, a cast to the
6624	formal type does not work. */
6625	if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
6626	{
6627	tree efield;
6628
6629	/* Set the _data field. */
6630	tmp = gfc_class_data_get (decl: var);
6631	efield = fold_convert (TREE_TYPE (tmp),
6632	gfc_class_data_get (parmse.expr));
6633	gfc_add_modify (&parmse.pre, tmp, efield);
6634
6635	/* Set the _vptr field. */
6636	tmp = gfc_class_vptr_get (decl: var);
6637	efield = fold_convert (TREE_TYPE (tmp),
6638	gfc_class_vptr_get (parmse.expr));
6639	gfc_add_modify (&parmse.pre, tmp, efield);
6640
6641	/* Set the _len field. */
6642	tmp = gfc_class_len_get (decl: var);
6643	gfc_add_modify (&parmse.pre, tmp,
6644	build_int_cst (TREE_TYPE (tmp), 0));
6645	}
6646	else
6647	{
6648	tmp = fold_build1_loc (input_location,
6649	VIEW_CONVERT_EXPR,
6650	type, parmse.expr);
6651	gfc_add_modify (&parmse.pre, var, tmp);
6652	;
6653	}
6654	parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
6655	}
6656	}
6657	else
6658	{
6659	gfc_conv_expr_reference (se: &parmse, expr: e);
6660
6661	gfc_symbol *dsym = fsym;
6662	gfc_dummy_arg *dummy;
6663
6664	/* Use associated dummy as fallback for formal
6665	argument if there is no explicit interface. */
6666	if (dsym == NULL
6667	&& (dummy = arg->associated_dummy)
6668	&& dummy->intrinsicness == GFC_NON_INTRINSIC_DUMMY_ARG
6669	&& dummy->u.non_intrinsic->sym)
6670	dsym = dummy->u.non_intrinsic->sym;
6671
6672	if (dsym
6673	&& dsym->attr.intent == INTENT_OUT
6674	&& !dsym->attr.allocatable
6675	&& !dsym->attr.pointer
6676	&& e->expr_type == EXPR_VARIABLE
6677	&& e->ref == NULL
6678	&& e->symtree
6679	&& e->symtree->n.sym
6680	&& !e->symtree->n.sym->attr.dimension
6681	&& e->ts.type != BT_CHARACTER
6682	&& e->ts.type != BT_CLASS
6683	&& (e->ts.type != BT_DERIVED
6684	|| (dsym->ts.type == BT_DERIVED
6685	&& e->ts.u.derived == dsym->ts.u.derived
6686	/* Types with allocatable components are
6687	excluded from clobbering because we need
6688	the unclobbered pointers to free the
6689	allocatable components in the callee.
6690	Same goes for finalizable types or types
6691	with finalizable components, we need to
6692	pass the unclobbered values to the
6693	finalization routines.
6694	For parameterized types, it's less clear
6695	but they may not have a constant size
6696	so better exclude them in any case. */
6697	&& !e->ts.u.derived->attr.alloc_comp
6698	&& !e->ts.u.derived->attr.pdt_type
6699	&& !gfc_is_finalizable (e->ts.u.derived, NULL)))
6700	&& !sym->attr.elemental)
6701	{
6702	tree var;
6703	var = build_fold_indirect_ref_loc (input_location,
6704	parmse.expr);
6705	tree clobber = build_clobber (TREE_TYPE (var));
6706	gfc_add_modify (&clobbers, var, clobber);
6707	}
6708	}
6709	/* Catch base objects that are not variables. */
6710	if (e->ts.type == BT_CLASS
6711	&& e->expr_type != EXPR_VARIABLE
6712	&& expr && e == expr->base_expr)
6713	base_object = build_fold_indirect_ref_loc (input_location,
6714	parmse.expr);
6715
6716	/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6717	allocated on entry, it must be deallocated. */
6718	if (fsym && fsym->attr.intent == INTENT_OUT
6719	&& (fsym->attr.allocatable
6720	|| (fsym->ts.type == BT_CLASS
6721	&& CLASS_DATA (fsym)->attr.allocatable))
6722	&& !is_CFI_desc (fsym, NULL))
6723	{
6724	stmtblock_t block;
6725	tree ptr;
6726
6727	defer_to_dealloc_blk = true;
6728
6729	parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
6730	&parmse.pre);
6731
6732	if (parmse.class_container != NULL_TREE)
6733	parmse.class_container
6734	= gfc_evaluate_data_ref_now (parmse.class_container,
6735	&parmse.pre);
6736
6737	gfc_init_block (&block);
6738	ptr = parmse.expr;
6739	if (e->ts.type == BT_CLASS)
6740	ptr = gfc_class_data_get (decl: ptr);
6741
6742	tree cls = parmse.class_container;
6743	tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
6744	NULL_TREE, true,
6745	e, e->ts, cls);
6746	gfc_add_expr_to_block (&block, tmp);
6747	tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6748	void_type_node, ptr,
6749	null_pointer_node);
6750	gfc_add_expr_to_block (&block, tmp);
6751
6752	if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
6753	{
6754	gfc_add_modify (&block, ptr,
6755	fold_convert (TREE_TYPE (ptr),
6756	null_pointer_node));
6757	gfc_add_expr_to_block (&block, tmp);
6758	}
6759	else if (fsym->ts.type == BT_CLASS)
6760	{
6761	gfc_symbol *vtab;
6762	vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
6763	tmp = gfc_get_symbol_decl (vtab);
6764	tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6765	ptr = gfc_class_vptr_get (decl: parmse.expr);
6766	gfc_add_modify (&block, ptr,
6767	fold_convert (TREE_TYPE (ptr), tmp));
6768	gfc_add_expr_to_block (&block, tmp);
6769	}
6770
6771	if (fsym->attr.optional
6772	&& e->expr_type == EXPR_VARIABLE
6773	&& e->symtree->n.sym->attr.optional)
6774	{
6775	tmp = fold_build3_loc (input_location, COND_EXPR,
6776	void_type_node,
6777	gfc_conv_expr_present (sym: e->symtree->n.sym),
6778	gfc_finish_block (&block),
6779	build_empty_stmt (input_location));
6780	}
6781	else
6782	tmp = gfc_finish_block (&block);
6783
6784	gfc_add_expr_to_block (&dealloc_blk, tmp);
6785	}
6786
6787	/* A class array element needs converting back to be a
6788	class object, if the formal argument is a class object. */
6789	if (fsym && fsym->ts.type == BT_CLASS
6790	&& e->ts.type == BT_CLASS
6791	&& ((CLASS_DATA (fsym)->as
6792	&& CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
6793	|| CLASS_DATA (e)->attr.dimension))
6794	{
6795	gfc_se class_se = parmse;
6796	gfc_init_block (&class_se.pre);
6797	gfc_init_block (&class_se.post);
6798
6799	gfc_conv_class_to_class (parmse: &class_se, e, class_ts: fsym->ts, elemental: false,
6800	copyback: fsym->attr.intent != INTENT_IN
6801	&& (CLASS_DATA (fsym)->attr.class_pointer
6802	|| CLASS_DATA (fsym)->attr.allocatable),
6803	optional: fsym->attr.optional
6804	&& e->expr_type == EXPR_VARIABLE
6805	&& e->symtree->n.sym->attr.optional,
6806	CLASS_DATA (fsym)->attr.class_pointer
6807	|| CLASS_DATA (fsym)->attr.allocatable);
6808
6809	parmse.expr = class_se.expr;
6810	stmtblock_t *class_pre_block = defer_to_dealloc_blk
6811	? &dealloc_blk
6812	: &parmse.pre;
6813	gfc_add_block_to_block (class_pre_block, &class_se.pre);
6814	gfc_add_block_to_block (&parmse.post, &class_se.post);
6815	}
6816
6817	if (fsym && (fsym->ts.type == BT_DERIVED
6818	|| fsym->ts.type == BT_ASSUMED)
6819	&& e->ts.type == BT_CLASS
6820	&& !CLASS_DATA (e)->attr.dimension
6821	&& !CLASS_DATA (e)->attr.codimension)
6822	{
6823	parmse.expr = gfc_class_data_get (decl: parmse.expr);
6824	/* The result is a class temporary, whose _data component
6825	must be freed to avoid a memory leak. */
6826	if (e->expr_type == EXPR_FUNCTION
6827	&& CLASS_DATA (e)->attr.allocatable)
6828	{
6829	tree zero;
6830
6831	/* Finalize the expression. */
6832	gfc_finalize_tree_expr (&parmse, NULL,
6833	gfc_expr_attr (e), e->rank);
6834	gfc_add_block_to_block (&parmse.post,
6835	&parmse.finalblock);
6836
6837	/* Then free the class _data. */
6838	zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
6839	tmp = fold_build2_loc (input_location, NE_EXPR,
6840	logical_type_node,
6841	parmse.expr, zero);
6842	tmp = build3_v (COND_EXPR, tmp,
6843	gfc_call_free (parmse.expr),
6844	build_empty_stmt (input_location));
6845	gfc_add_expr_to_block (&parmse.post, tmp);
6846	gfc_add_modify (&parmse.post, parmse.expr, zero);
6847	}
6848	}
6849
6850	/* Wrap scalar variable in a descriptor. We need to convert
6851	the address of a pointer back to the pointer itself before,
6852	we can assign it to the data field. */
6853
6854	if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
6855	&& fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
6856	{
6857	tmp = parmse.expr;
6858	if (TREE_CODE (tmp) == ADDR_EXPR)
6859	tmp = TREE_OPERAND (tmp, 0);
6860	parmse.expr = gfc_conv_scalar_to_descriptor (se: &parmse, scalar: tmp,
6861	attr: fsym->attr);
6862	parmse.expr = gfc_build_addr_expr (NULL_TREE,
6863	parmse.expr);
6864	}
6865	else if (fsym && e->expr_type != EXPR_NULL
6866	&& ((fsym->attr.pointer
6867	&& fsym->attr.flavor != FL_PROCEDURE)
6868	|| (fsym->attr.proc_pointer
6869	&& !(e->expr_type == EXPR_VARIABLE
6870	&& e->symtree->n.sym->attr.dummy))
6871	|| (fsym->attr.proc_pointer
6872	&& e->expr_type == EXPR_VARIABLE
6873	&& gfc_is_proc_ptr_comp (e))
6874	|| (fsym->attr.allocatable
6875	&& fsym->attr.flavor != FL_PROCEDURE)))
6876	{
6877	/* Scalar pointer dummy args require an extra level of
6878	indirection. The null pointer already contains
6879	this level of indirection. */
6880	parm_kind = SCALAR_POINTER;
6881	parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
6882	}
6883	}
6884	}
6885	else if (e->ts.type == BT_CLASS
6886	&& fsym && fsym->ts.type == BT_CLASS
6887	&& (CLASS_DATA (fsym)->attr.dimension
6888	|| CLASS_DATA (fsym)->attr.codimension))
6889	{
6890	/* Pass a class array. */
6891	parmse.use_offset = 1;
6892	gfc_conv_expr_descriptor (&parmse, e);
6893	bool defer_to_dealloc_blk = false;
6894
6895	if (fsym->attr.optional
6896	&& e->expr_type == EXPR_VARIABLE
6897	&& e->symtree->n.sym->attr.optional)
6898	{
6899	stmtblock_t block;
6900
6901	gfc_init_block (&block);
6902	gfc_add_block_to_block (&block, &parmse.pre);
6903
6904	tree t = fold_build3_loc (input_location, COND_EXPR,
6905	void_type_node,
6906	gfc_conv_expr_present (sym: e->symtree->n.sym),
6907	gfc_finish_block (&block),
6908	build_empty_stmt (input_location));
6909
6910	gfc_add_expr_to_block (&parmse.pre, t);
6911	}
6912
6913	/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6914	allocated on entry, it must be deallocated. */
6915	if (fsym->attr.intent == INTENT_OUT
6916	&& CLASS_DATA (fsym)->attr.allocatable)
6917	{
6918	stmtblock_t block;
6919	tree ptr;
6920
6921	/* In case the data reference to deallocate is dependent on
6922	its own content, save the resulting pointer to a variable
6923	and only use that variable from now on, before the
6924	expression becomes invalid. */
6925	parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
6926	&parmse.pre);
6927
6928	if (parmse.class_container != NULL_TREE)
6929	parmse.class_container
6930	= gfc_evaluate_data_ref_now (parmse.class_container,
6931	&parmse.pre);
6932
6933	gfc_init_block (&block);
6934	ptr = parmse.expr;
6935	ptr = gfc_class_data_get (decl: ptr);
6936
6937	tree cls = parmse.class_container;
6938	tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
6939	NULL_TREE, NULL_TREE,
6940	NULL_TREE, true, e,
6941	GFC_CAF_COARRAY_NOCOARRAY,
6942	cls);
6943	gfc_add_expr_to_block (&block, tmp);
6944	tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6945	void_type_node, ptr,
6946	null_pointer_node);
6947	gfc_add_expr_to_block (&block, tmp);
6948	gfc_reset_vptr (block: &block, e, class_container: parmse.class_container);
6949
6950	if (fsym->attr.optional
6951	&& e->expr_type == EXPR_VARIABLE
6952	&& (!e->ref
6953	|| (e->ref->type == REF_ARRAY
6954	&& e->ref->u.ar.type != AR_FULL))
6955	&& e->symtree->n.sym->attr.optional)
6956	{
6957	tmp = fold_build3_loc (input_location, COND_EXPR,
6958	void_type_node,
6959	gfc_conv_expr_present (sym: e->symtree->n.sym),
6960	gfc_finish_block (&block),
6961	build_empty_stmt (input_location));
6962	}
6963	else
6964	tmp = gfc_finish_block (&block);
6965
6966	gfc_add_expr_to_block (&dealloc_blk, tmp);
6967	defer_to_dealloc_blk = true;
6968	}
6969
6970	gfc_se class_se = parmse;
6971	gfc_init_block (&class_se.pre);
6972	gfc_init_block (&class_se.post);
6973
6974	/* The conversion does not repackage the reference to a class
6975	array - _data descriptor. */
6976	gfc_conv_class_to_class (parmse: &class_se, e, class_ts: fsym->ts, elemental: false,
6977	copyback: fsym->attr.intent != INTENT_IN
6978	&& (CLASS_DATA (fsym)->attr.class_pointer
6979	|| CLASS_DATA (fsym)->attr.allocatable),
6980	optional: fsym->attr.optional
6981	&& e->expr_type == EXPR_VARIABLE
6982	&& e->symtree->n.sym->attr.optional,
6983	CLASS_DATA (fsym)->attr.class_pointer
6984	|| CLASS_DATA (fsym)->attr.allocatable);
6985
6986	parmse.expr = class_se.expr;
6987	stmtblock_t *class_pre_block = defer_to_dealloc_blk
6988	? &dealloc_blk
6989	: &parmse.pre;
6990	gfc_add_block_to_block (class_pre_block, &class_se.pre);
6991	gfc_add_block_to_block (&parmse.post, &class_se.post);
6992	}
6993	else
6994	{
6995	/* If the argument is a function call that may not create
6996	a temporary for the result, we have to check that we
6997	can do it, i.e. that there is no alias between this
6998	argument and another one. */
6999	if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
7000	{
7001	gfc_expr *iarg;
7002	sym_intent intent;
7003
7004	if (fsym != NULL)
7005	intent = fsym->attr.intent;
7006	else
7007	intent = INTENT_UNKNOWN;
7008
7009	if (gfc_check_fncall_dependency (e, intent, sym, args,
7010	NOT_ELEMENTAL))
7011	parmse.force_tmp = 1;
7012
7013	iarg = e->value.function.actual->expr;
7014
7015	/* Temporary needed if aliasing due to host association. */
7016	if (sym->attr.contained
7017	&& !sym->attr.pure
7018	&& !sym->attr.implicit_pure
7019	&& !sym->attr.use_assoc
7020	&& iarg->expr_type == EXPR_VARIABLE
7021	&& sym->ns == iarg->symtree->n.sym->ns)
7022	parmse.force_tmp = 1;
7023
7024	/* Ditto within module. */
7025	if (sym->attr.use_assoc
7026	&& !sym->attr.pure
7027	&& !sym->attr.implicit_pure
7028	&& iarg->expr_type == EXPR_VARIABLE
7029	&& sym->module == iarg->symtree->n.sym->module)
7030	parmse.force_tmp = 1;
7031	}
7032
7033	/* Special case for assumed-rank arrays: when passing an
7034	argument to a nonallocatable/nonpointer dummy, the bounds have
7035	to be reset as otherwise a last-dim ubound of -1 is
7036	indistinguishable from an assumed-size array in the callee. */
7037	if (!sym->attr.is_bind_c && e && fsym && fsym->as
7038	&& fsym->as->type == AS_ASSUMED_RANK
7039	&& e->rank != -1
7040	&& e->expr_type == EXPR_VARIABLE
7041	&& ((fsym->ts.type == BT_CLASS
7042	&& !CLASS_DATA (fsym)->attr.class_pointer
7043	&& !CLASS_DATA (fsym)->attr.allocatable)
7044	|| (fsym->ts.type != BT_CLASS
7045	&& !fsym->attr.pointer && !fsym->attr.allocatable)))
7046	{
7047	/* Change AR_FULL to a (:,:,:) ref to force bounds update. */
7048	gfc_ref *ref;
7049	for (ref = e->ref; ref->next; ref = ref->next)
7050	;
7051	if (ref->u.ar.type == AR_FULL
7052	&& ref->u.ar.as->type != AS_ASSUMED_SIZE)
7053	ref->u.ar.type = AR_SECTION;
7054	}
7055
7056	if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
7057	/* Implement F2018, 18.3.6, list item (5), bullet point 2. */
7058	gfc_conv_gfc_desc_to_cfi_desc (parmse: &parmse, e, fsym);
7059
7060	else if (e->expr_type == EXPR_VARIABLE
7061	&& is_subref_array (e)
7062	&& !(fsym && fsym->attr.pointer))
7063	/* The actual argument is a component reference to an
7064	array of derived types. In this case, the argument
7065	is converted to a temporary, which is passed and then
7066	written back after the procedure call. */
7067	gfc_conv_subref_array_arg (se: &parmse, expr: e, g77: nodesc_arg,
7068	intent: fsym ? fsym->attr.intent : INTENT_INOUT,
7069	formal_ptr: fsym && fsym->attr.pointer);
7070
7071	else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
7072	&& CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
7073	&& nodesc_arg && fsym->ts.type == BT_DERIVED)
7074	/* An assumed size class actual argument being passed to
7075	a 'no descriptor' formal argument just requires the
7076	data pointer to be passed. For class dummy arguments
7077	this is stored in the symbol backend decl.. */
7078	parmse.expr = e->symtree->n.sym->backend_decl;
7079
7080	else if (gfc_is_class_array_ref (e, NULL)
7081	&& fsym && fsym->ts.type == BT_DERIVED)
7082	/* The actual argument is a component reference to an
7083	array of derived types. In this case, the argument
7084	is converted to a temporary, which is passed and then
7085	written back after the procedure call.
7086	OOP-TODO: Insert code so that if the dynamic type is
7087	the same as the declared type, copy-in/copy-out does
7088	not occur. */
7089	gfc_conv_subref_array_arg (se: &parmse, expr: e, g77: nodesc_arg,
7090	intent: fsym->attr.intent,
7091	formal_ptr: fsym->attr.pointer);
7092
7093	else if (gfc_is_class_array_function (e)
7094	&& fsym && fsym->ts.type == BT_DERIVED)
7095	/* See previous comment. For function actual argument,
7096	the write out is not needed so the intent is set as
7097	intent in. */
7098	{
7099	e->must_finalize = 1;
7100	gfc_conv_subref_array_arg (se: &parmse, expr: e, g77: nodesc_arg,
7101	intent: INTENT_IN, formal_ptr: fsym->attr.pointer);
7102	}
7103	else if (fsym && fsym->attr.contiguous
7104	&& !gfc_is_simply_contiguous (e, false, true)
7105	&& gfc_expr_is_variable (e))
7106	{
7107	gfc_conv_subref_array_arg (se: &parmse, expr: e, g77: nodesc_arg,
7108	intent: fsym->attr.intent,
7109	formal_ptr: fsym->attr.pointer);
7110	}
7111	else
7112	/* This is where we introduce a temporary to store the
7113	result of a non-lvalue array expression. */
7114	gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
7115	sym->name, NULL);
7116
7117	/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7118	allocated on entry, it must be deallocated.
7119	CFI descriptors are handled elsewhere. */
7120	if (fsym && fsym->attr.allocatable
7121	&& fsym->attr.intent == INTENT_OUT
7122	&& !is_CFI_desc (fsym, NULL))
7123	{
7124	if (fsym->ts.type == BT_DERIVED
7125	&& fsym->ts.u.derived->attr.alloc_comp)
7126	{
7127	// deallocate the components first
7128	tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
7129	parmse.expr, e->rank);
7130	/* But check whether dummy argument is optional. */
7131	if (tmp != NULL_TREE
7132	&& fsym->attr.optional
7133	&& e->expr_type == EXPR_VARIABLE
7134	&& e->symtree->n.sym->attr.optional)
7135	{
7136	tree present;
7137	present = gfc_conv_expr_present (sym: e->symtree->n.sym);
7138	tmp = build3_v (COND_EXPR, present, tmp,
7139	build_empty_stmt (input_location));
7140	}
7141	if (tmp != NULL_TREE)
7142	gfc_add_expr_to_block (&dealloc_blk, tmp);
7143	}
7144
7145	tmp = parmse.expr;
7146	/* With bind(C), the actual argument is replaced by a bind-C
7147	descriptor; in this case, the data component arrives here,
7148	which shall not be dereferenced, but still freed and
7149	nullified. */
7150	if (TREE_TYPE(tmp) != pvoid_type_node)
7151	tmp = build_fold_indirect_ref_loc (input_location,
7152	parmse.expr);
7153	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
7154	tmp = gfc_conv_descriptor_data_get (tmp);
7155	tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
7156	NULL_TREE, NULL_TREE, true,
7157	e,
7158	GFC_CAF_COARRAY_NOCOARRAY);
7159	if (fsym->attr.optional
7160	&& e->expr_type == EXPR_VARIABLE
7161	&& e->symtree->n.sym->attr.optional)
7162	tmp = fold_build3_loc (input_location, COND_EXPR,
7163	void_type_node,
7164	gfc_conv_expr_present (sym: e->symtree->n.sym),
7165	tmp, build_empty_stmt (input_location));
7166	gfc_add_expr_to_block (&dealloc_blk, tmp);
7167	}
7168	}
7169	}
7170	/* Special case for an assumed-rank dummy argument. */
7171	if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
7172	&& (fsym->ts.type == BT_CLASS
7173	? (CLASS_DATA (fsym)->as
7174	&& CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
7175	: (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
7176	{
7177	if (fsym->ts.type == BT_CLASS
7178	? (CLASS_DATA (fsym)->attr.class_pointer
7179	|| CLASS_DATA (fsym)->attr.allocatable)
7180	: (fsym->attr.pointer || fsym->attr.allocatable))
7181	{
7182	/* Unallocated allocatable arrays and unassociated pointer
7183	arrays need their dtype setting if they are argument
7184	associated with assumed rank dummies to set the rank. */
7185	set_dtype_for_unallocated (parmse: &parmse, e);
7186	}
7187	else if (e->expr_type == EXPR_VARIABLE
7188	&& e->symtree->n.sym->attr.dummy
7189	&& (e->ts.type == BT_CLASS
7190	? (e->ref && e->ref->next
7191	&& e->ref->next->type == REF_ARRAY
7192	&& e->ref->next->u.ar.type == AR_FULL
7193	&& e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
7194	: (e->ref && e->ref->type == REF_ARRAY
7195	&& e->ref->u.ar.type == AR_FULL
7196	&& e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
7197	{
7198	/* Assumed-size actual to assumed-rank dummy requires
7199	dim[rank-1].ubound = -1. */
7200	tree minus_one;
7201	tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
7202	if (fsym->ts.type == BT_CLASS)
7203	tmp = gfc_class_data_get (decl: tmp);
7204	minus_one = build_int_cst (gfc_array_index_type, -1);
7205	gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
7206	gfc_rank_cst[e->rank - 1],
7207	minus_one);
7208	}
7209	}
7210
7211	/* The case with fsym->attr.optional is that of a user subroutine
7212	with an interface indicating an optional argument. When we call
7213	an intrinsic subroutine, however, fsym is NULL, but we might still
7214	have an optional argument, so we proceed to the substitution
7215	just in case. */
7216	if (e && (fsym == NULL || fsym->attr.optional))
7217	{
7218	/* If an optional argument is itself an optional dummy argument,
7219	check its presence and substitute a null if absent. This is
7220	only needed when passing an array to an elemental procedure
7221	as then array elements are accessed - or no NULL pointer is
7222	allowed and a "1" or "0" should be passed if not present.
7223	When passing a non-array-descriptor full array to a
7224	non-array-descriptor dummy, no check is needed. For
7225	array-descriptor actual to array-descriptor dummy, see
7226	PR 41911 for why a check has to be inserted.
7227	fsym == NULL is checked as intrinsics required the descriptor
7228	but do not always set fsym.
7229	Also, it is necessary to pass a NULL pointer to library routines
7230	which usually ignore optional arguments, so they can handle
7231	these themselves. */
7232	if (e->expr_type == EXPR_VARIABLE
7233	&& e->symtree->n.sym->attr.optional
7234	&& (((e->rank != 0 && elemental_proc)
7235	|| e->representation.length || e->ts.type == BT_CHARACTER
7236	|| (e->rank != 0
7237	&& (fsym == NULL
7238	|| (fsym->as
7239	&& (fsym->as->type == AS_ASSUMED_SHAPE
7240	|| fsym->as->type == AS_ASSUMED_RANK
7241	|| fsym->as->type == AS_DEFERRED)))))
7242	|| se->ignore_optional))
7243	gfc_conv_missing_dummy (se: &parmse, arg: e, ts: fsym ? fsym->ts : e->ts,
7244	kind: e->representation.length);
7245	}
7246
7247	if (fsym && e)
7248	{
7249	/* Obtain the character length of an assumed character length
7250	length procedure from the typespec. */
7251	if (fsym->ts.type == BT_CHARACTER
7252	&& parmse.string_length == NULL_TREE
7253	&& e->ts.type == BT_PROCEDURE
7254	&& e->symtree->n.sym->ts.type == BT_CHARACTER
7255	&& e->symtree->n.sym->ts.u.cl->length != NULL
7256	&& e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7257	{
7258	gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
7259	parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
7260	}
7261	}
7262
7263	/* If any actual argument of the procedure is allocatable and passed
7264	to an allocatable dummy with INTENT(OUT), we conservatively
7265	evaluate actual argument expressions before deallocations are
7266	performed and the procedure is executed. May create temporaries.
7267	This ensures we conform to F2023:15.5.3, 15.5.4. */
7268	if (e && fsym && force_eval_args
7269	&& fsym->attr.intent != INTENT_OUT
7270	&& !gfc_is_constant_expr (e))
7271	parmse.expr = gfc_evaluate_now (parmse.expr, &parmse.pre);
7272
7273	if (fsym && need_interface_mapping && e)
7274	gfc_add_interface_mapping (mapping: &mapping, sym: fsym, se: &parmse, expr: e);
7275
7276	gfc_add_block_to_block (&se->pre, &parmse.pre);
7277	gfc_add_block_to_block (&post, &parmse.post);
7278	gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
7279
7280	/* Allocated allocatable components of derived types must be
7281	deallocated for non-variable scalars, array arguments to elemental
7282	procedures, and array arguments with descriptor to non-elemental
7283	procedures. As bounds information for descriptorless arrays is no
7284	longer available here, they are dealt with in trans-array.cc
7285	(gfc_conv_array_parameter). */
7286	if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
7287	&& e->ts.u.derived->attr.alloc_comp
7288	&& (e->rank == 0 || elemental_proc || !nodesc_arg)
7289	&& !expr_may_alias_variables (e, array_may_alias: elemental_proc))
7290	{
7291	int parm_rank;
7292	/* It is known the e returns a structure type with at least one
7293	allocatable component. When e is a function, ensure that the
7294	function is called once only by using a temporary variable. */
7295	if (!DECL_P (parmse.expr))
7296	parmse.expr = gfc_evaluate_now_loc (input_location,
7297	parmse.expr, &se->pre);
7298
7299	if (fsym && fsym->attr.value)
7300	tmp = parmse.expr;
7301	else
7302	tmp = build_fold_indirect_ref_loc (input_location,
7303	parmse.expr);
7304
7305	parm_rank = e->rank;
7306	switch (parm_kind)
7307	{
7308	case (ELEMENTAL):
7309	case (SCALAR):
7310	parm_rank = 0;
7311	break;
7312
7313	case (SCALAR_POINTER):
7314	tmp = build_fold_indirect_ref_loc (input_location,
7315	tmp);
7316	break;
7317	}
7318
7319	if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
7320	{
7321	/* The derived type is passed to gfc_deallocate_alloc_comp.
7322	Therefore, class actuals can be handled correctly but derived
7323	types passed to class formals need the _data component. */
7324	tmp = gfc_class_data_get (decl: tmp);
7325	if (!CLASS_DATA (fsym)->attr.dimension)
7326	{
7327	if (UNLIMITED_POLY (fsym))
7328	{
7329	tree type = gfc_typenode_for_spec (&e->ts);
7330	type = build_pointer_type (type);
7331	tmp = fold_convert (type, tmp);
7332	}
7333	tmp = build_fold_indirect_ref_loc (input_location, tmp);
7334	}
7335	}
7336
7337	if (e->expr_type == EXPR_OP
7338	&& e->value.op.op == INTRINSIC_PARENTHESES
7339	&& e->value.op.op1->expr_type == EXPR_VARIABLE)
7340	{
7341	tree local_tmp;
7342	local_tmp = gfc_evaluate_now (tmp, &se->pre);
7343	local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
7344	parm_rank, 0);
7345	gfc_add_expr_to_block (&se->post, local_tmp);
7346	}
7347
7348	if (!finalized && !e->must_finalize)
7349	{
7350	bool scalar_res_outside_loop;
7351	scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION
7352	&& parm_rank == 0
7353	&& parmse.loop;
7354
7355	/* Scalars passed to an assumed rank argument are converted to
7356	a descriptor. Obtain the data field before deallocating any
7357	allocatable components. */
7358	if (parm_rank == 0 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
7359	tmp = gfc_conv_descriptor_data_get (tmp);
7360
7361	if (scalar_res_outside_loop)
7362	{
7363	/* Go through the ss chain to find the argument and use
7364	the stored value. */
7365	gfc_ss *tmp_ss = parmse.loop->ss;
7366	for (; tmp_ss; tmp_ss = tmp_ss->next)
7367	if (tmp_ss->info
7368	&& tmp_ss->info->expr == e
7369	&& tmp_ss->info->data.scalar.value != NULL_TREE)
7370	{
7371	tmp = tmp_ss->info->data.scalar.value;
7372	break;
7373	}
7374	}
7375
7376	STRIP_NOPS (tmp);
7377
7378	if (derived_array != NULL_TREE)
7379	tmp = gfc_deallocate_alloc_comp (e->ts.u.derived,
7380	derived_array,
7381	parm_rank);
7382	else if ((e->ts.type == BT_CLASS
7383	&& GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
7384	|| e->ts.type == BT_DERIVED)
7385	tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
7386	parm_rank);
7387	else if (e->ts.type == BT_CLASS)
7388	tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
7389	tmp, parm_rank);
7390
7391	if (scalar_res_outside_loop)
7392	gfc_add_expr_to_block (&parmse.loop->post, tmp);
7393	else
7394	gfc_prepend_expr_to_block (&post, tmp);
7395	}
7396	}
7397
7398	/* Add argument checking of passing an unallocated/NULL actual to
7399	a nonallocatable/nonpointer dummy. */
7400
7401	if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
7402	{
7403	symbol_attribute attr;
7404	char *msg;
7405	tree cond;
7406	tree tmp;
7407	symbol_attribute fsym_attr;
7408
7409	if (fsym)
7410	{
7411	if (fsym->ts.type == BT_CLASS)
7412	{
7413	fsym_attr = CLASS_DATA (fsym)->attr;
7414	fsym_attr.pointer = fsym_attr.class_pointer;
7415	}
7416	else
7417	fsym_attr = fsym->attr;
7418	}
7419
7420	if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
7421	attr = gfc_expr_attr (e);
7422	else
7423	goto end_pointer_check;
7424
7425	/* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
7426	allocatable to an optional dummy, cf. 12.5.2.12. */
7427	if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
7428	&& (gfc_option.allow_std & GFC_STD_F2008) != 0)
7429	goto end_pointer_check;
7430
7431	if (attr.optional)
7432	{
7433	/* If the actual argument is an optional pointer/allocatable and
7434	the formal argument takes an nonpointer optional value,
7435	it is invalid to pass a non-present argument on, even
7436	though there is no technical reason for this in gfortran.
7437	See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
7438	tree present, null_ptr, type;
7439
7440	if (attr.allocatable
7441	&& (fsym == NULL || !fsym_attr.allocatable))
7442	msg = xasprintf ("Allocatable actual argument '%s' is not "
7443	"allocated or not present",
7444	e->symtree->n.sym->name);
7445	else if (attr.pointer
7446	&& (fsym == NULL || !fsym_attr.pointer))
7447	msg = xasprintf ("Pointer actual argument '%s' is not "
7448	"associated or not present",
7449	e->symtree->n.sym->name);
7450	else if (attr.proc_pointer && !e->value.function.actual
7451	&& (fsym == NULL || !fsym_attr.proc_pointer))
7452	msg = xasprintf ("Proc-pointer actual argument '%s' is not "
7453	"associated or not present",
7454	e->symtree->n.sym->name);
7455	else
7456	goto end_pointer_check;
7457
7458	present = gfc_conv_expr_present (sym: e->symtree->n.sym);
7459	type = TREE_TYPE (present);
7460	present = fold_build2_loc (input_location, EQ_EXPR,
7461	logical_type_node, present,
7462	fold_convert (type,
7463	null_pointer_node));
7464	type = TREE_TYPE (parmse.expr);
7465	null_ptr = fold_build2_loc (input_location, EQ_EXPR,
7466	logical_type_node, parmse.expr,
7467	fold_convert (type,
7468	null_pointer_node));
7469	cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7470	logical_type_node, present, null_ptr);
7471	}
7472	else
7473	{
7474	if (attr.allocatable
7475	&& (fsym == NULL || !fsym_attr.allocatable))
7476	msg = xasprintf ("Allocatable actual argument '%s' is not "
7477	"allocated", e->symtree->n.sym->name);
7478	else if (attr.pointer
7479	&& (fsym == NULL || !fsym_attr.pointer))
7480	msg = xasprintf ("Pointer actual argument '%s' is not "
7481	"associated", e->symtree->n.sym->name);
7482	else if (attr.proc_pointer && !e->value.function.actual
7483	&& (fsym == NULL || !fsym_attr.proc_pointer))
7484	msg = xasprintf ("Proc-pointer actual argument '%s' is not "
7485	"associated", e->symtree->n.sym->name);
7486	else
7487	goto end_pointer_check;
7488
7489	tmp = parmse.expr;
7490	if (fsym && fsym->ts.type == BT_CLASS)
7491	{
7492	if (POINTER_TYPE_P (TREE_TYPE (tmp)))
7493	tmp = build_fold_indirect_ref_loc (input_location, tmp);
7494	tmp = gfc_class_data_get (decl: tmp);
7495	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
7496	tmp = gfc_conv_descriptor_data_get (tmp);
7497	}
7498
7499	/* If the argument is passed by value, we need to strip the
7500	INDIRECT_REF. */
7501	if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
7502	tmp = gfc_build_addr_expr (NULL_TREE, tmp);
7503
7504	cond = fold_build2_loc (input_location, EQ_EXPR,
7505	logical_type_node, tmp,
7506	fold_convert (TREE_TYPE (tmp),
7507	null_pointer_node));
7508	}
7509
7510	gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
7511	msg);
7512	free (ptr: msg);
7513	}
7514	end_pointer_check:
7515
7516	/* Deferred length dummies pass the character length by reference
7517	so that the value can be returned. */
7518	if (parmse.string_length && fsym && fsym->ts.deferred)
7519	{
7520	if (INDIRECT_REF_P (parmse.string_length))
7521	{
7522	/* In chains of functions/procedure calls the string_length already
7523	is a pointer to the variable holding the length. Therefore
7524	remove the deref on call. */
7525	tmp = parmse.string_length;
7526	parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
7527	}
7528	else
7529	{
7530	tmp = parmse.string_length;
7531	if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
7532	tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
7533	parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
7534	}
7535
7536	if (e && e->expr_type == EXPR_VARIABLE
7537	&& fsym->attr.allocatable
7538	&& e->ts.u.cl->backend_decl
7539	&& VAR_P (e->ts.u.cl->backend_decl))
7540	{
7541	if (INDIRECT_REF_P (tmp))
7542	tmp = TREE_OPERAND (tmp, 0);
7543	gfc_add_modify (&se->post, e->ts.u.cl->backend_decl,
7544	fold_convert (gfc_charlen_type_node, tmp));
7545	}
7546	}
7547
7548	/* Character strings are passed as two parameters, a length and a
7549	pointer - except for Bind(c) and c_ptrs which only passe the pointer.
7550	An unlimited polymorphic formal argument likewise does not
7551	need the length. */
7552	if (parmse.string_length != NULL_TREE
7553	&& !sym->attr.is_bind_c
7554	&& !(fsym && fsym->ts.type == BT_DERIVED && fsym->ts.u.derived
7555	&& fsym->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
7556	&& fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING )
7557	&& !(fsym && fsym->ts.type == BT_ASSUMED)
7558	&& !(fsym && UNLIMITED_POLY (fsym)))
7559	vec_safe_push (v&: stringargs, obj: parmse.string_length);
7560
7561	/* When calling __copy for character expressions to unlimited
7562	polymorphic entities, the dst argument needs a string length. */
7563	if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
7564	&& startswith (str: sym->name, prefix: "__vtab_CHARACTER")
7565	&& arg->next && arg->next->expr
7566	&& (arg->next->expr->ts.type == BT_DERIVED
7567	|| arg->next->expr->ts.type == BT_CLASS)
7568	&& arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
7569	vec_safe_push (v&: stringargs, obj: parmse.string_length);
7570
7571	/* For descriptorless coarrays and assumed-shape coarray dummies, we
7572	pass the token and the offset as additional arguments. */
7573	if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
7574	&& ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
7575	&& !fsym->attr.allocatable)
7576	|| (fsym->ts.type == BT_CLASS
7577	&& CLASS_DATA (fsym)->attr.codimension
7578	&& !CLASS_DATA (fsym)->attr.allocatable)))
7579	{
7580	/* Token and offset. */
7581	vec_safe_push (v&: stringargs, null_pointer_node);
7582	vec_safe_push (v&: stringargs, obj: build_int_cst (gfc_array_index_type, 0));
7583	gcc_assert (fsym->attr.optional);
7584	}
7585	else if (fsym && flag_coarray == GFC_FCOARRAY_LIB
7586	&& ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
7587	&& !fsym->attr.allocatable)
7588	|| (fsym->ts.type == BT_CLASS
7589	&& CLASS_DATA (fsym)->attr.codimension
7590	&& !CLASS_DATA (fsym)->attr.allocatable)))
7591	{
7592	tree caf_decl, caf_type;
7593	tree offset, tmp2;
7594
7595	caf_decl = gfc_get_tree_for_caf_expr (expr: e);
7596	caf_type = TREE_TYPE (caf_decl);
7597
7598	if (GFC_DESCRIPTOR_TYPE_P (caf_type)
7599	&& (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
7600	|| GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
7601	tmp = gfc_conv_descriptor_token (caf_decl);
7602	else if (DECL_LANG_SPECIFIC (caf_decl)
7603	&& GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
7604	tmp = GFC_DECL_TOKEN (caf_decl);
7605	else
7606	{
7607	gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
7608	&& GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
7609	tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
7610	}
7611
7612	vec_safe_push (v&: stringargs, obj: tmp);
7613
7614	if (GFC_DESCRIPTOR_TYPE_P (caf_type)
7615	&& GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
7616	offset = build_int_cst (gfc_array_index_type, 0);
7617	else if (DECL_LANG_SPECIFIC (caf_decl)
7618	&& GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
7619	offset = GFC_DECL_CAF_OFFSET (caf_decl);
7620	else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
7621	offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
7622	else
7623	offset = build_int_cst (gfc_array_index_type, 0);
7624
7625	if (GFC_DESCRIPTOR_TYPE_P (caf_type))
7626	tmp = gfc_conv_descriptor_data_get (caf_decl);
7627	else
7628	{
7629	gcc_assert (POINTER_TYPE_P (caf_type));
7630	tmp = caf_decl;
7631	}
7632
7633	tmp2 = fsym->ts.type == BT_CLASS
7634	? gfc_class_data_get (decl: parmse.expr) : parmse.expr;
7635	if ((fsym->ts.type != BT_CLASS
7636	&& (fsym->as->type == AS_ASSUMED_SHAPE
7637	|| fsym->as->type == AS_ASSUMED_RANK))
7638	|| (fsym->ts.type == BT_CLASS
7639	&& (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
7640	|| CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
7641	{
7642	if (fsym->ts.type == BT_CLASS)
7643	gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
7644	else
7645	{
7646	gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
7647	tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
7648	}
7649	gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
7650	tmp2 = gfc_conv_descriptor_data_get (tmp2);
7651	}
7652	else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
7653	tmp2 = gfc_conv_descriptor_data_get (tmp2);
7654	else
7655	{
7656	gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
7657	}
7658
7659	tmp = fold_build2_loc (input_location, MINUS_EXPR,
7660	gfc_array_index_type,
7661	fold_convert (gfc_array_index_type, tmp2),
7662	fold_convert (gfc_array_index_type, tmp));
7663	offset = fold_build2_loc (input_location, PLUS_EXPR,
7664	gfc_array_index_type, offset, tmp);
7665
7666	vec_safe_push (v&: stringargs, obj: offset);
7667	}
7668
7669	vec_safe_push (v&: arglist, obj: parmse.expr);
7670	}
7671
7672	gfc_add_block_to_block (&se->pre, &dealloc_blk);
7673	gfc_add_block_to_block (&se->pre, &clobbers);
7674	gfc_finish_interface_mapping (mapping: &mapping, pre: &se->pre, post: &se->post);
7675
7676	if (comp)
7677	ts = comp->ts;
7678	else if (sym->ts.type == BT_CLASS)
7679	ts = CLASS_DATA (sym)->ts;
7680	else
7681	ts = sym->ts;
7682
7683	if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
7684	se->string_length = build_int_cst (gfc_charlen_type_node, 1);
7685	else if (ts.type == BT_CHARACTER)
7686	{
7687	if (ts.u.cl->length == NULL)
7688	{
7689	/* Assumed character length results are not allowed by C418 of the 2003
7690	standard and are trapped in resolve.cc; except in the case of SPREAD
7691	(and other intrinsics?) and dummy functions. In the case of SPREAD,
7692	we take the character length of the first argument for the result.
7693	For dummies, we have to look through the formal argument list for
7694	this function and use the character length found there.
7695	Likewise, we handle the case of deferred-length character dummy
7696	arguments to intrinsics that determine the characteristics of
7697	the result, which cannot be deferred-length. */
7698	if (expr->value.function.isym)
7699	ts.deferred = false;
7700	if (ts.deferred)
7701	cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
7702	else if (!sym->attr.dummy)
7703	cl.backend_decl = (*stringargs)[0];
7704	else
7705	{
7706	formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
7707	for (; formal; formal = formal->next)
7708	if (strcmp (s1: formal->sym->name, s2: sym->name) == 0)
7709	cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
7710	}
7711	len = cl.backend_decl;
7712	}
7713	else
7714	{
7715	tree tmp;
7716
7717	/* Calculate the length of the returned string. */
7718	gfc_init_se (se: &parmse, NULL);
7719	if (need_interface_mapping)
7720	gfc_apply_interface_mapping (mapping: &mapping, se: &parmse, expr: ts.u.cl->length);
7721	else
7722	gfc_conv_expr (se: &parmse, expr: ts.u.cl->length);
7723	gfc_add_block_to_block (&se->pre, &parmse.pre);
7724	gfc_add_block_to_block (&se->post, &parmse.post);
7725	tmp = parmse.expr;
7726	/* TODO: It would be better to have the charlens as
7727	gfc_charlen_type_node already when the interface is
7728	created instead of converting it here (see PR 84615). */
7729	tmp = fold_build2_loc (input_location, MAX_EXPR,
7730	gfc_charlen_type_node,
7731	fold_convert (gfc_charlen_type_node, tmp),
7732	build_zero_cst (gfc_charlen_type_node));
7733	cl.backend_decl = tmp;
7734	}
7735
7736	/* Set up a charlen structure for it. */
7737	cl.next = NULL;
7738	cl.length = NULL;
7739	ts.u.cl = &cl;
7740
7741	len = cl.backend_decl;
7742	}
7743
7744	byref = (comp && (comp->attr.dimension
7745	|| (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
7746	|| (!comp && gfc_return_by_reference (sym));
7747	if (byref)
7748	{
7749	if (se->direct_byref)
7750	{
7751	/* Sometimes, too much indirection can be applied; e.g. for
7752	function_result = array_valued_recursive_function. */
7753	if (TREE_TYPE (TREE_TYPE (se->expr))
7754	&& TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
7755	&& GFC_DESCRIPTOR_TYPE_P
7756	(TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
7757	se->expr = build_fold_indirect_ref_loc (input_location,
7758	se->expr);
7759
7760	/* If the lhs of an assignment x = f(..) is allocatable and
7761	f2003 is allowed, we must do the automatic reallocation.
7762	TODO - deal with intrinsics, without using a temporary. */
7763	if (flag_realloc_lhs
7764	&& se->ss && se->ss->loop_chain
7765	&& se->ss->loop_chain->is_alloc_lhs
7766	&& !expr->value.function.isym
7767	&& sym->result->as != NULL)
7768	{
7769	/* Evaluate the bounds of the result, if known. */
7770	gfc_set_loop_bounds_from_array_spec (&mapping, se,
7771	sym->result->as);
7772
7773	/* Perform the automatic reallocation. */
7774	tmp = gfc_alloc_allocatable_for_assignment (se->loop,
7775	expr, NULL);
7776	gfc_add_expr_to_block (&se->pre, tmp);
7777
7778	/* Pass the temporary as the first argument. */
7779	result = info->descriptor;
7780	}
7781	else
7782	result = build_fold_indirect_ref_loc (input_location,
7783	se->expr);
7784	vec_safe_push (v&: retargs, obj: se->expr);
7785	}
7786	else if (comp && comp->attr.dimension)
7787	{
7788	gcc_assert (se->loop && info);
7789
7790	/* Set the type of the array. */
7791	tmp = gfc_typenode_for_spec (&comp->ts);
7792	gcc_assert (se->ss->dimen == se->loop->dimen);
7793
7794	/* Evaluate the bounds of the result, if known. */
7795	gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
7796
7797	/* If the lhs of an assignment x = f(..) is allocatable and
7798	f2003 is allowed, we must not generate the function call
7799	here but should just send back the results of the mapping.
7800	This is signalled by the function ss being flagged. */
7801	if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
7802	{
7803	gfc_free_interface_mapping (mapping: &mapping);
7804	return has_alternate_specifier;
7805	}
7806
7807	/* Create a temporary to store the result. In case the function
7808	returns a pointer, the temporary will be a shallow copy and
7809	mustn't be deallocated. */
7810	callee_alloc = comp->attr.allocatable || comp->attr.pointer;
7811	gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
7812	tmp, NULL_TREE, false,
7813	!comp->attr.pointer, callee_alloc,
7814	&se->ss->info->expr->where);
7815
7816	/* Pass the temporary as the first argument. */
7817	result = info->descriptor;
7818	tmp = gfc_build_addr_expr (NULL_TREE, result);
7819	vec_safe_push (v&: retargs, obj: tmp);
7820	}
7821	else if (!comp && sym->result->attr.dimension)
7822	{
7823	gcc_assert (se->loop && info);
7824
7825	/* Set the type of the array. */
7826	tmp = gfc_typenode_for_spec (&ts);
7827	gcc_assert (se->ss->dimen == se->loop->dimen);
7828
7829	/* Evaluate the bounds of the result, if known. */
7830	gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
7831
7832	/* If the lhs of an assignment x = f(..) is allocatable and
7833	f2003 is allowed, we must not generate the function call
7834	here but should just send back the results of the mapping.
7835	This is signalled by the function ss being flagged. */
7836	if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
7837	{
7838	gfc_free_interface_mapping (mapping: &mapping);
7839	return has_alternate_specifier;
7840	}
7841
7842	/* Create a temporary to store the result. In case the function
7843	returns a pointer, the temporary will be a shallow copy and
7844	mustn't be deallocated. */
7845	callee_alloc = sym->attr.allocatable || sym->attr.pointer;
7846	gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
7847	tmp, NULL_TREE, false,
7848	!sym->attr.pointer, callee_alloc,
7849	&se->ss->info->expr->where);
7850
7851	/* Pass the temporary as the first argument. */
7852	result = info->descriptor;
7853	tmp = gfc_build_addr_expr (NULL_TREE, result);
7854	vec_safe_push (v&: retargs, obj: tmp);
7855	}
7856	else if (ts.type == BT_CHARACTER)
7857	{
7858	/* Pass the string length. */
7859	type = gfc_get_character_type (ts.kind, ts.u.cl);
7860	type = build_pointer_type (type);
7861
7862	/* Emit a DECL_EXPR for the VLA type. */
7863	tmp = TREE_TYPE (type);
7864	if (TYPE_SIZE (tmp)
7865	&& TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
7866	{
7867	tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
7868	DECL_ARTIFICIAL (tmp) = 1;
7869	DECL_IGNORED_P (tmp) = 1;
7870	tmp = fold_build1_loc (input_location, DECL_EXPR,
7871	TREE_TYPE (tmp), tmp);
7872	gfc_add_expr_to_block (&se->pre, tmp);
7873	}
7874
7875	/* Return an address to a char[0:len-1]* temporary for
7876	character pointers. */
7877	if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
7878	|| (comp && (comp->attr.pointer || comp->attr.allocatable)))
7879	{
7880	var = gfc_create_var (type, "pstr");
7881
7882	if ((!comp && sym->attr.allocatable)
7883	|| (comp && comp->attr.allocatable))
7884	{
7885	gfc_add_modify (&se->pre, var,
7886	fold_convert (TREE_TYPE (var),
7887	null_pointer_node));
7888	tmp = gfc_call_free (var);
7889	gfc_add_expr_to_block (&se->post, tmp);
7890	}
7891
7892	/* Provide an address expression for the function arguments. */
7893	var = gfc_build_addr_expr (NULL_TREE, var);
7894	}
7895	else
7896	var = gfc_conv_string_tmp (se, type, len);
7897
7898	vec_safe_push (v&: retargs, obj: var);
7899	}
7900	else
7901	{
7902	gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
7903
7904	type = gfc_get_complex_type (ts.kind);
7905	var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
7906	vec_safe_push (v&: retargs, obj: var);
7907	}
7908
7909	/* Add the string length to the argument list. */
7910	if (ts.type == BT_CHARACTER && ts.deferred)
7911	{
7912	tmp = len;
7913	if (!VAR_P (tmp))
7914	tmp = gfc_evaluate_now (len, &se->pre);
7915	TREE_STATIC (tmp) = 1;
7916	gfc_add_modify (&se->pre, tmp,
7917	build_int_cst (TREE_TYPE (tmp), 0));
7918	tmp = gfc_build_addr_expr (NULL_TREE, tmp);
7919	vec_safe_push (v&: retargs, obj: tmp);
7920	}
7921	else if (ts.type == BT_CHARACTER)
7922	vec_safe_push (v&: retargs, obj: len);
7923	}
7924	gfc_free_interface_mapping (mapping: &mapping);
7925
7926	/* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
7927	arglen = (vec_safe_length (v: arglist) + vec_safe_length (v: optionalargs)
7928	+ vec_safe_length (v: stringargs) + vec_safe_length (v: append_args));
7929	vec_safe_reserve (v&: retargs, nelems: arglen);
7930
7931	/* Add the return arguments. */
7932	vec_safe_splice (dst&: retargs, src: arglist);
7933
7934	/* Add the hidden present status for optional+value to the arguments. */
7935	vec_safe_splice (dst&: retargs, src: optionalargs);
7936
7937	/* Add the hidden string length parameters to the arguments. */
7938	vec_safe_splice (dst&: retargs, src: stringargs);
7939
7940	/* We may want to append extra arguments here. This is used e.g. for
7941	calls to libgfortran_matmul_??, which need extra information. */
7942	vec_safe_splice (dst&: retargs, src: append_args);
7943
7944	arglist = retargs;
7945
7946	/* Generate the actual call. */
7947	if (base_object == NULL_TREE)
7948	conv_function_val (se, sym, expr, actual_args: args);
7949	else
7950	conv_base_obj_fcn_val (se, base_object, expr);
7951
7952	/* If there are alternate return labels, function type should be
7953	integer. Can't modify the type in place though, since it can be shared
7954	with other functions. For dummy arguments, the typing is done to
7955	this result, even if it has to be repeated for each call. */
7956	if (has_alternate_specifier
7957	&& TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
7958	{
7959	if (!sym->attr.dummy)
7960	{
7961	TREE_TYPE (sym->backend_decl)
7962	= build_function_type (integer_type_node,
7963	TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
7964	se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
7965	}
7966	else
7967	TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
7968	}
7969
7970	fntype = TREE_TYPE (TREE_TYPE (se->expr));
7971	se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
7972
7973	/* Allocatable scalar function results must be freed and nullified
7974	after use. This necessitates the creation of a temporary to
7975	hold the result to prevent duplicate calls. */
7976	symbol_attribute attr = comp ? comp->attr : sym->attr;
7977	bool allocatable = attr.allocatable && !attr.dimension;
7978	gfc_symbol *der = comp ?
7979	comp->ts.type == BT_DERIVED ? comp->ts.u.derived : NULL
7980	:
7981	sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL;
7982	bool finalizable = der != NULL && der->ns->proc_name
7983	&& gfc_is_finalizable (der, NULL);
7984
7985	if (!byref && finalizable)
7986	gfc_finalize_tree_expr (se, der, attr, expr->rank);
7987
7988	if (!byref && sym->ts.type != BT_CHARACTER
7989	&& allocatable && !finalizable)
7990	{
7991	tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
7992	gfc_add_modify (&se->pre, tmp, se->expr);
7993	se->expr = tmp;
7994	tmp = gfc_call_free (tmp);
7995	gfc_add_expr_to_block (&post, tmp);
7996	gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
7997	}
7998
7999	/* If we have a pointer function, but we don't want a pointer, e.g.
8000	something like
8001	x = f()
8002	where f is pointer valued, we have to dereference the result. */
8003	if (!se->want_pointer && !byref
8004	&& ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8005	|| (comp && (comp->attr.pointer || comp->attr.allocatable))))
8006	se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
8007
8008	/* f2c calling conventions require a scalar default real function to
8009	return a double precision result. Convert this back to default
8010	real. We only care about the cases that can happen in Fortran 77.
8011	*/
8012	if (flag_f2c && sym->ts.type == BT_REAL
8013	&& sym->ts.kind == gfc_default_real_kind
8014	&& !sym->attr.pointer
8015	&& !sym->attr.allocatable
8016	&& !sym->attr.always_explicit)
8017	se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
8018
8019	/* A pure function may still have side-effects - it may modify its
8020	parameters. */
8021	TREE_SIDE_EFFECTS (se->expr) = 1;
8022	#if 0
8023	if (!sym->attr.pure)
8024	TREE_SIDE_EFFECTS (se->expr) = 1;
8025	#endif
8026
8027	if (byref)
8028	{
8029	/* Add the function call to the pre chain. There is no expression. */
8030	gfc_add_expr_to_block (&se->pre, se->expr);
8031	se->expr = NULL_TREE;
8032
8033	if (!se->direct_byref)
8034	{
8035	if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
8036	{
8037	if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
8038	{
8039	/* Check the data pointer hasn't been modified. This would
8040	happen in a function returning a pointer. */
8041	tmp = gfc_conv_descriptor_data_get (info->descriptor);
8042	tmp = fold_build2_loc (input_location, NE_EXPR,
8043	logical_type_node,
8044	tmp, info->data);
8045	gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
8046	gfc_msg_fault);
8047	}
8048	se->expr = info->descriptor;
8049	/* Bundle in the string length. */
8050	se->string_length = len;
8051
8052	if (finalizable)
8053	gfc_finalize_tree_expr (se, der, attr, expr->rank);
8054	}
8055	else if (ts.type == BT_CHARACTER)
8056	{
8057	/* Dereference for character pointer results. */
8058	if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8059	|| (comp && (comp->attr.pointer || comp->attr.allocatable)))
8060	se->expr = build_fold_indirect_ref_loc (input_location, var);
8061	else
8062	se->expr = var;
8063
8064	se->string_length = len;
8065	}
8066	else
8067	{
8068	gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
8069	se->expr = build_fold_indirect_ref_loc (input_location, var);
8070	}
8071	}
8072	}
8073
8074	/* Associate the rhs class object's meta-data with the result, when the
8075	result is a temporary. */
8076	if (args && args->expr && args->expr->ts.type == BT_CLASS
8077	&& sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
8078	&& !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
8079	{
8080	gfc_se parmse;
8081	gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (e: args->expr);
8082
8083	gfc_init_se (se: &parmse, NULL);
8084	parmse.data_not_needed = 1;
8085	gfc_conv_expr (se: &parmse, expr: class_expr);
8086	if (!DECL_LANG_SPECIFIC (result))
8087	gfc_allocate_lang_decl (result);
8088	GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
8089	gfc_free_expr (class_expr);
8090	/* -fcheck= can add diagnostic code, which has to be placed before
8091	the call. */
8092	if (parmse.pre.head != NULL)
8093	gfc_add_expr_to_block (&se->pre, parmse.pre.head);
8094	gcc_assert (parmse.post.head == NULL_TREE);
8095	}
8096
8097	/* Follow the function call with the argument post block. */
8098	if (byref)
8099	{
8100	gfc_add_block_to_block (&se->pre, &post);
8101
8102	/* Transformational functions of derived types with allocatable
8103	components must have the result allocatable components copied when the
8104	argument is actually given. */
8105	arg = expr->value.function.actual;
8106	if (result && arg && expr->rank
8107	&& expr->value.function.isym
8108	&& expr->value.function.isym->transformational
8109	&& arg->expr
8110	&& arg->expr->ts.type == BT_DERIVED
8111	&& arg->expr->ts.u.derived->attr.alloc_comp)
8112	{
8113	tree tmp2;
8114	/* Copy the allocatable components. We have to use a
8115	temporary here to prevent source allocatable components
8116	from being corrupted. */
8117	tmp2 = gfc_evaluate_now (result, &se->pre);
8118	tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
8119	result, tmp2, expr->rank, 0);
8120	gfc_add_expr_to_block (&se->pre, tmp);
8121	tmp = gfc_copy_allocatable_data (dest: result, src: tmp2, TREE_TYPE(tmp2),
8122	rank: expr->rank);
8123	gfc_add_expr_to_block (&se->pre, tmp);
8124
8125	/* Finally free the temporary's data field. */
8126	tmp = gfc_conv_descriptor_data_get (tmp2);
8127	tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
8128	NULL_TREE, NULL_TREE, true,
8129	NULL, GFC_CAF_COARRAY_NOCOARRAY);
8130	gfc_add_expr_to_block (&se->pre, tmp);
8131	}
8132	}
8133	else
8134	{
8135	/* For a function with a class array result, save the result as
8136	a temporary, set the info fields needed by the scalarizer and
8137	call the finalization function of the temporary. Note that the
8138	nullification of allocatable components needed by the result
8139	is done in gfc_trans_assignment_1. */
8140	if (expr && ((gfc_is_class_array_function (expr)
8141	&& se->ss && se->ss->loop)
8142	|| gfc_is_alloc_class_scalar_function (expr))
8143	&& se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
8144	&& expr->must_finalize)
8145	{
8146	int n;
8147	if (se->ss && se->ss->loop)
8148	{
8149	gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
8150	se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
8151	tmp = gfc_class_data_get (decl: se->expr);
8152	info->descriptor = tmp;
8153	info->data = gfc_conv_descriptor_data_get (tmp);
8154	info->offset = gfc_conv_descriptor_offset_get (tmp);
8155	for (n = 0; n < se->ss->loop->dimen; n++)
8156	{
8157	tree dim = gfc_rank_cst[n];
8158	se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
8159	se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
8160	}
8161	}
8162	else
8163	{
8164	/* TODO Eliminate the doubling of temporaries. This
8165	one is necessary to ensure no memory leakage. */
8166	se->expr = gfc_evaluate_now (se->expr, &se->pre);
8167	}
8168
8169	/* Finalize the result, if necessary. */
8170	attr = CLASS_DATA (expr->value.function.esym->result)->attr;
8171	if (!((gfc_is_class_array_function (expr)
8172	|| gfc_is_alloc_class_scalar_function (expr))
8173	&& attr.pointer))
8174	gfc_finalize_tree_expr (se, NULL, attr, expr->rank);
8175	}
8176	gfc_add_block_to_block (&se->post, &post);
8177	}
8178
8179	return has_alternate_specifier;
8180	}
8181
8182
8183	/* Fill a character string with spaces. */
8184
8185	static tree
8186	fill_with_spaces (tree start, tree type, tree size)
8187	{
8188	stmtblock_t block, loop;
8189	tree i, el, exit_label, cond, tmp;
8190
8191	/* For a simple char type, we can call memset(). */
8192	if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
8193	return build_call_expr_loc (input_location,
8194	builtin_decl_explicit (fncode: BUILT_IN_MEMSET),
8195	3, start,
8196	build_int_cst (gfc_get_int_type (gfc_c_int_kind),
8197	lang_hooks.to_target_charset (' ')),
8198	fold_convert (size_type_node, size));
8199
8200	/* Otherwise, we use a loop:
8201	for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
8202	*el = (type) ' ';
8203	*/
8204
8205	/* Initialize variables. */
8206	gfc_init_block (&block);
8207	i = gfc_create_var (sizetype, "i");
8208	gfc_add_modify (&block, i, fold_convert (sizetype, size));
8209	el = gfc_create_var (build_pointer_type (type), "el");
8210	gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
8211	exit_label = gfc_build_label_decl (NULL_TREE);
8212	TREE_USED (exit_label) = 1;
8213
8214
8215	/* Loop body. */
8216	gfc_init_block (&loop);
8217
8218	/* Exit condition. */
8219	cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
8220	build_zero_cst (sizetype));
8221	tmp = build1_v (GOTO_EXPR, exit_label);
8222	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
8223	build_empty_stmt (input_location));
8224	gfc_add_expr_to_block (&loop, tmp);
8225
8226	/* Assignment. */
8227	gfc_add_modify (&loop,
8228	fold_build1_loc (input_location, INDIRECT_REF, type, el),
8229	build_int_cst (type, lang_hooks.to_target_charset (' ')));
8230
8231	/* Increment loop variables. */
8232	gfc_add_modify (&loop, i,
8233	fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
8234	TYPE_SIZE_UNIT (type)));
8235	gfc_add_modify (&loop, el,
8236	fold_build_pointer_plus_loc (loc: input_location,
8237	ptr: el, TYPE_SIZE_UNIT (type)));
8238
8239	/* Making the loop... actually loop! */
8240	tmp = gfc_finish_block (&loop);
8241	tmp = build1_v (LOOP_EXPR, tmp);
8242	gfc_add_expr_to_block (&block, tmp);
8243
8244	/* The exit label. */
8245	tmp = build1_v (LABEL_EXPR, exit_label);
8246	gfc_add_expr_to_block (&block, tmp);
8247
8248
8249	return gfc_finish_block (&block);
8250	}
8251
8252
8253	/* Generate code to copy a string. */
8254
8255	void
8256	gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
8257	int dkind, tree slength, tree src, int skind)
8258	{
8259	tree tmp, dlen, slen;
8260	tree dsc;
8261	tree ssc;
8262	tree cond;
8263	tree cond2;
8264	tree tmp2;
8265	tree tmp3;
8266	tree tmp4;
8267	tree chartype;
8268	stmtblock_t tempblock;
8269
8270	gcc_assert (dkind == skind);
8271
8272	if (slength != NULL_TREE)
8273	{
8274	slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
8275	ssc = gfc_string_to_single_character (len: slen, str: src, kind: skind);
8276	}
8277	else
8278	{
8279	slen = build_one_cst (gfc_charlen_type_node);
8280	ssc = src;
8281	}
8282
8283	if (dlength != NULL_TREE)
8284	{
8285	dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
8286	dsc = gfc_string_to_single_character (len: dlen, str: dest, kind: dkind);
8287	}
8288	else
8289	{
8290	dlen = build_one_cst (gfc_charlen_type_node);
8291	dsc = dest;
8292	}
8293
8294	/* Assign directly if the types are compatible. */
8295	if (dsc != NULL_TREE && ssc != NULL_TREE
8296	&& TREE_TYPE (dsc) == TREE_TYPE (ssc))
8297	{
8298	gfc_add_modify (block, dsc, ssc);
8299	return;
8300	}
8301
8302	/* The string copy algorithm below generates code like
8303
8304	if (destlen > 0)
8305	{
8306	if (srclen < destlen)
8307	{
8308	memmove (dest, src, srclen);
8309	// Pad with spaces.
8310	memset (&dest[srclen], ' ', destlen - srclen);
8311	}
8312	else
8313	{
8314	// Truncate if too long.
8315	memmove (dest, src, destlen);
8316	}
8317	}
8318	*/
8319
8320	/* Do nothing if the destination length is zero. */
8321	cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
8322	build_zero_cst (TREE_TYPE (dlen)));
8323
8324	/* For non-default character kinds, we have to multiply the string
8325	length by the base type size. */
8326	chartype = gfc_get_char_type (dkind);
8327	slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
8328	slen,
8329	fold_convert (TREE_TYPE (slen),
8330	TYPE_SIZE_UNIT (chartype)));
8331	dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
8332	dlen,
8333	fold_convert (TREE_TYPE (dlen),
8334	TYPE_SIZE_UNIT (chartype)));
8335
8336	if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
8337	dest = fold_convert (pvoid_type_node, dest);
8338	else
8339	dest = gfc_build_addr_expr (pvoid_type_node, dest);
8340
8341	if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
8342	src = fold_convert (pvoid_type_node, src);
8343	else
8344	src = gfc_build_addr_expr (pvoid_type_node, src);
8345
8346	/* Truncate string if source is too long. */
8347	cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
8348	dlen);
8349
8350	/* Pre-evaluate pointers unless one of the IF arms will be optimized away. */
8351	if (!CONSTANT_CLASS_P (cond2))
8352	{
8353	dest = gfc_evaluate_now (dest, block);
8354	src = gfc_evaluate_now (src, block);
8355	}
8356
8357	/* Copy and pad with spaces. */
8358	tmp3 = build_call_expr_loc (input_location,
8359	builtin_decl_explicit (fncode: BUILT_IN_MEMMOVE),
8360	3, dest, src,
8361	fold_convert (size_type_node, slen));
8362
8363	/* Wstringop-overflow appears at -O3 even though this warning is not
8364	explicitly available in fortran nor can it be switched off. If the
8365	source length is a constant, its negative appears as a very large
8366	positive number and triggers the warning in BUILTIN_MEMSET. Fixing
8367	the result of the MINUS_EXPR suppresses this spurious warning. */
8368	tmp = fold_build2_loc (input_location, MINUS_EXPR,
8369	TREE_TYPE(dlen), dlen, slen);
8370	if (slength && TREE_CONSTANT (slength))
8371	tmp = gfc_evaluate_now (tmp, block);
8372
8373	tmp4 = fold_build_pointer_plus_loc (loc: input_location, ptr: dest, off: slen);
8374	tmp4 = fill_with_spaces (start: tmp4, type: chartype, size: tmp);
8375
8376	gfc_init_block (&tempblock);
8377	gfc_add_expr_to_block (&tempblock, tmp3);
8378	gfc_add_expr_to_block (&tempblock, tmp4);
8379	tmp3 = gfc_finish_block (&tempblock);
8380
8381	/* The truncated memmove if the slen >= dlen. */
8382	tmp2 = build_call_expr_loc (input_location,
8383	builtin_decl_explicit (fncode: BUILT_IN_MEMMOVE),
8384	3, dest, src,
8385	fold_convert (size_type_node, dlen));
8386
8387	/* The whole copy_string function is there. */
8388	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
8389	tmp3, tmp2);
8390	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
8391	build_empty_stmt (input_location));
8392	gfc_add_expr_to_block (block, tmp);
8393	}
8394
8395
8396	/* Translate a statement function.
8397	The value of a statement function reference is obtained by evaluating the
8398	expression using the values of the actual arguments for the values of the
8399	corresponding dummy arguments. */
8400
8401	static void
8402	gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
8403	{
8404	gfc_symbol *sym;
8405	gfc_symbol *fsym;
8406	gfc_formal_arglist *fargs;
8407	gfc_actual_arglist *args;
8408	gfc_se lse;
8409	gfc_se rse;
8410	gfc_saved_var *saved_vars;
8411	tree *temp_vars;
8412	tree type;
8413	tree tmp;
8414	int n;
8415
8416	sym = expr->symtree->n.sym;
8417	args = expr->value.function.actual;
8418	gfc_init_se (se: &lse, NULL);
8419	gfc_init_se (se: &rse, NULL);
8420
8421	n = 0;
8422	for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
8423	n++;
8424	saved_vars = XCNEWVEC (gfc_saved_var, n);
8425	temp_vars = XCNEWVEC (tree, n);
8426
8427	for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
8428	fargs = fargs->next, n++)
8429	{
8430	/* Each dummy shall be specified, explicitly or implicitly, to be
8431	scalar. */
8432	gcc_assert (fargs->sym->attr.dimension == 0);
8433	fsym = fargs->sym;
8434
8435	if (fsym->ts.type == BT_CHARACTER)
8436	{
8437	/* Copy string arguments. */
8438	tree arglen;
8439
8440	gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
8441	&& fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
8442
8443	/* Create a temporary to hold the value. */
8444	if (fsym->ts.u.cl->backend_decl == NULL_TREE)
8445	fsym->ts.u.cl->backend_decl
8446	= gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
8447
8448	type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
8449	temp_vars[n] = gfc_create_var (type, fsym->name);
8450
8451	arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
8452
8453	gfc_conv_expr (se: &rse, expr: args->expr);
8454	gfc_conv_string_parameter (se: &rse);
8455	gfc_add_block_to_block (&se->pre, &lse.pre);
8456	gfc_add_block_to_block (&se->pre, &rse.pre);
8457
8458	gfc_trans_string_copy (block: &se->pre, dlength: arglen, dest: temp_vars[n], dkind: fsym->ts.kind,
8459	slength: rse.string_length, src: rse.expr, skind: fsym->ts.kind);
8460	gfc_add_block_to_block (&se->pre, &lse.post);
8461	gfc_add_block_to_block (&se->pre, &rse.post);
8462	}
8463	else
8464	{
8465	/* For everything else, just evaluate the expression. */
8466
8467	/* Create a temporary to hold the value. */
8468	type = gfc_typenode_for_spec (&fsym->ts);
8469	temp_vars[n] = gfc_create_var (type, fsym->name);
8470
8471	gfc_conv_expr (se: &lse, expr: args->expr);
8472
8473	gfc_add_block_to_block (&se->pre, &lse.pre);
8474	gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
8475	gfc_add_block_to_block (&se->pre, &lse.post);
8476	}
8477
8478	args = args->next;
8479	}
8480
8481	/* Use the temporary variables in place of the real ones. */
8482	for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
8483	fargs = fargs->next, n++)
8484	gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
8485
8486	gfc_conv_expr (se, expr: sym->value);
8487
8488	if (sym->ts.type == BT_CHARACTER)
8489	{
8490	gfc_conv_const_charlen (sym->ts.u.cl);
8491
8492	/* Force the expression to the correct length. */
8493	if (!INTEGER_CST_P (se->string_length)
8494	|| tree_int_cst_lt (t1: se->string_length,
8495	t2: sym->ts.u.cl->backend_decl))
8496	{
8497	type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
8498	tmp = gfc_create_var (type, sym->name);
8499	tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
8500	gfc_trans_string_copy (block: &se->pre, dlength: sym->ts.u.cl->backend_decl, dest: tmp,
8501	dkind: sym->ts.kind, slength: se->string_length, src: se->expr,
8502	skind: sym->ts.kind);
8503	se->expr = tmp;
8504	}
8505	se->string_length = sym->ts.u.cl->backend_decl;
8506	}
8507
8508	/* Restore the original variables. */
8509	for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
8510	fargs = fargs->next, n++)
8511	gfc_restore_sym (fargs->sym, &saved_vars[n]);
8512	free (ptr: temp_vars);
8513	free (ptr: saved_vars);
8514	}
8515
8516
8517	/* Translate a function expression. */
8518
8519	static void
8520	gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
8521	{
8522	gfc_symbol *sym;
8523
8524	if (expr->value.function.isym)
8525	{
8526	gfc_conv_intrinsic_function (se, expr);
8527	return;
8528	}
8529
8530	/* expr.value.function.esym is the resolved (specific) function symbol for
8531	most functions. However this isn't set for dummy procedures. */
8532	sym = expr->value.function.esym;
8533	if (!sym)
8534	sym = expr->symtree->n.sym;
8535
8536	/* The IEEE_ARITHMETIC functions are caught here. */
8537	if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
8538	if (gfc_conv_ieee_arithmetic_function (se, expr))
8539	return;
8540
8541	/* We distinguish statement functions from general functions to improve
8542	runtime performance. */
8543	if (sym->attr.proc == PROC_ST_FUNCTION)
8544	{
8545	gfc_conv_statement_function (se, expr);
8546	return;
8547	}
8548
8549	gfc_conv_procedure_call (se, sym, args: expr->value.function.actual, expr,
8550	NULL);
8551	}
8552
8553
8554	/* Determine whether the given EXPR_CONSTANT is a zero initializer. */
8555
8556	static bool
8557	is_zero_initializer_p (gfc_expr * expr)
8558	{
8559	if (expr->expr_type != EXPR_CONSTANT)
8560	return false;
8561
8562	/* We ignore constants with prescribed memory representations for now. */
8563	if (expr->representation.string)
8564	return false;
8565
8566	switch (expr->ts.type)
8567	{
8568	case BT_INTEGER:
8569	return mpz_cmp_si (expr->value.integer, 0) == 0;
8570
8571	case BT_REAL:
8572	return mpfr_zero_p (expr->value.real)
8573	&& MPFR_SIGN (expr->value.real) >= 0;
8574
8575	case BT_LOGICAL:
8576	return expr->value.logical == 0;
8577
8578	case BT_COMPLEX:
8579	return mpfr_zero_p (mpc_realref (expr->value.complex))
8580	&& MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
8581	&& mpfr_zero_p (mpc_imagref (expr->value.complex))
8582	&& MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
8583
8584	default:
8585	break;
8586	}
8587	return false;
8588	}
8589
8590
8591	static void
8592	gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
8593	{
8594	gfc_ss *ss;
8595
8596	ss = se->ss;
8597	gcc_assert (ss != NULL && ss != gfc_ss_terminator);
8598	gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
8599
8600	gfc_conv_tmp_array_ref (se);
8601	}
8602
8603
8604	/* Build a static initializer. EXPR is the expression for the initial value.
8605	The other parameters describe the variable of the component being
8606	initialized. EXPR may be null. */
8607
8608	tree
8609	gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
8610	bool array, bool pointer, bool procptr)
8611	{
8612	gfc_se se;
8613
8614	if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
8615	&& ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
8616	&& ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
8617	return build_constructor (type, NULL);
8618
8619	if (!(expr || pointer || procptr))
8620	return NULL_TREE;
8621
8622	/* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
8623	(these are the only two iso_c_binding derived types that can be
8624	used as initialization expressions). If so, we need to modify
8625	the 'expr' to be that for a (void *). */
8626	if (expr != NULL && expr->ts.type == BT_DERIVED
8627	&& expr->ts.is_iso_c && expr->ts.u.derived)
8628	{
8629	if (TREE_CODE (type) == ARRAY_TYPE)
8630	return build_constructor (type, NULL);
8631	else if (POINTER_TYPE_P (type))
8632	return build_int_cst (type, 0);
8633	else
8634	gcc_unreachable ();
8635	}
8636
8637	if (array && !procptr)
8638	{
8639	tree ctor;
8640	/* Arrays need special handling. */
8641	if (pointer)
8642	ctor = gfc_build_null_descriptor (type);
8643	/* Special case assigning an array to zero. */
8644	else if (is_zero_initializer_p (expr))
8645	ctor = build_constructor (type, NULL);
8646	else
8647	ctor = gfc_conv_array_initializer (type, expr);
8648	TREE_STATIC (ctor) = 1;
8649	return ctor;
8650	}
8651	else if (pointer || procptr)
8652	{
8653	if (ts->type == BT_CLASS && !procptr)
8654	{
8655	gfc_init_se (se: &se, NULL);
8656	gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
8657	gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
8658	TREE_STATIC (se.expr) = 1;
8659	return se.expr;
8660	}
8661	else if (!expr || expr->expr_type == EXPR_NULL)
8662	return fold_convert (type, null_pointer_node);
8663	else
8664	{
8665	gfc_init_se (se: &se, NULL);
8666	se.want_pointer = 1;
8667	gfc_conv_expr (se: &se, expr);
8668	gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
8669	return se.expr;
8670	}
8671	}
8672	else
8673	{
8674	switch (ts->type)
8675	{
8676	case_bt_struct:
8677	case BT_CLASS:
8678	gfc_init_se (se: &se, NULL);
8679	if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
8680	gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
8681	else
8682	gfc_conv_structure (&se, expr, 1);
8683	gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
8684	TREE_STATIC (se.expr) = 1;
8685	return se.expr;
8686
8687	case BT_CHARACTER:
8688	if (expr->expr_type == EXPR_CONSTANT)
8689	{
8690	tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl, expr);
8691	TREE_STATIC (ctor) = 1;
8692	return ctor;
8693	}
8694
8695	/* Fallthrough. */
8696	default:
8697	gfc_init_se (se: &se, NULL);
8698	gfc_conv_constant (&se, expr);
8699	gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
8700	return se.expr;
8701	}
8702	}
8703	}
8704
8705	static tree
8706	gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
8707	{
8708	gfc_se rse;
8709	gfc_se lse;
8710	gfc_ss *rss;
8711	gfc_ss *lss;
8712	gfc_array_info *lss_array;
8713	stmtblock_t body;
8714	stmtblock_t block;
8715	gfc_loopinfo loop;
8716	int n;
8717	tree tmp;
8718
8719	gfc_start_block (&block);
8720
8721	/* Initialize the scalarizer. */
8722	gfc_init_loopinfo (&loop);
8723
8724	gfc_init_se (se: &lse, NULL);
8725	gfc_init_se (se: &rse, NULL);
8726
8727	/* Walk the rhs. */
8728	rss = gfc_walk_expr (expr);
8729	if (rss == gfc_ss_terminator)
8730	/* The rhs is scalar. Add a ss for the expression. */
8731	rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
8732
8733	/* Create a SS for the destination. */
8734	lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
8735	GFC_SS_COMPONENT);
8736	lss_array = &lss->info->data.array;
8737	lss_array->shape = gfc_get_shape (cm->as->rank);
8738	lss_array->descriptor = dest;
8739	lss_array->data = gfc_conv_array_data (dest);
8740	lss_array->offset = gfc_conv_array_offset (dest);
8741	for (n = 0; n < cm->as->rank; n++)
8742	{
8743	lss_array->start[n] = gfc_conv_array_lbound (dest, n);
8744	lss_array->stride[n] = gfc_index_one_node;
8745
8746	mpz_init (lss_array->shape[n]);
8747	mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
8748	cm->as->lower[n]->value.integer);
8749	mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
8750	}
8751
8752	/* Associate the SS with the loop. */
8753	gfc_add_ss_to_loop (&loop, lss);
8754	gfc_add_ss_to_loop (&loop, rss);
8755
8756	/* Calculate the bounds of the scalarization. */
8757	gfc_conv_ss_startstride (&loop);
8758
8759	/* Setup the scalarizing loops. */
8760	gfc_conv_loop_setup (&loop, &expr->where);
8761
8762	/* Setup the gfc_se structures. */
8763	gfc_copy_loopinfo_to_se (&lse, &loop);
8764	gfc_copy_loopinfo_to_se (&rse, &loop);
8765
8766	rse.ss = rss;
8767	gfc_mark_ss_chain_used (rss, 1);
8768	lse.ss = lss;
8769	gfc_mark_ss_chain_used (lss, 1);
8770
8771	/* Start the scalarized loop body. */
8772	gfc_start_scalarized_body (&loop, &body);
8773
8774	gfc_conv_tmp_array_ref (se: &lse);
8775	if (cm->ts.type == BT_CHARACTER)
8776	lse.string_length = cm->ts.u.cl->backend_decl;
8777
8778	gfc_conv_expr (se: &rse, expr);
8779
8780	tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
8781	gfc_add_expr_to_block (&body, tmp);
8782
8783	gcc_assert (rse.ss == gfc_ss_terminator);
8784
8785	/* Generate the copying loops. */
8786	gfc_trans_scalarizing_loops (&loop, &body);
8787
8788	/* Wrap the whole thing up. */
8789	gfc_add_block_to_block (&block, &loop.pre);
8790	gfc_add_block_to_block (&block, &loop.post);
8791
8792	gcc_assert (lss_array->shape != NULL);
8793	gfc_free_shape (shape: &lss_array->shape, rank: cm->as->rank);
8794	gfc_cleanup_loop (&loop);
8795
8796	return gfc_finish_block (&block);
8797	}
8798
8799
8800	static tree
8801	gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
8802	gfc_expr * expr)
8803	{
8804	gfc_se se;
8805	stmtblock_t block;
8806	tree offset;
8807	int n;
8808	tree tmp;
8809	tree tmp2;
8810	gfc_array_spec *as;
8811	gfc_expr *arg = NULL;
8812
8813	gfc_start_block (&block);
8814	gfc_init_se (se: &se, NULL);
8815
8816	/* Get the descriptor for the expressions. */
8817	se.want_pointer = 0;
8818	gfc_conv_expr_descriptor (&se, expr);
8819	gfc_add_block_to_block (&block, &se.pre);
8820	gfc_add_modify (&block, dest, se.expr);
8821	if (cm->ts.type == BT_CHARACTER
8822	&& gfc_deferred_strlen (cm, &tmp))
8823	{
8824	tmp = fold_build3_loc (input_location, COMPONENT_REF,
8825	TREE_TYPE (tmp),
8826	TREE_OPERAND (dest, 0),
8827	tmp, NULL_TREE);
8828	gfc_add_modify (&block, tmp,
8829	fold_convert (TREE_TYPE (tmp),
8830	se.string_length));
8831	cm->ts.u.cl->backend_decl = gfc_create_var (gfc_charlen_type_node,
8832	"slen");
8833	gfc_add_modify (&block, cm->ts.u.cl->backend_decl, se.string_length);
8834	}
8835
8836	/* Deal with arrays of derived types with allocatable components. */
8837	if (gfc_bt_struct (cm->ts.type)
8838	&& cm->ts.u.derived->attr.alloc_comp)
8839	// TODO: Fix caf_mode
8840	tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
8841	se.expr, dest,
8842	cm->as->rank, 0);
8843	else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
8844	&& CLASS_DATA(cm)->attr.allocatable)
8845	{
8846	if (cm->ts.u.derived->attr.alloc_comp)
8847	// TODO: Fix caf_mode
8848	tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
8849	se.expr, dest,
8850	expr->rank, 0);
8851	else
8852	{
8853	tmp = TREE_TYPE (dest);
8854	tmp = gfc_duplicate_allocatable (dest, se.expr,
8855	tmp, expr->rank, NULL_TREE);
8856	}
8857	}
8858	else if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
8859	tmp = gfc_duplicate_allocatable (dest, se.expr,
8860	gfc_typenode_for_spec (&cm->ts),
8861	cm->as->rank, NULL_TREE);
8862	else
8863	tmp = gfc_duplicate_allocatable (dest, se.expr,
8864	TREE_TYPE(cm->backend_decl),
8865	cm->as->rank, NULL_TREE);
8866
8867
8868	gfc_add_expr_to_block (&block, tmp);
8869	gfc_add_block_to_block (&block, &se.post);
8870
8871	if (expr->expr_type != EXPR_VARIABLE)
8872	gfc_conv_descriptor_data_set (&block, se.expr,
8873	null_pointer_node);
8874
8875	/* We need to know if the argument of a conversion function is a
8876	variable, so that the correct lower bound can be used. */
8877	if (expr->expr_type == EXPR_FUNCTION
8878	&& expr->value.function.isym
8879	&& expr->value.function.isym->conversion
8880	&& expr->value.function.actual->expr
8881	&& expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
8882	arg = expr->value.function.actual->expr;
8883
8884	/* Obtain the array spec of full array references. */
8885	if (arg)
8886	as = gfc_get_full_arrayspec_from_expr (expr: arg);
8887	else
8888	as = gfc_get_full_arrayspec_from_expr (expr);
8889
8890	/* Shift the lbound and ubound of temporaries to being unity,
8891	rather than zero, based. Always calculate the offset. */
8892	offset = gfc_conv_descriptor_offset_get (dest);
8893	gfc_add_modify (&block, offset, gfc_index_zero_node);
8894	tmp2 =gfc_create_var (gfc_array_index_type, NULL);
8895
8896	for (n = 0; n < expr->rank; n++)
8897	{
8898	tree span;
8899	tree lbound;
8900
8901	/* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
8902	TODO It looks as if gfc_conv_expr_descriptor should return
8903	the correct bounds and that the following should not be
8904	necessary. This would simplify gfc_conv_intrinsic_bound
8905	as well. */
8906	if (as && as->lower[n])
8907	{
8908	gfc_se lbse;
8909	gfc_init_se (se: &lbse, NULL);
8910	gfc_conv_expr (se: &lbse, expr: as->lower[n]);
8911	gfc_add_block_to_block (&block, &lbse.pre);
8912	lbound = gfc_evaluate_now (lbse.expr, &block);
8913	}
8914	else if (as && arg)
8915	{
8916	tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
8917	lbound = gfc_conv_descriptor_lbound_get (tmp,
8918	gfc_rank_cst[n]);
8919	}
8920	else if (as)
8921	lbound = gfc_conv_descriptor_lbound_get (dest,
8922	gfc_rank_cst[n]);
8923	else
8924	lbound = gfc_index_one_node;
8925
8926	lbound = fold_convert (gfc_array_index_type, lbound);
8927
8928	/* Shift the bounds and set the offset accordingly. */
8929	tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
8930	span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8931	tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
8932	tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8933	span, lbound);
8934	gfc_conv_descriptor_ubound_set (&block, dest,
8935	gfc_rank_cst[n], tmp);
8936	gfc_conv_descriptor_lbound_set (&block, dest,
8937	gfc_rank_cst[n], lbound);
8938
8939	tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8940	gfc_conv_descriptor_lbound_get (dest,
8941	gfc_rank_cst[n]),
8942	gfc_conv_descriptor_stride_get (dest,
8943	gfc_rank_cst[n]));
8944	gfc_add_modify (&block, tmp2, tmp);
8945	tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8946	offset, tmp2);
8947	gfc_conv_descriptor_offset_set (&block, dest, tmp);
8948	}
8949
8950	if (arg)
8951	{
8952	/* If a conversion expression has a null data pointer
8953	argument, nullify the allocatable component. */
8954	tree non_null_expr;
8955	tree null_expr;
8956
8957	if (arg->symtree->n.sym->attr.allocatable
8958	|| arg->symtree->n.sym->attr.pointer)
8959	{
8960	non_null_expr = gfc_finish_block (&block);
8961	gfc_start_block (&block);
8962	gfc_conv_descriptor_data_set (&block, dest,
8963	null_pointer_node);
8964	null_expr = gfc_finish_block (&block);
8965	tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
8966	tmp = build2_loc (loc: input_location, code: EQ_EXPR, type: logical_type_node, arg0: tmp,
8967	fold_convert (TREE_TYPE (tmp), null_pointer_node));
8968	return build3_v (COND_EXPR, tmp,
8969	null_expr, non_null_expr);
8970	}
8971	}
8972
8973	return gfc_finish_block (&block);
8974	}
8975
8976
8977	/* Allocate or reallocate scalar component, as necessary. */
8978
8979	static void
8980	alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp,
8981	gfc_component *cm, gfc_expr *expr2,
8982	tree slen)
8983	{
8984	tree tmp;
8985	tree ptr;
8986	tree size;
8987	tree size_in_bytes;
8988	tree lhs_cl_size = NULL_TREE;
8989	gfc_se se;
8990
8991	if (!comp)
8992	return;
8993
8994	if (!expr2 || expr2->rank)
8995	return;
8996
8997	realloc_lhs_warning (type: expr2->ts.type, array: false, where: &expr2->where);
8998
8999	if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9000	{
9001	gcc_assert (expr2->ts.type == BT_CHARACTER);
9002	if (!expr2->ts.u.cl->backend_decl
9003	|| !VAR_P (expr2->ts.u.cl->backend_decl))
9004	expr2->ts.u.cl->backend_decl = gfc_create_var (TREE_TYPE (slen),
9005	"slen");
9006	gfc_add_modify (block, expr2->ts.u.cl->backend_decl, slen);
9007
9008	size = expr2->ts.u.cl->backend_decl;
9009
9010	gfc_deferred_strlen (cm, &tmp);
9011	lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
9012	gfc_charlen_type_node,
9013	TREE_OPERAND (comp, 0),
9014	tmp, NULL_TREE);
9015
9016	tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
9017	tmp = TYPE_SIZE_UNIT (tmp);
9018	size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
9019	TREE_TYPE (tmp), tmp,
9020	fold_convert (TREE_TYPE (tmp), size));
9021	}
9022	else if (cm->ts.type == BT_CLASS)
9023	{
9024	if (expr2->ts.type != BT_CLASS)
9025	{
9026	if (expr2->ts.type == BT_CHARACTER)
9027	{
9028	gfc_init_se (se: &se, NULL);
9029	gfc_conv_expr (se: &se, expr: expr2);
9030	size = build_int_cst (gfc_charlen_type_node, expr2->ts.kind);
9031	size = fold_build2_loc (input_location, MULT_EXPR,
9032	gfc_charlen_type_node,
9033	se.string_length, size);
9034	size = fold_convert (size_type_node, size);
9035	}
9036	else
9037	{
9038	if (expr2->ts.type == BT_DERIVED)
9039	tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
9040	else
9041	tmp = gfc_typenode_for_spec (&expr2->ts);
9042	size = TYPE_SIZE_UNIT (tmp);
9043	}
9044	}
9045	else
9046	{
9047	gfc_expr *e2vtab;
9048	e2vtab = gfc_find_and_cut_at_last_class_ref (e: expr2);
9049	gfc_add_vptr_component (e2vtab);
9050	gfc_add_size_component (e2vtab);
9051	gfc_init_se (se: &se, NULL);
9052	gfc_conv_expr (se: &se, expr: e2vtab);
9053	gfc_add_block_to_block (block, &se.pre);
9054	size = fold_convert (size_type_node, se.expr);
9055	gfc_free_expr (e2vtab);
9056	}
9057	size_in_bytes = size;
9058	}
9059	else
9060	{
9061	/* Otherwise use the length in bytes of the rhs. */
9062	size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
9063	size_in_bytes = size;
9064	}
9065
9066	size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
9067	size_in_bytes, size_one_node);
9068
9069	if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
9070	{
9071	tmp = build_call_expr_loc (input_location,
9072	builtin_decl_explicit (fncode: BUILT_IN_CALLOC),
9073	2, build_one_cst (size_type_node),
9074	size_in_bytes);
9075	tmp = fold_convert (TREE_TYPE (comp), tmp);
9076	gfc_add_modify (block, comp, tmp);
9077	}
9078	else
9079	{
9080	tmp = build_call_expr_loc (input_location,
9081	builtin_decl_explicit (fncode: BUILT_IN_MALLOC),
9082	1, size_in_bytes);
9083	if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
9084	ptr = gfc_class_data_get (decl: comp);
9085	else
9086	ptr = comp;
9087	tmp = fold_convert (TREE_TYPE (ptr), tmp);
9088	gfc_add_modify (block, ptr, tmp);
9089	}
9090
9091	if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9092	/* Update the lhs character length. */
9093	gfc_add_modify (block, lhs_cl_size,
9094	fold_convert (TREE_TYPE (lhs_cl_size), size));
9095	}
9096
9097
9098	/* Assign a single component of a derived type constructor. */
9099
9100	static tree
9101	gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
9102	gfc_expr * expr, bool init)
9103	{
9104	gfc_se se;
9105	gfc_se lse;
9106	stmtblock_t block;
9107	tree tmp;
9108	tree vtab;
9109
9110	gfc_start_block (&block);
9111
9112	if (cm->attr.pointer || cm->attr.proc_pointer)
9113	{
9114	/* Only care about pointers here, not about allocatables. */
9115	gfc_init_se (se: &se, NULL);
9116	/* Pointer component. */
9117	if ((cm->attr.dimension || cm->attr.codimension)
9118	&& !cm->attr.proc_pointer)
9119	{
9120	/* Array pointer. */
9121	if (expr->expr_type == EXPR_NULL)
9122	gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9123	else
9124	{
9125	se.direct_byref = 1;
9126	se.expr = dest;
9127	gfc_conv_expr_descriptor (&se, expr);
9128	gfc_add_block_to_block (&block, &se.pre);
9129	gfc_add_block_to_block (&block, &se.post);
9130	}
9131	}
9132	else
9133	{
9134	/* Scalar pointers. */
9135	se.want_pointer = 1;
9136	gfc_conv_expr (se: &se, expr);
9137	gfc_add_block_to_block (&block, &se.pre);
9138
9139	if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
9140	&& expr->symtree->n.sym->attr.dummy)
9141	se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
9142
9143	gfc_add_modify (&block, dest,
9144	fold_convert (TREE_TYPE (dest), se.expr));
9145	gfc_add_block_to_block (&block, &se.post);
9146	}
9147	}
9148	else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
9149	{
9150	/* NULL initialization for CLASS components. */
9151	tmp = gfc_trans_structure_assign (dest,
9152	gfc_class_initializer (&cm->ts, expr),
9153	false);
9154	gfc_add_expr_to_block (&block, tmp);
9155	}
9156	else if ((cm->attr.dimension || cm->attr.codimension)
9157	&& !cm->attr.proc_pointer)
9158	{
9159	if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
9160	gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9161	else if (cm->attr.allocatable || cm->attr.pdt_array)
9162	{
9163	tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
9164	gfc_add_expr_to_block (&block, tmp);
9165	}
9166	else
9167	{
9168	tmp = gfc_trans_subarray_assign (dest, cm, expr);
9169	gfc_add_expr_to_block (&block, tmp);
9170	}
9171	}
9172	else if (cm->ts.type == BT_CLASS
9173	&& CLASS_DATA (cm)->attr.dimension
9174	&& CLASS_DATA (cm)->attr.allocatable
9175	&& expr->ts.type == BT_DERIVED)
9176	{
9177	vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
9178	vtab = gfc_build_addr_expr (NULL_TREE, vtab);
9179	tmp = gfc_class_vptr_get (decl: dest);
9180	gfc_add_modify (&block, tmp,
9181	fold_convert (TREE_TYPE (tmp), vtab));
9182	tmp = gfc_class_data_get (decl: dest);
9183	tmp = gfc_trans_alloc_subarray_assign (dest: tmp, cm, expr);
9184	gfc_add_expr_to_block (&block, tmp);
9185	}
9186	else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
9187	{
9188	/* NULL initialization for allocatable components. */
9189	gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
9190	null_pointer_node));
9191	}
9192	else if (init && (cm->attr.allocatable
9193	|| (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
9194	&& expr->ts.type != BT_CLASS)))
9195	{
9196	gfc_init_se (se: &se, NULL);
9197	gfc_conv_expr (se: &se, expr);
9198	tree size;
9199
9200	/* Take care about non-array allocatable components here. The alloc_*
9201	routine below is motivated by the alloc_scalar_allocatable_for_
9202	assignment() routine, but with the realloc portions removed and
9203	different input. */
9204	alloc_scalar_allocatable_subcomponent (block: &block, comp: dest, cm, expr2: expr,
9205	slen: se.string_length);
9206	/* The remainder of these instructions follow the if (cm->attr.pointer)
9207	if (!cm->attr.dimension) part above. */
9208	gfc_add_block_to_block (&block, &se.pre);
9209
9210	if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
9211	&& expr->symtree->n.sym->attr.dummy)
9212	se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
9213
9214	if (cm->ts.type == BT_CLASS)
9215	{
9216	tmp = gfc_class_data_get (decl: dest);
9217	tmp = build_fold_indirect_ref_loc (input_location, tmp);
9218	vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
9219	vtab = gfc_build_addr_expr (NULL_TREE, vtab);
9220	gfc_add_modify (&block, gfc_class_vptr_get (decl: dest),
9221	fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
9222	}
9223	else
9224	tmp = build_fold_indirect_ref_loc (input_location, dest);
9225
9226	/* For deferred strings insert a memcpy. */
9227	if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9228	{
9229	gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
9230	size = size_of_string_in_bytes (cm->ts.kind, se.string_length
9231	? se.string_length
9232	: expr->ts.u.cl->backend_decl);
9233	tmp = gfc_build_memcpy_call (tmp, se.expr, size);
9234	gfc_add_expr_to_block (&block, tmp);
9235	}
9236	else if (cm->ts.type == BT_CLASS)
9237	{
9238	/* Fix the expression for memcpy. */
9239	if (expr->expr_type != EXPR_VARIABLE)
9240	se.expr = gfc_evaluate_now (se.expr, &block);
9241
9242	if (expr->ts.type == BT_CHARACTER)
9243	{
9244	size = build_int_cst (gfc_charlen_type_node, expr->ts.kind);
9245	size = fold_build2_loc (input_location, MULT_EXPR,
9246	gfc_charlen_type_node,
9247	se.string_length, size);
9248	size = fold_convert (size_type_node, size);
9249	}
9250	else
9251	size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr->ts));
9252
9253	/* Now copy the expression to the constructor component _data. */
9254	gfc_add_expr_to_block (&block,
9255	gfc_build_memcpy_call (tmp, se.expr, size));
9256
9257	/* Fill the unlimited polymorphic _len field. */
9258	if (UNLIMITED_POLY (cm) && expr->ts.type == BT_CHARACTER)
9259	{
9260	tmp = gfc_class_len_get (decl: gfc_get_class_from_expr (expr: tmp));
9261	gfc_add_modify (&block, tmp,
9262	fold_convert (TREE_TYPE (tmp),
9263	se.string_length));
9264	}
9265	}
9266	else
9267	gfc_add_modify (&block, tmp,
9268	fold_convert (TREE_TYPE (tmp), se.expr));
9269	gfc_add_block_to_block (&block, &se.post);
9270	}
9271	else if (expr->ts.type == BT_UNION)
9272	{
9273	tree tmp;
9274	gfc_constructor *c = gfc_constructor_first (base: expr->value.constructor);
9275	/* We mark that the entire union should be initialized with a contrived
9276	EXPR_NULL expression at the beginning. */
9277	if (c != NULL && c->n.component == NULL
9278	&& c->expr != NULL && c->expr->expr_type == EXPR_NULL)
9279	{
9280	tmp = build2_loc (loc: input_location, code: MODIFY_EXPR, void_type_node,
9281	arg0: dest, arg1: build_constructor (TREE_TYPE (dest), NULL));
9282	gfc_add_expr_to_block (&block, tmp);
9283	c = gfc_constructor_next (ctor: c);
9284	}
9285	/* The following constructor expression, if any, represents a specific
9286	map intializer, as given by the user. */
9287	if (c != NULL && c->expr != NULL)
9288	{
9289	gcc_assert (expr->expr_type == EXPR_STRUCTURE);
9290	tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
9291	gfc_add_expr_to_block (&block, tmp);
9292	}
9293	}
9294	else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
9295	{
9296	if (expr->expr_type != EXPR_STRUCTURE)
9297	{
9298	tree dealloc = NULL_TREE;
9299	gfc_init_se (se: &se, NULL);
9300	gfc_conv_expr (se: &se, expr);
9301	gfc_add_block_to_block (&block, &se.pre);
9302	/* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
9303	expression in a temporary variable and deallocate the allocatable
9304	components. Then we can the copy the expression to the result. */
9305	if (cm->ts.u.derived->attr.alloc_comp
9306	&& expr->expr_type != EXPR_VARIABLE)
9307	{
9308	se.expr = gfc_evaluate_now (se.expr, &block);
9309	dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
9310	expr->rank);
9311	}
9312	gfc_add_modify (&block, dest,
9313	fold_convert (TREE_TYPE (dest), se.expr));
9314	if (cm->ts.u.derived->attr.alloc_comp
9315	&& expr->expr_type != EXPR_NULL)
9316	{
9317	// TODO: Fix caf_mode
9318	tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
9319	dest, expr->rank, 0);
9320	gfc_add_expr_to_block (&block, tmp);
9321	if (dealloc != NULL_TREE)
9322	gfc_add_expr_to_block (&block, dealloc);
9323	}
9324	gfc_add_block_to_block (&block, &se.post);
9325	}
9326	else
9327	{
9328	/* Nested constructors. */
9329	tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
9330	gfc_add_expr_to_block (&block, tmp);
9331	}
9332	}
9333	else if (gfc_deferred_strlen (cm, &tmp))
9334	{
9335	tree strlen;
9336	strlen = tmp;
9337	gcc_assert (strlen);
9338	strlen = fold_build3_loc (input_location, COMPONENT_REF,
9339	TREE_TYPE (strlen),
9340	TREE_OPERAND (dest, 0),
9341	strlen, NULL_TREE);
9342
9343	if (expr->expr_type == EXPR_NULL)
9344	{
9345	tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
9346	gfc_add_modify (&block, dest, tmp);
9347	tmp = build_int_cst (TREE_TYPE (strlen), 0);
9348	gfc_add_modify (&block, strlen, tmp);
9349	}
9350	else
9351	{
9352	tree size;
9353	gfc_init_se (se: &se, NULL);
9354	gfc_conv_expr (se: &se, expr);
9355	size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
9356	tmp = build_call_expr_loc (input_location,
9357	builtin_decl_explicit (fncode: BUILT_IN_MALLOC),
9358	1, size);
9359	gfc_add_modify (&block, dest,
9360	fold_convert (TREE_TYPE (dest), tmp));
9361	gfc_add_modify (&block, strlen,
9362	fold_convert (TREE_TYPE (strlen), se.string_length));
9363	tmp = gfc_build_memcpy_call (dest, se.expr, size);
9364	gfc_add_expr_to_block (&block, tmp);
9365	}
9366	}
9367	else if (!cm->attr.artificial)
9368	{
9369	/* Scalar component (excluding deferred parameters). */
9370	gfc_init_se (se: &se, NULL);
9371	gfc_init_se (se: &lse, NULL);
9372
9373	gfc_conv_expr (se: &se, expr);
9374	if (cm->ts.type == BT_CHARACTER)
9375	lse.string_length = cm->ts.u.cl->backend_decl;
9376	lse.expr = dest;
9377	tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
9378	gfc_add_expr_to_block (&block, tmp);
9379	}
9380	return gfc_finish_block (&block);
9381	}
9382
9383	/* Assign a derived type constructor to a variable. */
9384
9385	tree
9386	gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
9387	{
9388	gfc_constructor *c;
9389	gfc_component *cm;
9390	stmtblock_t block;
9391	tree field;
9392	tree tmp;
9393	gfc_se se;
9394
9395	gfc_start_block (&block);
9396
9397	if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
9398	&& (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
9399	|| expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
9400	{
9401	gfc_se lse;
9402
9403	gfc_init_se (se: &se, NULL);
9404	gfc_init_se (se: &lse, NULL);
9405	gfc_conv_expr (se: &se, expr: gfc_constructor_first (base: expr->value.constructor)->expr);
9406	lse.expr = dest;
9407	gfc_add_modify (&block, lse.expr,
9408	fold_convert (TREE_TYPE (lse.expr), se.expr));
9409
9410	return gfc_finish_block (&block);
9411	}
9412
9413	/* Make sure that the derived type has been completely built. */
9414	if (!expr->ts.u.derived->backend_decl
9415	|| !TYPE_FIELDS (expr->ts.u.derived->backend_decl))
9416	{
9417	tmp = gfc_typenode_for_spec (&expr->ts);
9418	gcc_assert (tmp);
9419	}
9420
9421	cm = expr->ts.u.derived->components;
9422
9423
9424	if (coarray)
9425	gfc_init_se (se: &se, NULL);
9426
9427	for (c = gfc_constructor_first (base: expr->value.constructor);
9428	c; c = gfc_constructor_next (ctor: c), cm = cm->next)
9429	{
9430	/* Skip absent members in default initializers. */
9431	if (!c->expr && !cm->attr.allocatable)
9432	continue;
9433
9434	/* Register the component with the caf-lib before it is initialized.
9435	Register only allocatable components, that are not coarray'ed
9436	components (%comp[*]). Only register when the constructor is not the
9437	null-expression. */
9438	if (coarray && !cm->attr.codimension
9439	&& (cm->attr.allocatable || cm->attr.pointer)
9440	&& (!c->expr || c->expr->expr_type == EXPR_NULL))
9441	{
9442	tree token, desc, size;
9443	bool is_array = cm->ts.type == BT_CLASS
9444	? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
9445
9446	field = cm->backend_decl;
9447	field = fold_build3_loc (input_location, COMPONENT_REF,
9448	TREE_TYPE (field), dest, field, NULL_TREE);
9449	if (cm->ts.type == BT_CLASS)
9450	field = gfc_class_data_get (decl: field);
9451
9452	token = is_array ? gfc_conv_descriptor_token (field)
9453	: fold_build3_loc (input_location, COMPONENT_REF,
9454	TREE_TYPE (cm->caf_token), dest,
9455	cm->caf_token, NULL_TREE);
9456
9457	if (is_array)
9458	{
9459	/* The _caf_register routine looks at the rank of the array
9460	descriptor to decide whether the data registered is an array
9461	or not. */
9462	int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
9463	: cm->as->rank;
9464	/* When the rank is not known just set a positive rank, which
9465	suffices to recognize the data as array. */
9466	if (rank < 0)
9467	rank = 1;
9468	size = build_zero_cst (size_type_node);
9469	desc = field;
9470	gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
9471	build_int_cst (signed_char_type_node, rank));
9472	}
9473	else
9474	{
9475	desc = gfc_conv_scalar_to_descriptor (se: &se, scalar: field,
9476	attr: cm->ts.type == BT_CLASS
9477	? CLASS_DATA (cm)->attr
9478	: cm->attr);
9479	size = TYPE_SIZE_UNIT (TREE_TYPE (field));
9480	}
9481	gfc_add_block_to_block (&block, &se.pre);
9482	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
9483	7, size, build_int_cst (
9484	integer_type_node,
9485	GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
9486	gfc_build_addr_expr (pvoid_type_node,
9487	token),
9488	gfc_build_addr_expr (NULL_TREE, desc),
9489	null_pointer_node, null_pointer_node,
9490	integer_zero_node);
9491	gfc_add_expr_to_block (&block, tmp);
9492	}
9493	field = cm->backend_decl;
9494	gcc_assert(field);
9495	tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
9496	dest, field, NULL_TREE);
9497	if (!c->expr)
9498	{
9499	gfc_expr *e = gfc_get_null_expr (NULL);
9500	tmp = gfc_trans_subcomponent_assign (dest: tmp, cm, expr: e, init);
9501	gfc_free_expr (e);
9502	}
9503	else
9504	tmp = gfc_trans_subcomponent_assign (dest: tmp, cm, expr: c->expr, init);
9505	gfc_add_expr_to_block (&block, tmp);
9506	}
9507	return gfc_finish_block (&block);
9508	}
9509
9510	static void
9511	gfc_conv_union_initializer (vec<constructor_elt, va_gc> *&v,
9512	gfc_component *un, gfc_expr *init)
9513	{
9514	gfc_constructor *ctor;
9515
9516	if (un->ts.type != BT_UNION || un == NULL || init == NULL)
9517	return;
9518
9519	ctor = gfc_constructor_first (base: init->value.constructor);
9520
9521	if (ctor == NULL || ctor->expr == NULL)
9522	return;
9523
9524	gcc_assert (init->expr_type == EXPR_STRUCTURE);
9525
9526	/* If we have an 'initialize all' constructor, do it first. */
9527	if (ctor->expr->expr_type == EXPR_NULL)
9528	{
9529	tree union_type = TREE_TYPE (un->backend_decl);
9530	tree val = build_constructor (union_type, NULL);
9531	CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
9532	ctor = gfc_constructor_next (ctor);
9533	}
9534
9535	/* Add the map initializer on top. */
9536	if (ctor != NULL && ctor->expr != NULL)
9537	{
9538	gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
9539	tree val = gfc_conv_initializer (expr: ctor->expr, ts: &un->ts,
9540	TREE_TYPE (un->backend_decl),
9541	array: un->attr.dimension, pointer: un->attr.pointer,
9542	procptr: un->attr.proc_pointer);
9543	CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
9544	}
9545	}
9546
9547	/* Build an expression for a constructor. If init is nonzero then
9548	this is part of a static variable initializer. */
9549
9550	void
9551	gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
9552	{
9553	gfc_constructor *c;
9554	gfc_component *cm;
9555	tree val;
9556	tree type;
9557	tree tmp;
9558	vec<constructor_elt, va_gc> *v = NULL;
9559
9560	gcc_assert (se->ss == NULL);
9561	gcc_assert (expr->expr_type == EXPR_STRUCTURE);
9562	type = gfc_typenode_for_spec (&expr->ts);
9563
9564	if (!init)
9565	{
9566	/* Create a temporary variable and fill it in. */
9567	se->expr = gfc_create_var (type, expr->ts.u.derived->name);
9568	/* The symtree in expr is NULL, if the code to generate is for
9569	initializing the static members only. */
9570	tmp = gfc_trans_structure_assign (dest: se->expr, expr, init: expr->symtree != NULL,
9571	coarray: se->want_coarray);
9572	gfc_add_expr_to_block (&se->pre, tmp);
9573	return;
9574	}
9575
9576	cm = expr->ts.u.derived->components;
9577
9578	for (c = gfc_constructor_first (base: expr->value.constructor);
9579	c; c = gfc_constructor_next (ctor: c), cm = cm->next)
9580	{
9581	/* Skip absent members in default initializers and allocatable
9582	components. Although the latter have a default initializer
9583	of EXPR_NULL,... by default, the static nullify is not needed
9584	since this is done every time we come into scope. */
9585	if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
9586	continue;
9587
9588	if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
9589	&& strcmp (s1: cm->name, s2: "_extends") == 0
9590	&& cm->initializer->symtree)
9591	{
9592	tree vtab;
9593	gfc_symbol *vtabs;
9594	vtabs = cm->initializer->symtree->n.sym;
9595	vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
9596	vtab = unshare_expr_without_location (vtab);
9597	CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
9598	}
9599	else if (cm->ts.u.derived && strcmp (s1: cm->name, s2: "_size") == 0)
9600	{
9601	val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
9602	CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
9603	fold_convert (TREE_TYPE (cm->backend_decl),
9604	val));
9605	}
9606	else if (cm->ts.type == BT_INTEGER && strcmp (s1: cm->name, s2: "_len") == 0)
9607	CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
9608	fold_convert (TREE_TYPE (cm->backend_decl),
9609	integer_zero_node));
9610	else if (cm->ts.type == BT_UNION)
9611	gfc_conv_union_initializer (v, un: cm, init: c->expr);
9612	else
9613	{
9614	val = gfc_conv_initializer (expr: c->expr, ts: &cm->ts,
9615	TREE_TYPE (cm->backend_decl),
9616	array: cm->attr.dimension, pointer: cm->attr.pointer,
9617	procptr: cm->attr.proc_pointer);
9618	val = unshare_expr_without_location (val);
9619
9620	/* Append it to the constructor list. */
9621	CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
9622	}
9623	}
9624
9625	se->expr = build_constructor (type, v);
9626	if (init)
9627	TREE_CONSTANT (se->expr) = 1;
9628	}
9629
9630
9631	/* Translate a substring expression. */
9632
9633	static void
9634	gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
9635	{
9636	gfc_ref *ref;
9637
9638	ref = expr->ref;
9639
9640	gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
9641
9642	se->expr = gfc_build_wide_string_const (expr->ts.kind,
9643	expr->value.character.length,
9644	expr->value.character.string);
9645
9646	se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
9647	TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
9648
9649	if (ref)
9650	gfc_conv_substring (se, ref, kind: expr->ts.kind, NULL, where: &expr->where);
9651	}
9652
9653
9654	/* Entry point for expression translation. Evaluates a scalar quantity.
9655	EXPR is the expression to be translated, and SE is the state structure if
9656	called from within the scalarized. */
9657
9658	void
9659	gfc_conv_expr (gfc_se * se, gfc_expr * expr)
9660	{
9661	gfc_ss *ss;
9662
9663	ss = se->ss;
9664	if (ss && ss->info->expr == expr
9665	&& (ss->info->type == GFC_SS_SCALAR
9666	|| ss->info->type == GFC_SS_REFERENCE))
9667	{
9668	gfc_ss_info *ss_info;
9669
9670	ss_info = ss->info;
9671	/* Substitute a scalar expression evaluated outside the scalarization
9672	loop. */
9673	se->expr = ss_info->data.scalar.value;
9674	if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
9675	se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
9676
9677	se->string_length = ss_info->string_length;
9678	gfc_advance_se_ss_chain (se);
9679	return;
9680	}
9681
9682	/* We need to convert the expressions for the iso_c_binding derived types.
9683	C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
9684	null_pointer_node. C_PTR and C_FUNPTR are converted to match the
9685	typespec for the C_PTR and C_FUNPTR symbols, which has already been
9686	updated to be an integer with a kind equal to the size of a (void *). */
9687	if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
9688	&& expr->ts.u.derived->attr.is_bind_c)
9689	{
9690	if (expr->expr_type == EXPR_VARIABLE
9691	&& (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
9692	|| expr->symtree->n.sym->intmod_sym_id
9693	== ISOCBINDING_NULL_FUNPTR))
9694	{
9695	/* Set expr_type to EXPR_NULL, which will result in
9696	null_pointer_node being used below. */
9697	expr->expr_type = EXPR_NULL;
9698	}
9699	else
9700	{
9701	/* Update the type/kind of the expression to be what the new
9702	type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
9703	expr->ts.type = BT_INTEGER;
9704	expr->ts.f90_type = BT_VOID;
9705	expr->ts.kind = gfc_index_integer_kind;
9706	}
9707	}
9708
9709	gfc_fix_class_refs (e: expr);
9710
9711	switch (expr->expr_type)
9712	{
9713	case EXPR_OP:
9714	gfc_conv_expr_op (se, expr);
9715	break;
9716
9717	case EXPR_FUNCTION:
9718	gfc_conv_function_expr (se, expr);
9719	break;
9720
9721	case EXPR_CONSTANT:
9722	gfc_conv_constant (se, expr);
9723	break;
9724
9725	case EXPR_VARIABLE:
9726	gfc_conv_variable (se, expr);
9727	break;
9728
9729	case EXPR_NULL:
9730	se->expr = null_pointer_node;
9731	break;
9732
9733	case EXPR_SUBSTRING:
9734	gfc_conv_substring_expr (se, expr);
9735	break;
9736
9737	case EXPR_STRUCTURE:
9738	gfc_conv_structure (se, expr, init: 0);
9739	/* F2008 4.5.6.3 para 5: If an executable construct references a
9740	structure constructor or array constructor, the entity created by
9741	the constructor is finalized after execution of the innermost
9742	executable construct containing the reference. This, in fact,
9743	was later deleted by the Combined Techical Corrigenda 1 TO 4 for
9744	fortran 2008 (f08/0011). */
9745	if (!gfc_notification_std (GFC_STD_F2018_DEL) && expr->must_finalize
9746	&& gfc_may_be_finalized (expr->ts))
9747	{
9748	gfc_warning (opt: 0, "The structure constructor at %C has been"
9749	" finalized. This feature was removed by f08/0011."
9750	" Use -std=f2018 or -std=gnu to eliminate the"
9751	" finalization.");
9752	symbol_attribute attr;
9753	attr.allocatable = attr.pointer = 0;
9754	gfc_finalize_tree_expr (se, expr->ts.u.derived, attr, 0);
9755	gfc_add_block_to_block (&se->post, &se->finalblock);
9756	}
9757	break;
9758
9759	case EXPR_ARRAY:
9760	gfc_conv_array_constructor_expr (se, expr);
9761	gfc_add_block_to_block (&se->post, &se->finalblock);
9762	break;
9763
9764	default:
9765	gcc_unreachable ();
9766	break;
9767	}
9768	}
9769
9770	/* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
9771	of an assignment. */
9772	void
9773	gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
9774	{
9775	gfc_conv_expr (se, expr);
9776	/* All numeric lvalues should have empty post chains. If not we need to
9777	figure out a way of rewriting an lvalue so that it has no post chain. */
9778	gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
9779	}
9780
9781	/* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
9782	numeric expressions. Used for scalar values where inserting cleanup code
9783	is inconvenient. */
9784	void
9785	gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
9786	{
9787	tree val;
9788
9789	gcc_assert (expr->ts.type != BT_CHARACTER);
9790	gfc_conv_expr (se, expr);
9791	if (se->post.head)
9792	{
9793	val = gfc_create_var (TREE_TYPE (se->expr), NULL);
9794	gfc_add_modify (&se->pre, val, se->expr);
9795	se->expr = val;
9796	gfc_add_block_to_block (&se->pre, &se->post);
9797	}
9798	}
9799
9800	/* Helper to translate an expression and convert it to a particular type. */
9801	void
9802	gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
9803	{
9804	gfc_conv_expr_val (se, expr);
9805	se->expr = convert (type, se->expr);
9806	}
9807
9808
9809	/* Converts an expression so that it can be passed by reference. Scalar
9810	values only. */
9811
9812	void
9813	gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
9814	{
9815	gfc_ss *ss;
9816	tree var;
9817
9818	ss = se->ss;
9819	if (ss && ss->info->expr == expr
9820	&& ss->info->type == GFC_SS_REFERENCE)
9821	{
9822	/* Returns a reference to the scalar evaluated outside the loop
9823	for this case. */
9824	gfc_conv_expr (se, expr);
9825
9826	if (expr->ts.type == BT_CHARACTER
9827	&& expr->expr_type != EXPR_FUNCTION)
9828	gfc_conv_string_parameter (se);
9829	else
9830	se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
9831
9832	return;
9833	}
9834
9835	if (expr->ts.type == BT_CHARACTER)
9836	{
9837	gfc_conv_expr (se, expr);
9838	gfc_conv_string_parameter (se);
9839	return;
9840	}
9841
9842	if (expr->expr_type == EXPR_VARIABLE)
9843	{
9844	se->want_pointer = 1;
9845	gfc_conv_expr (se, expr);
9846	if (se->post.head)
9847	{
9848	var = gfc_create_var (TREE_TYPE (se->expr), NULL);
9849	gfc_add_modify (&se->pre, var, se->expr);
9850	gfc_add_block_to_block (&se->pre, &se->post);
9851	se->expr = var;
9852	}
9853	return;
9854	}
9855
9856	if (expr->expr_type == EXPR_FUNCTION
9857	&& ((expr->value.function.esym
9858	&& expr->value.function.esym->result
9859	&& expr->value.function.esym->result->attr.pointer
9860	&& !expr->value.function.esym->result->attr.dimension)
9861	|| (!expr->value.function.esym && !expr->ref
9862	&& expr->symtree->n.sym->attr.pointer
9863	&& !expr->symtree->n.sym->attr.dimension)))
9864	{
9865	se->want_pointer = 1;
9866	gfc_conv_expr (se, expr);
9867	var = gfc_create_var (TREE_TYPE (se->expr), NULL);
9868	gfc_add_modify (&se->pre, var, se->expr);
9869	se->expr = var;
9870	return;
9871	}
9872
9873	gfc_conv_expr (se, expr);
9874
9875	/* Create a temporary var to hold the value. */
9876	if (TREE_CONSTANT (se->expr))
9877	{
9878	tree tmp = se->expr;
9879	STRIP_TYPE_NOPS (tmp);
9880	var = build_decl (input_location,
9881	CONST_DECL, NULL, TREE_TYPE (tmp));
9882	DECL_INITIAL (var) = tmp;
9883	TREE_STATIC (var) = 1;
9884	pushdecl (var);
9885	}
9886	else
9887	{
9888	var = gfc_create_var (TREE_TYPE (se->expr), NULL);
9889	gfc_add_modify (&se->pre, var, se->expr);
9890	}
9891
9892	if (!expr->must_finalize)
9893	gfc_add_block_to_block (&se->pre, &se->post);
9894
9895	/* Take the address of that value. */
9896	se->expr = gfc_build_addr_expr (NULL_TREE, var);
9897	}
9898
9899
9900	/* Get the _len component for an unlimited polymorphic expression. */
9901
9902	static tree
9903	trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
9904	{
9905	gfc_se se;
9906	gfc_ref *ref = expr->ref;
9907
9908	gfc_init_se (se: &se, NULL);
9909	while (ref && ref->next)
9910	ref = ref->next;
9911	gfc_add_len_component (expr);
9912	gfc_conv_expr (se: &se, expr);
9913	gfc_add_block_to_block (block, &se.pre);
9914	gcc_assert (se.post.head == NULL_TREE);
9915	if (ref)
9916	{
9917	gfc_free_ref_list (ref->next);
9918	ref->next = NULL;
9919	}
9920	else
9921	{
9922	gfc_free_ref_list (expr->ref);
9923	expr->ref = NULL;
9924	}
9925	return se.expr;
9926	}
9927
9928
9929	/* Assign _vptr and _len components as appropriate. BLOCK should be a
9930	statement-list outside of the scalarizer-loop. When code is generated, that
9931	depends on the scalarized expression, it is added to RSE.PRE.
9932	Returns le's _vptr tree and when set the len expressions in to_lenp and
9933	from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
9934	expression. */
9935
9936	static tree
9937	trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
9938	gfc_expr * re, gfc_se *rse,
9939	tree * to_lenp, tree * from_lenp)
9940	{
9941	gfc_se se;
9942	gfc_expr * vptr_expr;
9943	tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
9944	bool set_vptr = false, temp_rhs = false;
9945	stmtblock_t *pre = block;
9946	tree class_expr = NULL_TREE;
9947
9948	/* Create a temporary for complicated expressions. */
9949	if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
9950	&& rse->expr != NULL_TREE && !DECL_P (rse->expr))
9951	{
9952	if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
9953	class_expr = gfc_get_class_from_expr (expr: rse->expr);
9954
9955	if (rse->loop)
9956	pre = &rse->loop->pre;
9957	else
9958	pre = &rse->pre;
9959
9960	if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
9961	{
9962	tmp = TREE_OPERAND (rse->expr, 0);
9963	tmp = gfc_create_var (TREE_TYPE (tmp), "rhs");
9964	gfc_add_modify (&rse->pre, tmp, TREE_OPERAND (rse->expr, 0));
9965	}
9966	else
9967	{
9968	tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
9969	gfc_add_modify (&rse->pre, tmp, rse->expr);
9970	}
9971
9972	rse->expr = tmp;
9973	temp_rhs = true;
9974	}
9975
9976	/* Get the _vptr for the left-hand side expression. */
9977	gfc_init_se (se: &se, NULL);
9978	vptr_expr = gfc_find_and_cut_at_last_class_ref (e: le);
9979	if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
9980	{
9981	/* Care about _len for unlimited polymorphic entities. */
9982	if (UNLIMITED_POLY (vptr_expr)
9983	|| (vptr_expr->ts.type == BT_DERIVED
9984	&& vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
9985	to_len = trans_get_upoly_len (block, expr: vptr_expr);
9986	gfc_add_vptr_component (vptr_expr);
9987	set_vptr = true;
9988	}
9989	else
9990	vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
9991	se.want_pointer = 1;
9992	gfc_conv_expr (se: &se, expr: vptr_expr);
9993	gfc_free_expr (vptr_expr);
9994	gfc_add_block_to_block (block, &se.pre);
9995	gcc_assert (se.post.head == NULL_TREE);
9996	lhs_vptr = se.expr;
9997	STRIP_NOPS (lhs_vptr);
9998
9999	/* Set the _vptr only when the left-hand side of the assignment is a
10000	class-object. */
10001	if (set_vptr)
10002	{
10003	/* Get the vptr from the rhs expression only, when it is variable.
10004	Functions are expected to be assigned to a temporary beforehand. */
10005	vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
10006	? gfc_find_and_cut_at_last_class_ref (e: re)
10007	: NULL;
10008	if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
10009	{
10010	if (to_len != NULL_TREE)
10011	{
10012	/* Get the _len information from the rhs. */
10013	if (UNLIMITED_POLY (vptr_expr)
10014	|| (vptr_expr->ts.type == BT_DERIVED
10015	&& vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
10016	from_len = trans_get_upoly_len (block, expr: vptr_expr);
10017	}
10018	gfc_add_vptr_component (vptr_expr);
10019	}
10020	else
10021	{
10022	if (re->expr_type == EXPR_VARIABLE
10023	&& DECL_P (re->symtree->n.sym->backend_decl)
10024	&& DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
10025	&& GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
10026	&& GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
10027	re->symtree->n.sym->backend_decl))))
10028	{
10029	vptr_expr = NULL;
10030	se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
10031	re->symtree->n.sym->backend_decl));
10032	if (to_len)
10033	from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
10034	re->symtree->n.sym->backend_decl));
10035	}
10036	else if (temp_rhs && re->ts.type == BT_CLASS)
10037	{
10038	vptr_expr = NULL;
10039	if (class_expr)
10040	tmp = class_expr;
10041	else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
10042	tmp = gfc_get_class_from_expr (expr: rse->expr);
10043	else
10044	tmp = rse->expr;
10045
10046	se.expr = gfc_class_vptr_get (decl: tmp);
10047	if (UNLIMITED_POLY (re))
10048	from_len = gfc_class_len_get (decl: tmp);
10049
10050	}
10051	else if (re->expr_type != EXPR_NULL)
10052	/* Only when rhs is non-NULL use its declared type for vptr
10053	initialisation. */
10054	vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
10055	else
10056	/* When the rhs is NULL use the vtab of lhs' declared type. */
10057	vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
10058	}
10059
10060	if (vptr_expr)
10061	{
10062	gfc_init_se (se: &se, NULL);
10063	se.want_pointer = 1;
10064	gfc_conv_expr (se: &se, expr: vptr_expr);
10065	gfc_free_expr (vptr_expr);
10066	gfc_add_block_to_block (block, &se.pre);
10067	gcc_assert (se.post.head == NULL_TREE);
10068	}
10069	gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
10070	se.expr));
10071
10072	if (to_len != NULL_TREE)
10073	{
10074	/* The _len component needs to be set. Figure how to get the
10075	value of the right-hand side. */
10076	if (from_len == NULL_TREE)
10077	{
10078	if (rse->string_length != NULL_TREE)
10079	from_len = rse->string_length;
10080	else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
10081	{
10082	gfc_init_se (se: &se, NULL);
10083	gfc_conv_expr (se: &se, expr: re->ts.u.cl->length);
10084	gfc_add_block_to_block (block, &se.pre);
10085	gcc_assert (se.post.head == NULL_TREE);
10086	from_len = gfc_evaluate_now (se.expr, block);
10087	}
10088	else
10089	from_len = build_zero_cst (gfc_charlen_type_node);
10090	}
10091	gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
10092	from_len));
10093	}
10094	}
10095
10096	/* Return the _len trees only, when requested. */
10097	if (to_lenp)
10098	*to_lenp = to_len;
10099	if (from_lenp)
10100	*from_lenp = from_len;
10101	return lhs_vptr;
10102	}
10103
10104
10105	/* Assign tokens for pointer components. */
10106
10107	static void
10108	trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
10109	gfc_expr *expr2)
10110	{
10111	symbol_attribute lhs_attr, rhs_attr;
10112	tree tmp, lhs_tok, rhs_tok;
10113	/* Flag to indicated component refs on the rhs. */
10114	bool rhs_cr;
10115
10116	lhs_attr = gfc_caf_attr (expr1);
10117	if (expr2->expr_type != EXPR_NULL)
10118	{
10119	rhs_attr = gfc_caf_attr (expr2, i: false, r: &rhs_cr);
10120	if (lhs_attr.codimension && rhs_attr.codimension)
10121	{
10122	lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (outerse: lse, expr: expr1);
10123	lhs_tok = build_fold_indirect_ref (lhs_tok);
10124
10125	if (rhs_cr)
10126	rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (outerse: rse, expr: expr2);
10127	else
10128	{
10129	tree caf_decl;
10130	caf_decl = gfc_get_tree_for_caf_expr (expr: expr2);
10131	gfc_get_caf_token_offset (se: rse, token: &rhs_tok, NULL, caf_decl,
10132	NULL_TREE, NULL);
10133	}
10134	tmp = build2_loc (loc: input_location, code: MODIFY_EXPR, void_type_node,
10135	arg0: lhs_tok,
10136	fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
10137	gfc_prepend_expr_to_block (&lse->post, tmp);
10138	}
10139	}
10140	else if (lhs_attr.codimension)
10141	{
10142	lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (outerse: lse, expr: expr1);
10143	lhs_tok = build_fold_indirect_ref (lhs_tok);
10144	tmp = build2_loc (loc: input_location, code: MODIFY_EXPR, void_type_node,
10145	arg0: lhs_tok, null_pointer_node);
10146	gfc_prepend_expr_to_block (&lse->post, tmp);
10147	}
10148	}
10149
10150
10151	/* Do everything that is needed for a CLASS function expr2. */
10152
10153	static tree
10154	trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
10155	gfc_expr *expr1, gfc_expr *expr2)
10156	{
10157	tree expr1_vptr = NULL_TREE;
10158	tree tmp;
10159
10160	gfc_conv_function_expr (se: rse, expr: expr2);
10161	rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
10162
10163	if (expr1->ts.type != BT_CLASS)
10164	rse->expr = gfc_class_data_get (decl: rse->expr);
10165	else
10166	{
10167	expr1_vptr = trans_class_vptr_len_assignment (block, le: expr1,
10168	re: expr2, rse,
10169	NULL, NULL);
10170	gfc_add_block_to_block (block, &rse->pre);
10171	tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
10172	gfc_add_modify (&lse->pre, tmp, rse->expr);
10173
10174	gfc_add_modify (&lse->pre, expr1_vptr,
10175	fold_convert (TREE_TYPE (expr1_vptr),
10176	gfc_class_vptr_get (tmp)));
10177	rse->expr = gfc_class_data_get (decl: tmp);
10178	}
10179
10180	return expr1_vptr;
10181	}
10182
10183
10184	tree
10185	gfc_trans_pointer_assign (gfc_code * code)
10186	{
10187	return gfc_trans_pointer_assignment (code->expr1, code->expr2);
10188	}
10189
10190
10191	/* Generate code for a pointer assignment. */
10192
10193	tree
10194	gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
10195	{
10196	gfc_se lse;
10197	gfc_se rse;
10198	stmtblock_t block;
10199	tree desc;
10200	tree tmp;
10201	tree expr1_vptr = NULL_TREE;
10202	bool scalar, non_proc_ptr_assign;
10203	gfc_ss *ss;
10204
10205	gfc_start_block (&block);
10206
10207	gfc_init_se (se: &lse, NULL);
10208
10209	/* Usually testing whether this is not a proc pointer assignment. */
10210	non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer
10211	&& expr2->expr_type == EXPR_VARIABLE
10212	&& expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE);
10213
10214	/* Check whether the expression is a scalar or not; we cannot use
10215	expr1->rank as it can be nonzero for proc pointers. */
10216	ss = gfc_walk_expr (expr1);
10217	scalar = ss == gfc_ss_terminator;
10218	if (!scalar)
10219	gfc_free_ss_chain (ss);
10220
10221	if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
10222	&& expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
10223	{
10224	gfc_add_data_component (expr2);
10225	/* The following is required as gfc_add_data_component doesn't
10226	update ts.type if there is a trailing REF_ARRAY. */
10227	expr2->ts.type = BT_DERIVED;
10228	}
10229
10230	if (scalar)
10231	{
10232	/* Scalar pointers. */
10233	lse.want_pointer = 1;
10234	gfc_conv_expr (se: &lse, expr: expr1);
10235	gfc_init_se (se: &rse, NULL);
10236	rse.want_pointer = 1;
10237	if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
10238	trans_class_pointer_fcn (block: &block, lse: &lse, rse: &rse, expr1, expr2);
10239	else
10240	gfc_conv_expr (se: &rse, expr: expr2);
10241
10242	if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
10243	{
10244	trans_class_vptr_len_assignment (block: &block, le: expr1, re: expr2, rse: &rse, NULL,
10245	NULL);
10246	lse.expr = gfc_class_data_get (decl: lse.expr);
10247	}
10248
10249	if (expr1->symtree->n.sym->attr.proc_pointer
10250	&& expr1->symtree->n.sym->attr.dummy)
10251	lse.expr = build_fold_indirect_ref_loc (input_location,
10252	lse.expr);
10253
10254	if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
10255	&& expr2->symtree->n.sym->attr.dummy)
10256	rse.expr = build_fold_indirect_ref_loc (input_location,
10257	rse.expr);
10258
10259	gfc_add_block_to_block (&block, &lse.pre);
10260	gfc_add_block_to_block (&block, &rse.pre);
10261
10262	/* Check character lengths if character expression. The test is only
10263	really added if -fbounds-check is enabled. Exclude deferred
10264	character length lefthand sides. */
10265	if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
10266	&& !expr1->ts.deferred
10267	&& !expr1->symtree->n.sym->attr.proc_pointer
10268	&& !gfc_is_proc_ptr_comp (expr1))
10269	{
10270	gcc_assert (expr2->ts.type == BT_CHARACTER);
10271	gcc_assert (lse.string_length && rse.string_length);
10272	gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
10273	lse.string_length, rse.string_length,
10274	&block);
10275	}
10276
10277	/* The assignment to an deferred character length sets the string
10278	length to that of the rhs. */
10279	if (expr1->ts.deferred)
10280	{
10281	if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
10282	gfc_add_modify (&block, lse.string_length,
10283	fold_convert (TREE_TYPE (lse.string_length),
10284	rse.string_length));
10285	else if (lse.string_length != NULL)
10286	gfc_add_modify (&block, lse.string_length,
10287	build_zero_cst (TREE_TYPE (lse.string_length)));
10288	}
10289
10290	gfc_add_modify (&block, lse.expr,
10291	fold_convert (TREE_TYPE (lse.expr), rse.expr));
10292
10293	/* Also set the tokens for pointer components in derived typed
10294	coarrays. */
10295	if (flag_coarray == GFC_FCOARRAY_LIB)
10296	trans_caf_token_assign (lse: &lse, rse: &rse, expr1, expr2);
10297
10298	gfc_add_block_to_block (&block, &rse.post);
10299	gfc_add_block_to_block (&block, &lse.post);
10300	}
10301	else
10302	{
10303	gfc_ref* remap;
10304	bool rank_remap;
10305	tree strlen_lhs;
10306	tree strlen_rhs = NULL_TREE;
10307
10308	/* Array pointer. Find the last reference on the LHS and if it is an
10309	array section ref, we're dealing with bounds remapping. In this case,
10310	set it to AR_FULL so that gfc_conv_expr_descriptor does
10311	not see it and process the bounds remapping afterwards explicitly. */
10312	for (remap = expr1->ref; remap; remap = remap->next)
10313	if (!remap->next && remap->type == REF_ARRAY
10314	&& remap->u.ar.type == AR_SECTION)
10315	break;
10316	rank_remap = (remap && remap->u.ar.end[0]);
10317
10318	if (remap && expr2->expr_type == EXPR_NULL)
10319	{
10320	gfc_error ("If bounds remapping is specified at %L, "
10321	"the pointer target shall not be NULL", &expr1->where);
10322	return NULL_TREE;
10323	}
10324
10325	gfc_init_se (se: &lse, NULL);
10326	if (remap)
10327	lse.descriptor_only = 1;
10328	gfc_conv_expr_descriptor (&lse, expr1);
10329	strlen_lhs = lse.string_length;
10330	desc = lse.expr;
10331
10332	if (expr2->expr_type == EXPR_NULL)
10333	{
10334	/* Just set the data pointer to null. */
10335	gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
10336	}
10337	else if (rank_remap)
10338	{
10339	/* If we are rank-remapping, just get the RHS's descriptor and
10340	process this later on. */
10341	gfc_init_se (se: &rse, NULL);
10342	rse.direct_byref = 1;
10343	rse.byref_noassign = 1;
10344
10345	if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
10346	expr1_vptr = trans_class_pointer_fcn (block: &block, lse: &lse, rse: &rse,
10347	expr1, expr2);
10348	else if (expr2->expr_type == EXPR_FUNCTION)
10349	{
10350	tree bound[GFC_MAX_DIMENSIONS];
10351	int i;
10352
10353	for (i = 0; i < expr2->rank; i++)
10354	bound[i] = NULL_TREE;
10355	tmp = gfc_typenode_for_spec (&expr2->ts);
10356	tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
10357	bound, bound, 0,
10358	GFC_ARRAY_POINTER_CONT, false);
10359	tmp = gfc_create_var (tmp, "ptrtemp");
10360	rse.descriptor_only = 0;
10361	rse.expr = tmp;
10362	rse.direct_byref = 1;
10363	gfc_conv_expr_descriptor (&rse, expr2);
10364	strlen_rhs = rse.string_length;
10365	rse.expr = tmp;
10366	}
10367	else
10368	{
10369	gfc_conv_expr_descriptor (&rse, expr2);
10370	strlen_rhs = rse.string_length;
10371	if (expr1->ts.type == BT_CLASS)
10372	expr1_vptr = trans_class_vptr_len_assignment (block: &block, le: expr1,
10373	re: expr2, rse: &rse,
10374	NULL, NULL);
10375	}
10376	}
10377	else if (expr2->expr_type == EXPR_VARIABLE)
10378	{
10379	/* Assign directly to the LHS's descriptor. */
10380	lse.descriptor_only = 0;
10381	lse.direct_byref = 1;
10382	gfc_conv_expr_descriptor (&lse, expr2);
10383	strlen_rhs = lse.string_length;
10384	gfc_init_se (se: &rse, NULL);
10385
10386	if (expr1->ts.type == BT_CLASS)
10387	{
10388	rse.expr = NULL_TREE;
10389	rse.string_length = strlen_rhs;
10390	trans_class_vptr_len_assignment (block: &block, le: expr1, re: expr2, rse: &rse,
10391	NULL, NULL);
10392	}
10393
10394	if (remap == NULL)
10395	{
10396	/* If the target is not a whole array, use the target array
10397	reference for remap. */
10398	for (remap = expr2->ref; remap; remap = remap->next)
10399	if (remap->type == REF_ARRAY
10400	&& remap->u.ar.type == AR_FULL
10401	&& remap->next)
10402	break;
10403	}
10404	}
10405	else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
10406	{
10407	gfc_init_se (se: &rse, NULL);
10408	rse.want_pointer = 1;
10409	gfc_conv_function_expr (se: &rse, expr: expr2);
10410	if (expr1->ts.type != BT_CLASS)
10411	{
10412	rse.expr = gfc_class_data_get (decl: rse.expr);
10413	gfc_add_modify (&lse.pre, desc, rse.expr);
10414	/* Set the lhs span. */
10415	tmp = TREE_TYPE (rse.expr);
10416	tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
10417	tmp = fold_convert (gfc_array_index_type, tmp);
10418	gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
10419	}
10420	else
10421	{
10422	expr1_vptr = trans_class_vptr_len_assignment (block: &block, le: expr1,
10423	re: expr2, rse: &rse, NULL,
10424	NULL);
10425	gfc_add_block_to_block (&block, &rse.pre);
10426	tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
10427	gfc_add_modify (&lse.pre, tmp, rse.expr);
10428
10429	gfc_add_modify (&lse.pre, expr1_vptr,
10430	fold_convert (TREE_TYPE (expr1_vptr),
10431	gfc_class_vptr_get (tmp)));
10432	rse.expr = gfc_class_data_get (decl: tmp);
10433	gfc_add_modify (&lse.pre, desc, rse.expr);
10434	}
10435	}
10436	else
10437	{
10438	/* Assign to a temporary descriptor and then copy that
10439	temporary to the pointer. */
10440	tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
10441	lse.descriptor_only = 0;
10442	lse.expr = tmp;
10443	lse.direct_byref = 1;
10444	gfc_conv_expr_descriptor (&lse, expr2);
10445	strlen_rhs = lse.string_length;
10446	gfc_add_modify (&lse.pre, desc, tmp);
10447	}
10448
10449	if (expr1->ts.type == BT_CHARACTER
10450	&& expr1->ts.deferred)
10451	{
10452	gfc_symbol *psym = expr1->symtree->n.sym;
10453	tmp = NULL_TREE;
10454	if (psym->ts.type == BT_CHARACTER)
10455	{
10456	gcc_assert (psym->ts.u.cl->backend_decl
10457	&& VAR_P (psym->ts.u.cl->backend_decl));
10458	tmp = psym->ts.u.cl->backend_decl;
10459	}
10460	else if (expr1->ts.u.cl->backend_decl
10461	&& VAR_P (expr1->ts.u.cl->backend_decl))
10462	tmp = expr1->ts.u.cl->backend_decl;
10463	else if (TREE_CODE (lse.expr) == COMPONENT_REF)
10464	{
10465	gfc_ref *ref = expr1->ref;
10466	for (;ref; ref = ref->next)
10467	{
10468	if (ref->type == REF_COMPONENT
10469	&& ref->u.c.component->ts.type == BT_CHARACTER
10470	&& gfc_deferred_strlen (ref->u.c.component, &tmp))
10471	tmp = fold_build3_loc (input_location, COMPONENT_REF,
10472	TREE_TYPE (tmp),
10473	TREE_OPERAND (lse.expr, 0),
10474	tmp, NULL_TREE);
10475	}
10476	}
10477
10478	gcc_assert (tmp);
10479
10480	if (expr2->expr_type != EXPR_NULL)
10481	gfc_add_modify (&block, tmp,
10482	fold_convert (TREE_TYPE (tmp), strlen_rhs));
10483	else
10484	gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
10485	}
10486
10487	gfc_add_block_to_block (&block, &lse.pre);
10488	if (rank_remap)
10489	gfc_add_block_to_block (&block, &rse.pre);
10490
10491	/* If we do bounds remapping, update LHS descriptor accordingly. */
10492	if (remap)
10493	{
10494	int dim;
10495	gcc_assert (remap->u.ar.dimen == expr1->rank);
10496
10497	if (rank_remap)
10498	{
10499	/* Do rank remapping. We already have the RHS's descriptor
10500	converted in rse and now have to build the correct LHS
10501	descriptor for it. */
10502
10503	tree dtype, data, span;
10504	tree offs, stride;
10505	tree lbound, ubound;
10506
10507	/* Set dtype. */
10508	dtype = gfc_conv_descriptor_dtype (desc);
10509	tmp = gfc_get_dtype (TREE_TYPE (desc));
10510	gfc_add_modify (&block, dtype, tmp);
10511
10512	/* Copy data pointer. */
10513	data = gfc_conv_descriptor_data_get (rse.expr);
10514	gfc_conv_descriptor_data_set (&block, desc, data);
10515
10516	/* Copy the span. */
10517	if (VAR_P (rse.expr)
10518	&& GFC_DECL_PTR_ARRAY_P (rse.expr))
10519	span = gfc_conv_descriptor_span_get (rse.expr);
10520	else
10521	{
10522	tmp = TREE_TYPE (rse.expr);
10523	tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
10524	span = fold_convert (gfc_array_index_type, tmp);
10525	}
10526	gfc_conv_descriptor_span_set (&block, desc, span);
10527
10528	/* Copy offset but adjust it such that it would correspond
10529	to a lbound of zero. */
10530	offs = gfc_conv_descriptor_offset_get (rse.expr);
10531	for (dim = 0; dim < expr2->rank; ++dim)
10532	{
10533	stride = gfc_conv_descriptor_stride_get (rse.expr,
10534	gfc_rank_cst[dim]);
10535	lbound = gfc_conv_descriptor_lbound_get (rse.expr,
10536	gfc_rank_cst[dim]);
10537	tmp = fold_build2_loc (input_location, MULT_EXPR,
10538	gfc_array_index_type, stride, lbound);
10539	offs = fold_build2_loc (input_location, PLUS_EXPR,
10540	gfc_array_index_type, offs, tmp);
10541	}
10542	gfc_conv_descriptor_offset_set (&block, desc, offs);
10543
10544	/* Set the bounds as declared for the LHS and calculate strides as
10545	well as another offset update accordingly. */
10546	stride = gfc_conv_descriptor_stride_get (rse.expr,
10547	gfc_rank_cst[0]);
10548	for (dim = 0; dim < expr1->rank; ++dim)
10549	{
10550	gfc_se lower_se;
10551	gfc_se upper_se;
10552
10553	gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
10554
10555	/* Convert declared bounds. */
10556	gfc_init_se (se: &lower_se, NULL);
10557	gfc_init_se (se: &upper_se, NULL);
10558	gfc_conv_expr (se: &lower_se, expr: remap->u.ar.start[dim]);
10559	gfc_conv_expr (se: &upper_se, expr: remap->u.ar.end[dim]);
10560
10561	gfc_add_block_to_block (&block, &lower_se.pre);
10562	gfc_add_block_to_block (&block, &upper_se.pre);
10563
10564	lbound = fold_convert (gfc_array_index_type, lower_se.expr);
10565	ubound = fold_convert (gfc_array_index_type, upper_se.expr);
10566
10567	lbound = gfc_evaluate_now (lbound, &block);
10568	ubound = gfc_evaluate_now (ubound, &block);
10569
10570	gfc_add_block_to_block (&block, &lower_se.post);
10571	gfc_add_block_to_block (&block, &upper_se.post);
10572
10573	/* Set bounds in descriptor. */
10574	gfc_conv_descriptor_lbound_set (&block, desc,
10575	gfc_rank_cst[dim], lbound);
10576	gfc_conv_descriptor_ubound_set (&block, desc,
10577	gfc_rank_cst[dim], ubound);
10578
10579	/* Set stride. */
10580	stride = gfc_evaluate_now (stride, &block);
10581	gfc_conv_descriptor_stride_set (&block, desc,
10582	gfc_rank_cst[dim], stride);
10583
10584	/* Update offset. */
10585	offs = gfc_conv_descriptor_offset_get (desc);
10586	tmp = fold_build2_loc (input_location, MULT_EXPR,
10587	gfc_array_index_type, lbound, stride);
10588	offs = fold_build2_loc (input_location, MINUS_EXPR,
10589	gfc_array_index_type, offs, tmp);
10590	offs = gfc_evaluate_now (offs, &block);
10591	gfc_conv_descriptor_offset_set (&block, desc, offs);
10592
10593	/* Update stride. */
10594	tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
10595	stride = fold_build2_loc (input_location, MULT_EXPR,
10596	gfc_array_index_type, stride, tmp);
10597	}
10598	}
10599	else
10600	{
10601	/* Bounds remapping. Just shift the lower bounds. */
10602
10603	gcc_assert (expr1->rank == expr2->rank);
10604
10605	for (dim = 0; dim < remap->u.ar.dimen; ++dim)
10606	{
10607	gfc_se lbound_se;
10608
10609	gcc_assert (!remap->u.ar.end[dim]);
10610	gfc_init_se (se: &lbound_se, NULL);
10611	if (remap->u.ar.start[dim])
10612	{
10613	gfc_conv_expr (se: &lbound_se, expr: remap->u.ar.start[dim]);
10614	gfc_add_block_to_block (&block, &lbound_se.pre);
10615	}
10616	else
10617	/* This remap arises from a target that is not a whole
10618	array. The start expressions will be NULL but we need
10619	the lbounds to be one. */
10620	lbound_se.expr = gfc_index_one_node;
10621	gfc_conv_shift_descriptor_lbound (&block, desc,
10622	dim, lbound_se.expr);
10623	gfc_add_block_to_block (&block, &lbound_se.post);
10624	}
10625	}
10626	}
10627
10628	/* If rank remapping was done, check with -fcheck=bounds that
10629	the target is at least as large as the pointer. */
10630	if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
10631	{
10632	tree lsize, rsize;
10633	tree fault;
10634	const char* msg;
10635
10636	lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
10637	rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
10638
10639	lsize = gfc_evaluate_now (lsize, &block);
10640	rsize = gfc_evaluate_now (rsize, &block);
10641	fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
10642	rsize, lsize);
10643
10644	msg = _("Target of rank remapping is too small (%ld < %ld)");
10645	gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
10646	msg, rsize, lsize);
10647	}
10648
10649	/* Check string lengths if applicable. The check is only really added
10650	to the output code if -fbounds-check is enabled. */
10651	if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
10652	{
10653	gcc_assert (expr2->ts.type == BT_CHARACTER);
10654	gcc_assert (strlen_lhs && strlen_rhs);
10655	gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
10656	strlen_lhs, strlen_rhs, &block);
10657	}
10658
10659	gfc_add_block_to_block (&block, &lse.post);
10660	if (rank_remap)
10661	gfc_add_block_to_block (&block, &rse.post);
10662	}
10663
10664	return gfc_finish_block (&block);
10665	}
10666
10667
10668	/* Makes sure se is suitable for passing as a function string parameter. */
10669	/* TODO: Need to check all callers of this function. It may be abused. */
10670
10671	void
10672	gfc_conv_string_parameter (gfc_se * se)
10673	{
10674	tree type;
10675
10676	if (TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE
10677	&& integer_onep (se->string_length))
10678	{
10679	se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
10680	return;
10681	}
10682
10683	if (TREE_CODE (se->expr) == STRING_CST)
10684	{
10685	type = TREE_TYPE (TREE_TYPE (se->expr));
10686	se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
10687	return;
10688	}
10689
10690	if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
10691	|| TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
10692	&& TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
10693	{
10694	type = TREE_TYPE (se->expr);
10695	if (TREE_CODE (se->expr) != INDIRECT_REF)
10696	se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
10697	else
10698	{
10699	if (TREE_CODE (type) == ARRAY_TYPE)
10700	type = TREE_TYPE (type);
10701	type = gfc_get_character_type_len_for_eltype (type,
10702	se->string_length);
10703	type = build_pointer_type (type);
10704	se->expr = gfc_build_addr_expr (type, se->expr);
10705	}
10706	}
10707
10708	gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
10709	}
10710
10711
10712	/* Generate code for assignment of scalar variables. Includes character
10713	strings and derived types with allocatable components.
10714	If you know that the LHS has no allocations, set dealloc to false.
10715
10716	DEEP_COPY has no effect if the typespec TS is not a derived type with
10717	allocatable components. Otherwise, if it is set, an explicit copy of each
10718	allocatable component is made. This is necessary as a simple copy of the
10719	whole object would copy array descriptors as is, so that the lhs's
10720	allocatable components would point to the rhs's after the assignment.
10721	Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
10722	necessary if the rhs is a non-pointer function, as the allocatable components
10723	are not accessible by other means than the function's result after the
10724	function has returned. It is even more subtle when temporaries are involved,
10725	as the two following examples show:
10726	1. When we evaluate an array constructor, a temporary is created. Thus
10727	there is theoretically no alias possible. However, no deep copy is
10728	made for this temporary, so that if the constructor is made of one or
10729	more variable with allocatable components, those components still point
10730	to the variable's: DEEP_COPY should be set for the assignment from the
10731	temporary to the lhs in that case.
10732	2. When assigning a scalar to an array, we evaluate the scalar value out
10733	of the loop, store it into a temporary variable, and assign from that.
10734	In that case, deep copying when assigning to the temporary would be a
10735	waste of resources; however deep copies should happen when assigning from
10736	the temporary to each array element: again DEEP_COPY should be set for
10737	the assignment from the temporary to the lhs. */
10738
10739	tree
10740	gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
10741	bool deep_copy, bool dealloc, bool in_coarray)
10742	{
10743	stmtblock_t block;
10744	tree tmp;
10745	tree cond;
10746
10747	gfc_init_block (&block);
10748
10749	if (ts.type == BT_CHARACTER)
10750	{
10751	tree rlen = NULL;
10752	tree llen = NULL;
10753
10754	if (lse->string_length != NULL_TREE)
10755	{
10756	gfc_conv_string_parameter (se: lse);
10757	gfc_add_block_to_block (&block, &lse->pre);
10758	llen = lse->string_length;
10759	}
10760
10761	if (rse->string_length != NULL_TREE)
10762	{
10763	gfc_conv_string_parameter (se: rse);
10764	gfc_add_block_to_block (&block, &rse->pre);
10765	rlen = rse->string_length;
10766	}
10767
10768	gfc_trans_string_copy (block: &block, dlength: llen, dest: lse->expr, dkind: ts.kind, slength: rlen,
10769	src: rse->expr, skind: ts.kind);
10770	}
10771	else if (gfc_bt_struct (ts.type)
10772	&& (ts.u.derived->attr.alloc_comp
10773	|| (deep_copy && ts.u.derived->attr.pdt_type)))
10774	{
10775	tree tmp_var = NULL_TREE;
10776	cond = NULL_TREE;
10777
10778	/* Are the rhs and the lhs the same? */
10779	if (deep_copy)
10780	{
10781	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10782	gfc_build_addr_expr (NULL_TREE, lse->expr),
10783	gfc_build_addr_expr (NULL_TREE, rse->expr));
10784	cond = gfc_evaluate_now (cond, &lse->pre);
10785	}
10786
10787	/* Deallocate the lhs allocated components as long as it is not
10788	the same as the rhs. This must be done following the assignment
10789	to prevent deallocating data that could be used in the rhs
10790	expression. */
10791	if (dealloc)
10792	{
10793	tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
10794	tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
10795	0, no_finalization: gfc_may_be_finalized (ts));
10796	if (deep_copy)
10797	tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
10798	tmp);
10799	gfc_add_expr_to_block (&lse->post, tmp);
10800	}
10801
10802	gfc_add_block_to_block (&block, &rse->pre);
10803	gfc_add_block_to_block (&block, &lse->finalblock);
10804	gfc_add_block_to_block (&block, &lse->pre);
10805
10806	gfc_add_modify (&block, lse->expr,
10807	fold_convert (TREE_TYPE (lse->expr), rse->expr));
10808
10809	/* Restore pointer address of coarray components. */
10810	if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
10811	{
10812	tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
10813	tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
10814	tmp);
10815	gfc_add_expr_to_block (&block, tmp);
10816	}
10817
10818	/* Do a deep copy if the rhs is a variable, if it is not the
10819	same as the lhs. */
10820	if (deep_copy)
10821	{
10822	int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
10823	| GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
10824	tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
10825	caf_mode);
10826	tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
10827	tmp);
10828	gfc_add_expr_to_block (&block, tmp);
10829	}
10830	}
10831	else if (gfc_bt_struct (ts.type))
10832	{
10833	gfc_add_block_to_block (&block, &rse->pre);
10834	gfc_add_block_to_block (&block, &lse->finalblock);
10835	gfc_add_block_to_block (&block, &lse->pre);
10836	tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
10837	TREE_TYPE (lse->expr), rse->expr);
10838	gfc_add_modify (&block, lse->expr, tmp);
10839	}
10840	/* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
10841	else if (ts.type == BT_CLASS)
10842	{
10843	gfc_add_block_to_block (&block, &lse->pre);
10844	gfc_add_block_to_block (&block, &rse->pre);
10845	gfc_add_block_to_block (&block, &lse->finalblock);
10846
10847	if (!trans_scalar_class_assign (block: &block, lse, rse))
10848	{
10849	/* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
10850	for the lhs which ensures that class data rhs cast as a string assigns
10851	correctly. */
10852	tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
10853	TREE_TYPE (rse->expr), lse->expr);
10854	gfc_add_modify (&block, tmp, rse->expr);
10855	}
10856	}
10857	else if (ts.type != BT_CLASS)
10858	{
10859	gfc_add_block_to_block (&block, &lse->pre);
10860	gfc_add_block_to_block (&block, &rse->pre);
10861
10862	gfc_add_modify (&block, lse->expr,
10863	fold_convert (TREE_TYPE (lse->expr), rse->expr));
10864	}
10865
10866	gfc_add_block_to_block (&block, &lse->post);
10867	gfc_add_block_to_block (&block, &rse->post);
10868
10869	return gfc_finish_block (&block);
10870	}
10871
10872
10873	/* There are quite a lot of restrictions on the optimisation in using an
10874	array function assign without a temporary. */
10875
10876	static bool
10877	arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
10878	{
10879	gfc_ref * ref;
10880	bool seen_array_ref;
10881	bool c = false;
10882	gfc_symbol *sym = expr1->symtree->n.sym;
10883
10884	/* Play it safe with class functions assigned to a derived type. */
10885	if (gfc_is_class_array_function (expr2)
10886	&& expr1->ts.type == BT_DERIVED)
10887	return true;
10888
10889	/* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
10890	if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
10891	return true;
10892
10893	/* Elemental functions are scalarized so that they don't need a
10894	temporary in gfc_trans_assignment_1, so return a true. Otherwise,
10895	they would need special treatment in gfc_trans_arrayfunc_assign. */
10896	if (expr2->value.function.esym != NULL
10897	&& expr2->value.function.esym->attr.elemental)
10898	return true;
10899
10900	/* Need a temporary if rhs is not FULL or a contiguous section. */
10901	if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
10902	return true;
10903
10904	/* Need a temporary if EXPR1 can't be expressed as a descriptor. */
10905	if (gfc_ref_needs_temporary_p (expr1->ref))
10906	return true;
10907
10908	/* Functions returning pointers or allocatables need temporaries. */
10909	if (gfc_expr_attr (expr2).pointer
10910	|| gfc_expr_attr (expr2).allocatable)
10911	return true;
10912
10913	/* Character array functions need temporaries unless the
10914	character lengths are the same. */
10915	if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
10916	{
10917	if (expr1->ts.u.cl->length == NULL
10918	|| expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
10919	return true;
10920
10921	if (expr2->ts.u.cl->length == NULL
10922	|| expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
10923	return true;
10924
10925	if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
10926	expr2->ts.u.cl->length->value.integer) != 0)
10927	return true;
10928	}
10929
10930	/* Check that no LHS component references appear during an array
10931	reference. This is needed because we do not have the means to
10932	span any arbitrary stride with an array descriptor. This check
10933	is not needed for the rhs because the function result has to be
10934	a complete type. */
10935	seen_array_ref = false;
10936	for (ref = expr1->ref; ref; ref = ref->next)
10937	{
10938	if (ref->type == REF_ARRAY)
10939	seen_array_ref= true;
10940	else if (ref->type == REF_COMPONENT && seen_array_ref)
10941	return true;
10942	}
10943
10944	/* Check for a dependency. */
10945	if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
10946	expr2->value.function.esym,
10947	expr2->value.function.actual,
10948	NOT_ELEMENTAL))
10949	return true;
10950
10951	/* If we have reached here with an intrinsic function, we do not
10952	need a temporary except in the particular case that reallocation
10953	on assignment is active and the lhs is allocatable and a target,
10954	or a pointer which may be a subref pointer. FIXME: The last
10955	condition can go away when we use span in the intrinsics
10956	directly.*/
10957	if (expr2->value.function.isym)
10958	return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target)
10959	|| (sym->attr.pointer && sym->attr.subref_array_pointer);
10960
10961	/* If the LHS is a dummy, we need a temporary if it is not
10962	INTENT(OUT). */
10963	if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
10964	return true;
10965
10966	/* If the lhs has been host_associated, is in common, a pointer or is
10967	a target and the function is not using a RESULT variable, aliasing
10968	can occur and a temporary is needed. */
10969	if ((sym->attr.host_assoc
10970	|| sym->attr.in_common
10971	|| sym->attr.pointer
10972	|| sym->attr.cray_pointee
10973	|| sym->attr.target)
10974	&& expr2->symtree != NULL
10975	&& expr2->symtree->n.sym == expr2->symtree->n.sym->result)
10976	return true;
10977
10978	/* A PURE function can unconditionally be called without a temporary. */
10979	if (expr2->value.function.esym != NULL
10980	&& expr2->value.function.esym->attr.pure)
10981	return false;
10982
10983	/* Implicit_pure functions are those which could legally be declared
10984	to be PURE. */
10985	if (expr2->value.function.esym != NULL
10986	&& expr2->value.function.esym->attr.implicit_pure)
10987	return false;
10988
10989	if (!sym->attr.use_assoc
10990	&& !sym->attr.in_common
10991	&& !sym->attr.pointer
10992	&& !sym->attr.target
10993	&& !sym->attr.cray_pointee
10994	&& expr2->value.function.esym)
10995	{
10996	/* A temporary is not needed if the function is not contained and
10997	the variable is local or host associated and not a pointer or
10998	a target. */
10999	if (!expr2->value.function.esym->attr.contained)
11000	return false;
11001
11002	/* A temporary is not needed if the lhs has never been host
11003	associated and the procedure is contained. */
11004	else if (!sym->attr.host_assoc)
11005	return false;
11006
11007	/* A temporary is not needed if the variable is local and not
11008	a pointer, a target or a result. */
11009	if (sym->ns->parent
11010	&& expr2->value.function.esym->ns == sym->ns->parent)
11011	return false;
11012	}
11013
11014	/* Default to temporary use. */
11015	return true;
11016	}
11017
11018
11019	/* Provide the loop info so that the lhs descriptor can be built for
11020	reallocatable assignments from extrinsic function calls. */
11021
11022	static void
11023	realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
11024	gfc_loopinfo *loop)
11025	{
11026	/* Signal that the function call should not be made by
11027	gfc_conv_loop_setup. */
11028	se->ss->is_alloc_lhs = 1;
11029	gfc_init_loopinfo (loop);
11030	gfc_add_ss_to_loop (loop, *ss);
11031	gfc_add_ss_to_loop (loop, se->ss);
11032	gfc_conv_ss_startstride (loop);
11033	gfc_conv_loop_setup (loop, where);
11034	gfc_copy_loopinfo_to_se (se, loop);
11035	gfc_add_block_to_block (&se->pre, &loop->pre);
11036	gfc_add_block_to_block (&se->pre, &loop->post);
11037	se->ss->is_alloc_lhs = 0;
11038	}
11039
11040
11041	/* For assignment to a reallocatable lhs from intrinsic functions,
11042	replace the se.expr (ie. the result) with a temporary descriptor.
11043	Null the data field so that the library allocates space for the
11044	result. Free the data of the original descriptor after the function,
11045	in case it appears in an argument expression and transfer the
11046	result to the original descriptor. */
11047
11048	static void
11049	fcncall_realloc_result (gfc_se *se, int rank)
11050	{
11051	tree desc;
11052	tree res_desc;
11053	tree tmp;
11054	tree offset;
11055	tree zero_cond;
11056	tree not_same_shape;
11057	stmtblock_t shape_block;
11058	int n;
11059
11060	/* Use the allocation done by the library. Substitute the lhs
11061	descriptor with a copy, whose data field is nulled.*/
11062	desc = build_fold_indirect_ref_loc (input_location, se->expr);
11063	if (POINTER_TYPE_P (TREE_TYPE (desc)))
11064	desc = build_fold_indirect_ref_loc (input_location, desc);
11065
11066	/* Unallocated, the descriptor does not have a dtype. */
11067	tmp = gfc_conv_descriptor_dtype (desc);
11068	gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
11069
11070	res_desc = gfc_evaluate_now (desc, &se->pre);
11071	gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
11072	se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
11073
11074	/* Free the lhs after the function call and copy the result data to
11075	the lhs descriptor. */
11076	tmp = gfc_conv_descriptor_data_get (desc);
11077	zero_cond = fold_build2_loc (input_location, EQ_EXPR,
11078	logical_type_node, tmp,
11079	build_int_cst (TREE_TYPE (tmp), 0));
11080	zero_cond = gfc_evaluate_now (zero_cond, &se->post);
11081	tmp = gfc_call_free (tmp);
11082	gfc_add_expr_to_block (&se->post, tmp);
11083
11084	tmp = gfc_conv_descriptor_data_get (res_desc);
11085	gfc_conv_descriptor_data_set (&se->post, desc, tmp);
11086
11087	/* Check that the shapes are the same between lhs and expression.
11088	The evaluation of the shape is done in 'shape_block' to avoid
11089	unitialized warnings from the lhs bounds. */
11090	not_same_shape = boolean_false_node;
11091	gfc_start_block (&shape_block);
11092	for (n = 0 ; n < rank; n++)
11093	{
11094	tree tmp1;
11095	tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
11096	tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
11097	tmp = fold_build2_loc (input_location, MINUS_EXPR,
11098	gfc_array_index_type, tmp, tmp1);
11099	tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
11100	tmp = fold_build2_loc (input_location, MINUS_EXPR,
11101	gfc_array_index_type, tmp, tmp1);
11102	tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
11103	tmp = fold_build2_loc (input_location, PLUS_EXPR,
11104	gfc_array_index_type, tmp, tmp1);
11105	tmp = fold_build2_loc (input_location, NE_EXPR,
11106	logical_type_node, tmp,
11107	gfc_index_zero_node);
11108	tmp = gfc_evaluate_now (tmp, &shape_block);
11109	if (n == 0)
11110	not_same_shape = tmp;
11111	else
11112	not_same_shape = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11113	logical_type_node, tmp,
11114	not_same_shape);
11115	}
11116
11117	/* 'zero_cond' being true is equal to lhs not being allocated or the
11118	shapes being different. */
11119	tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
11120	zero_cond, not_same_shape);
11121	gfc_add_modify (&shape_block, zero_cond, tmp);
11122	tmp = gfc_finish_block (&shape_block);
11123	tmp = build3_v (COND_EXPR, zero_cond,
11124	build_empty_stmt (input_location), tmp);
11125	gfc_add_expr_to_block (&se->post, tmp);
11126
11127	/* Now reset the bounds returned from the function call to bounds based
11128	on the lhs lbounds, except where the lhs is not allocated or the shapes
11129	of 'variable and 'expr' are different. Set the offset accordingly. */
11130	offset = gfc_index_zero_node;
11131	for (n = 0 ; n < rank; n++)
11132	{
11133	tree lbound;
11134
11135	lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
11136	lbound = fold_build3_loc (input_location, COND_EXPR,
11137	gfc_array_index_type, zero_cond,
11138	gfc_index_one_node, lbound);
11139	lbound = gfc_evaluate_now (lbound, &se->post);
11140
11141	tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
11142	tmp = fold_build2_loc (input_location, PLUS_EXPR,
11143	gfc_array_index_type, tmp, lbound);
11144	gfc_conv_descriptor_lbound_set (&se->post, desc,
11145	gfc_rank_cst[n], lbound);
11146	gfc_conv_descriptor_ubound_set (&se->post, desc,
11147	gfc_rank_cst[n], tmp);
11148
11149	/* Set stride and accumulate the offset. */
11150	tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
11151	gfc_conv_descriptor_stride_set (&se->post, desc,
11152	gfc_rank_cst[n], tmp);
11153	tmp = fold_build2_loc (input_location, MULT_EXPR,
11154	gfc_array_index_type, lbound, tmp);
11155	offset = fold_build2_loc (input_location, MINUS_EXPR,
11156	gfc_array_index_type, offset, tmp);
11157	offset = gfc_evaluate_now (offset, &se->post);
11158	}
11159
11160	gfc_conv_descriptor_offset_set (&se->post, desc, offset);
11161	}
11162
11163
11164
11165	/* Try to translate array(:) = func (...), where func is a transformational
11166	array function, without using a temporary. Returns NULL if this isn't the
11167	case. */
11168
11169	static tree
11170	gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
11171	{
11172	gfc_se se;
11173	gfc_ss *ss = NULL;
11174	gfc_component *comp = NULL;
11175	gfc_loopinfo loop;
11176	tree tmp;
11177	tree lhs;
11178	gfc_se final_se;
11179	gfc_symbol *sym = expr1->symtree->n.sym;
11180	bool finalizable = gfc_may_be_finalized (expr1->ts);
11181
11182	if (arrayfunc_assign_needs_temporary (expr1, expr2))
11183	return NULL;
11184
11185	/* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
11186	functions. */
11187	comp = gfc_get_proc_ptr_comp (expr2);
11188
11189	if (!(expr2->value.function.isym
11190	|| (comp && comp->attr.dimension)
11191	|| (!comp && gfc_return_by_reference (expr2->value.function.esym)
11192	&& expr2->value.function.esym->result->attr.dimension)))
11193	return NULL;
11194
11195	gfc_init_se (se: &se, NULL);
11196	gfc_start_block (&se.pre);
11197	se.want_pointer = 1;
11198
11199	/* First the lhs must be finalized, if necessary. We use a copy of the symbol
11200	backend decl, stash the original away for the finalization so that the
11201	value used is that before the assignment. This is necessary because
11202	evaluation of the rhs expression using direct by reference can change
11203	the value. However, the standard mandates that the finalization must occur
11204	after evaluation of the rhs. */
11205	gfc_init_se (se: &final_se, NULL);
11206
11207	if (finalizable)
11208	{
11209	tmp = sym->backend_decl;
11210	lhs = sym->backend_decl;
11211	if (INDIRECT_REF_P (tmp))
11212	tmp = TREE_OPERAND (tmp, 0);
11213	sym->backend_decl = gfc_create_var (TREE_TYPE (tmp), "lhs");
11214	gfc_add_modify (&se.pre, sym->backend_decl, tmp);
11215	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
11216	{
11217	tmp = gfc_copy_alloc_comp (expr1->ts.u.derived, tmp, sym->backend_decl,
11218	expr1->rank, 0);
11219	gfc_add_expr_to_block (&final_se.pre, tmp);
11220	}
11221	}
11222
11223	if (finalizable && gfc_assignment_finalizer_call (&final_se, expr1, false))
11224	{
11225	gfc_add_block_to_block (&se.pre, &final_se.pre);
11226	gfc_add_block_to_block (&se.post, &final_se.finalblock);
11227	}
11228
11229	if (finalizable)
11230	sym->backend_decl = lhs;
11231
11232	gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
11233
11234	if (expr1->ts.type == BT_DERIVED
11235	&& expr1->ts.u.derived->attr.alloc_comp)
11236	{
11237	tmp = build_fold_indirect_ref_loc (input_location, se.expr);
11238	tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, tmp,
11239	expr1->rank);
11240	gfc_add_expr_to_block (&se.pre, tmp);
11241	}
11242
11243	se.direct_byref = 1;
11244	se.ss = gfc_walk_expr (expr2);
11245	gcc_assert (se.ss != gfc_ss_terminator);
11246
11247	/* Since this is a direct by reference call, references to the lhs can be
11248	used for finalization of the function result just as long as the blocks
11249	from final_se are added at the right time. */
11250	gfc_init_se (se: &final_se, NULL);
11251	if (finalizable && expr2->value.function.esym)
11252	{
11253	final_se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
11254	gfc_finalize_tree_expr (&final_se, expr2->ts.u.derived,
11255	expr2->value.function.esym->attr,
11256	expr2->rank);
11257	}
11258
11259	/* Reallocate on assignment needs the loopinfo for extrinsic functions.
11260	This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
11261	Clearly, this cannot be done for an allocatable function result, since
11262	the shape of the result is unknown and, in any case, the function must
11263	correctly take care of the reallocation internally. For intrinsic
11264	calls, the array data is freed and the library takes care of allocation.
11265	TODO: Add logic of trans-array.cc: gfc_alloc_allocatable_for_assignment
11266	to the library. */
11267	if (flag_realloc_lhs
11268	&& gfc_is_reallocatable_lhs (expr1)
11269	&& !gfc_expr_attr (expr1).codimension
11270	&& !gfc_is_coindexed (expr1)
11271	&& !(expr2->value.function.esym
11272	&& expr2->value.function.esym->result->attr.allocatable))
11273	{
11274	realloc_lhs_warning (type: expr1->ts.type, array: true, where: &expr1->where);
11275
11276	if (!expr2->value.function.isym)
11277	{
11278	ss = gfc_walk_expr (expr1);
11279	gcc_assert (ss != gfc_ss_terminator);
11280
11281	realloc_lhs_loop_for_fcn_call (se: &se, where: &expr1->where, ss: &ss, loop: &loop);
11282	ss->is_alloc_lhs = 1;
11283	}
11284	else
11285	fcncall_realloc_result (se: &se, rank: expr1->rank);
11286	}
11287
11288	gfc_conv_function_expr (se: &se, expr: expr2);
11289
11290	/* Fix the result. */
11291	gfc_add_block_to_block (&se.pre, &se.post);
11292	if (finalizable)
11293	gfc_add_block_to_block (&se.pre, &final_se.pre);
11294
11295	/* Do the finalization, including final calls from function arguments. */
11296	if (finalizable)
11297	{
11298	gfc_add_block_to_block (&se.pre, &final_se.post);
11299	gfc_add_block_to_block (&se.pre, &se.finalblock);
11300	gfc_add_block_to_block (&se.pre, &final_se.finalblock);
11301	}
11302
11303	if (ss)
11304	gfc_cleanup_loop (&loop);
11305	else
11306	gfc_free_ss_chain (se.ss);
11307
11308	return gfc_finish_block (&se.pre);
11309	}
11310
11311
11312	/* Try to efficiently translate array(:) = 0. Return NULL if this
11313	can't be done. */
11314
11315	static tree
11316	gfc_trans_zero_assign (gfc_expr * expr)
11317	{
11318	tree dest, len, type;
11319	tree tmp;
11320	gfc_symbol *sym;
11321
11322	sym = expr->symtree->n.sym;
11323	dest = gfc_get_symbol_decl (sym);
11324
11325	type = TREE_TYPE (dest);
11326	if (POINTER_TYPE_P (type))
11327	type = TREE_TYPE (type);
11328	if (!GFC_ARRAY_TYPE_P (type))
11329	return NULL_TREE;
11330
11331	/* Determine the length of the array. */
11332	len = GFC_TYPE_ARRAY_SIZE (type);
11333	if (!len || TREE_CODE (len) != INTEGER_CST)
11334	return NULL_TREE;
11335
11336	tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
11337	len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
11338	fold_convert (gfc_array_index_type, tmp));
11339
11340	/* If we are zeroing a local array avoid taking its address by emitting
11341	a = {} instead. */
11342	if (!POINTER_TYPE_P (TREE_TYPE (dest)))
11343	return build2_loc (loc: input_location, code: MODIFY_EXPR, void_type_node,
11344	arg0: dest, arg1: build_constructor (TREE_TYPE (dest),
11345	NULL));
11346
11347	/* Convert arguments to the correct types. */
11348	dest = fold_convert (pvoid_type_node, dest);
11349	len = fold_convert (size_type_node, len);
11350
11351	/* Construct call to __builtin_memset. */
11352	tmp = build_call_expr_loc (input_location,
11353	builtin_decl_explicit (fncode: BUILT_IN_MEMSET),
11354	3, dest, integer_zero_node, len);
11355	return fold_convert (void_type_node, tmp);
11356	}
11357
11358
11359	/* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
11360	that constructs the call to __builtin_memcpy. */
11361
11362	tree
11363	gfc_build_memcpy_call (tree dst, tree src, tree len)
11364	{
11365	tree tmp;
11366
11367	/* Convert arguments to the correct types. */
11368	if (!POINTER_TYPE_P (TREE_TYPE (dst)))
11369	dst = gfc_build_addr_expr (pvoid_type_node, dst);
11370	else
11371	dst = fold_convert (pvoid_type_node, dst);
11372
11373	if (!POINTER_TYPE_P (TREE_TYPE (src)))
11374	src = gfc_build_addr_expr (pvoid_type_node, src);
11375	else
11376	src = fold_convert (pvoid_type_node, src);
11377
11378	len = fold_convert (size_type_node, len);
11379
11380	/* Construct call to __builtin_memcpy. */
11381	tmp = build_call_expr_loc (input_location,
11382	builtin_decl_explicit (fncode: BUILT_IN_MEMCPY),
11383	3, dst, src, len);
11384	return fold_convert (void_type_node, tmp);
11385	}
11386
11387
11388	/* Try to efficiently translate dst(:) = src(:). Return NULL if this
11389	can't be done. EXPR1 is the destination/lhs and EXPR2 is the
11390	source/rhs, both are gfc_full_array_ref_p which have been checked for
11391	dependencies. */
11392
11393	static tree
11394	gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
11395	{
11396	tree dst, dlen, dtype;
11397	tree src, slen, stype;
11398	tree tmp;
11399
11400	dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
11401	src = gfc_get_symbol_decl (expr2->symtree->n.sym);
11402
11403	dtype = TREE_TYPE (dst);
11404	if (POINTER_TYPE_P (dtype))
11405	dtype = TREE_TYPE (dtype);
11406	stype = TREE_TYPE (src);
11407	if (POINTER_TYPE_P (stype))
11408	stype = TREE_TYPE (stype);
11409
11410	if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
11411	return NULL_TREE;
11412
11413	/* Determine the lengths of the arrays. */
11414	dlen = GFC_TYPE_ARRAY_SIZE (dtype);
11415	if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
11416	return NULL_TREE;
11417	tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
11418	dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
11419	dlen, fold_convert (gfc_array_index_type, tmp));
11420
11421	slen = GFC_TYPE_ARRAY_SIZE (stype);
11422	if (!slen || TREE_CODE (slen) != INTEGER_CST)
11423	return NULL_TREE;
11424	tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
11425	slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
11426	slen, fold_convert (gfc_array_index_type, tmp));
11427
11428	/* Sanity check that they are the same. This should always be
11429	the case, as we should already have checked for conformance. */
11430	if (!tree_int_cst_equal (slen, dlen))
11431	return NULL_TREE;
11432
11433	return gfc_build_memcpy_call (dst, src, len: dlen);
11434	}
11435
11436
11437	/* Try to efficiently translate array(:) = (/ ... /). Return NULL if
11438	this can't be done. EXPR1 is the destination/lhs for which
11439	gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
11440
11441	static tree
11442	gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
11443	{
11444	unsigned HOST_WIDE_INT nelem;
11445	tree dst, dtype;
11446	tree src, stype;
11447	tree len;
11448	tree tmp;
11449
11450	nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
11451	if (nelem == 0)
11452	return NULL_TREE;
11453
11454	dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
11455	dtype = TREE_TYPE (dst);
11456	if (POINTER_TYPE_P (dtype))
11457	dtype = TREE_TYPE (dtype);
11458	if (!GFC_ARRAY_TYPE_P (dtype))
11459	return NULL_TREE;
11460
11461	/* Determine the lengths of the array. */
11462	len = GFC_TYPE_ARRAY_SIZE (dtype);
11463	if (!len || TREE_CODE (len) != INTEGER_CST)
11464	return NULL_TREE;
11465
11466	/* Confirm that the constructor is the same size. */
11467	if (compare_tree_int (len, nelem) != 0)
11468	return NULL_TREE;
11469
11470	tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
11471	len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
11472	fold_convert (gfc_array_index_type, tmp));
11473
11474	stype = gfc_typenode_for_spec (&expr2->ts);
11475	src = gfc_build_constant_array_constructor (expr2, stype);
11476
11477	return gfc_build_memcpy_call (dst, src, len);
11478	}
11479
11480
11481	/* Tells whether the expression is to be treated as a variable reference. */
11482
11483	bool
11484	gfc_expr_is_variable (gfc_expr *expr)
11485	{
11486	gfc_expr *arg;
11487	gfc_component *comp;
11488	gfc_symbol *func_ifc;
11489
11490	if (expr->expr_type == EXPR_VARIABLE)
11491	return true;
11492
11493	arg = gfc_get_noncopying_intrinsic_argument (expr);
11494	if (arg)
11495	{
11496	gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
11497	return gfc_expr_is_variable (expr: arg);
11498	}
11499
11500	/* A data-pointer-returning function should be considered as a variable
11501	too. */
11502	if (expr->expr_type == EXPR_FUNCTION
11503	&& expr->ref == NULL)
11504	{
11505	if (expr->value.function.isym != NULL)
11506	return false;
11507
11508	if (expr->value.function.esym != NULL)
11509	{
11510	func_ifc = expr->value.function.esym;
11511	goto found_ifc;
11512	}
11513	gcc_assert (expr->symtree);
11514	func_ifc = expr->symtree->n.sym;
11515	goto found_ifc;
11516	}
11517
11518	comp = gfc_get_proc_ptr_comp (expr);
11519	if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
11520	&& comp)
11521	{
11522	func_ifc = comp->ts.interface;
11523	goto found_ifc;
11524	}
11525
11526	if (expr->expr_type == EXPR_COMPCALL)
11527	{
11528	gcc_assert (!expr->value.compcall.tbp->is_generic);
11529	func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
11530	goto found_ifc;
11531	}
11532
11533	return false;
11534
11535	found_ifc:
11536	gcc_assert (func_ifc->attr.function
11537	&& func_ifc->result != NULL);
11538	return func_ifc->result->attr.pointer;
11539	}
11540
11541
11542	/* Is the lhs OK for automatic reallocation? */
11543
11544	static bool
11545	is_scalar_reallocatable_lhs (gfc_expr *expr)
11546	{
11547	gfc_ref * ref;
11548
11549	/* An allocatable variable with no reference. */
11550	if (expr->symtree->n.sym->attr.allocatable
11551	&& !expr->ref)
11552	return true;
11553
11554	/* All that can be left are allocatable components. However, we do
11555	not check for allocatable components here because the expression
11556	could be an allocatable component of a pointer component. */
11557	if (expr->symtree->n.sym->ts.type != BT_DERIVED
11558	&& expr->symtree->n.sym->ts.type != BT_CLASS)
11559	return false;
11560
11561	/* Find an allocatable component ref last. */
11562	for (ref = expr->ref; ref; ref = ref->next)
11563	if (ref->type == REF_COMPONENT
11564	&& !ref->next
11565	&& ref->u.c.component->attr.allocatable)
11566	return true;
11567
11568	return false;
11569	}
11570
11571
11572	/* Allocate or reallocate scalar lhs, as necessary. */
11573
11574	static void
11575	alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
11576	tree string_length,
11577	gfc_expr *expr1,
11578	gfc_expr *expr2)
11579
11580	{
11581	tree cond;
11582	tree tmp;
11583	tree size;
11584	tree size_in_bytes;
11585	tree jump_label1;
11586	tree jump_label2;
11587	gfc_se lse;
11588	gfc_ref *ref;
11589
11590	if (!expr1 || expr1->rank)
11591	return;
11592
11593	if (!expr2 || expr2->rank)
11594	return;
11595
11596	for (ref = expr1->ref; ref; ref = ref->next)
11597	if (ref->type == REF_SUBSTRING)
11598	return;
11599
11600	realloc_lhs_warning (type: expr2->ts.type, array: false, where: &expr2->where);
11601
11602	/* Since this is a scalar lhs, we can afford to do this. That is,
11603	there is no risk of side effects being repeated. */
11604	gfc_init_se (se: &lse, NULL);
11605	lse.want_pointer = 1;
11606	gfc_conv_expr (se: &lse, expr: expr1);
11607
11608	jump_label1 = gfc_build_label_decl (NULL_TREE);
11609	jump_label2 = gfc_build_label_decl (NULL_TREE);
11610
11611	/* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
11612	tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
11613	cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
11614	lse.expr, tmp);
11615	tmp = build3_v (COND_EXPR, cond,
11616	build1_v (GOTO_EXPR, jump_label1),
11617	build_empty_stmt (input_location));
11618	gfc_add_expr_to_block (block, tmp);
11619
11620	if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11621	{
11622	/* Use the rhs string length and the lhs element size. Note that 'size' is
11623	used below for the string-length comparison, only. */
11624	size = string_length;
11625	tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
11626	size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
11627	TREE_TYPE (tmp), tmp,
11628	fold_convert (TREE_TYPE (tmp), size));
11629	}
11630	else
11631	{
11632	/* Otherwise use the length in bytes of the rhs. */
11633	size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
11634	size_in_bytes = size;
11635	}
11636
11637	size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
11638	size_in_bytes, size_one_node);
11639
11640	if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
11641	{
11642	tree caf_decl, token;
11643	gfc_se caf_se;
11644	symbol_attribute attr;
11645
11646	gfc_clear_attr (&attr);
11647	gfc_init_se (se: &caf_se, NULL);
11648
11649	caf_decl = gfc_get_tree_for_caf_expr (expr: expr1);
11650	gfc_get_caf_token_offset (se: &caf_se, token: &token, NULL, caf_decl, NULL_TREE,
11651	NULL);
11652	gfc_add_block_to_block (block, &caf_se.pre);
11653	gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
11654	gfc_build_addr_expr (NULL_TREE, token),
11655	NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
11656	expr1, 1);
11657	}
11658	else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
11659	{
11660	tmp = build_call_expr_loc (input_location,
11661	builtin_decl_explicit (fncode: BUILT_IN_CALLOC),
11662	2, build_one_cst (size_type_node),
11663	size_in_bytes);
11664	tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
11665	gfc_add_modify (block, lse.expr, tmp);
11666	}
11667	else
11668	{
11669	tmp = build_call_expr_loc (input_location,
11670	builtin_decl_explicit (fncode: BUILT_IN_MALLOC),
11671	1, size_in_bytes);
11672	tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
11673	gfc_add_modify (block, lse.expr, tmp);
11674	}
11675
11676	if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11677	{
11678	/* Deferred characters need checking for lhs and rhs string
11679	length. Other deferred parameter variables will have to
11680	come here too. */
11681	tmp = build1_v (GOTO_EXPR, jump_label2);
11682	gfc_add_expr_to_block (block, tmp);
11683	}
11684	tmp = build1_v (LABEL_EXPR, jump_label1);
11685	gfc_add_expr_to_block (block, tmp);
11686
11687	/* For a deferred length character, reallocate if lengths of lhs and
11688	rhs are different. */
11689	if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11690	{
11691	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11692	lse.string_length,
11693	fold_convert (TREE_TYPE (lse.string_length),
11694	size));
11695	/* Jump past the realloc if the lengths are the same. */
11696	tmp = build3_v (COND_EXPR, cond,
11697	build1_v (GOTO_EXPR, jump_label2),
11698	build_empty_stmt (input_location));
11699	gfc_add_expr_to_block (block, tmp);
11700	tmp = build_call_expr_loc (input_location,
11701	builtin_decl_explicit (fncode: BUILT_IN_REALLOC),
11702	2, fold_convert (pvoid_type_node, lse.expr),
11703	size_in_bytes);
11704	tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
11705	gfc_add_modify (block, lse.expr, tmp);
11706	tmp = build1_v (LABEL_EXPR, jump_label2);
11707	gfc_add_expr_to_block (block, tmp);
11708
11709	/* Update the lhs character length. */
11710	size = string_length;
11711	gfc_add_modify (block, lse.string_length,
11712	fold_convert (TREE_TYPE (lse.string_length), size));
11713	}
11714	}
11715
11716	/* Check for assignments of the type
11717
11718	a = a + 4
11719
11720	to make sure we do not check for reallocation unneccessarily. */
11721
11722
11723	static bool
11724	is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
11725	{
11726	gfc_actual_arglist *a;
11727	gfc_expr *e1, *e2;
11728
11729	switch (expr2->expr_type)
11730	{
11731	case EXPR_VARIABLE:
11732	return gfc_dep_compare_expr (expr1, expr2) == 0;
11733
11734	case EXPR_FUNCTION:
11735	if (expr2->value.function.esym
11736	&& expr2->value.function.esym->attr.elemental)
11737	{
11738	for (a = expr2->value.function.actual; a != NULL; a = a->next)
11739	{
11740	e1 = a->expr;
11741	if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, expr2: e1))
11742	return false;
11743	}
11744	return true;
11745	}
11746	else if (expr2->value.function.isym
11747	&& expr2->value.function.isym->elemental)
11748	{
11749	for (a = expr2->value.function.actual; a != NULL; a = a->next)
11750	{
11751	e1 = a->expr;
11752	if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, expr2: e1))
11753	return false;
11754	}
11755	return true;
11756	}
11757
11758	break;
11759
11760	case EXPR_OP:
11761	switch (expr2->value.op.op)
11762	{
11763	case INTRINSIC_NOT:
11764	case INTRINSIC_UPLUS:
11765	case INTRINSIC_UMINUS:
11766	case INTRINSIC_PARENTHESES:
11767	return is_runtime_conformable (expr1, expr2: expr2->value.op.op1);
11768
11769	case INTRINSIC_PLUS:
11770	case INTRINSIC_MINUS:
11771	case INTRINSIC_TIMES:
11772	case INTRINSIC_DIVIDE:
11773	case INTRINSIC_POWER:
11774	case INTRINSIC_AND:
11775	case INTRINSIC_OR:
11776	case INTRINSIC_EQV:
11777	case INTRINSIC_NEQV:
11778	case INTRINSIC_EQ:
11779	case INTRINSIC_NE:
11780	case INTRINSIC_GT:
11781	case INTRINSIC_GE:
11782	case INTRINSIC_LT:
11783	case INTRINSIC_LE:
11784	case INTRINSIC_EQ_OS:
11785	case INTRINSIC_NE_OS:
11786	case INTRINSIC_GT_OS:
11787	case INTRINSIC_GE_OS:
11788	case INTRINSIC_LT_OS:
11789	case INTRINSIC_LE_OS:
11790
11791	e1 = expr2->value.op.op1;
11792	e2 = expr2->value.op.op2;
11793
11794	if (e1->rank == 0 && e2->rank > 0)
11795	return is_runtime_conformable (expr1, expr2: e2);
11796	else if (e1->rank > 0 && e2->rank == 0)
11797	return is_runtime_conformable (expr1, expr2: e1);
11798	else if (e1->rank > 0 && e2->rank > 0)
11799	return is_runtime_conformable (expr1, expr2: e1)
11800	&& is_runtime_conformable (expr1, expr2: e2);
11801	break;
11802
11803	default:
11804	break;
11805
11806	}
11807
11808	break;
11809
11810	default:
11811	break;
11812	}
11813	return false;
11814	}
11815
11816
11817	static tree
11818	trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
11819	gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
11820	bool class_realloc)
11821	{
11822	tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr;
11823	vec<tree, va_gc> *args = NULL;
11824	bool final_expr;
11825
11826	final_expr = gfc_assignment_finalizer_call (lse, lhs, false);
11827	if (final_expr)
11828	{
11829	if (rse->loop)
11830	gfc_prepend_expr_to_block (&rse->loop->pre,
11831	gfc_finish_block (&lse->finalblock));
11832	else
11833	gfc_add_block_to_block (block, &lse->finalblock);
11834	}
11835
11836	/* Store the old vptr so that dynamic types can be compared for
11837	reallocation to occur or not. */
11838	if (class_realloc)
11839	{
11840	tmp = lse->expr;
11841	if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
11842	tmp = gfc_get_class_from_expr (expr: tmp);
11843	}
11844
11845	vptr = trans_class_vptr_len_assignment (block, le: lhs, re: rhs, rse, to_lenp: &to_len,
11846	from_lenp: &from_len);
11847
11848	/* Generate (re)allocation of the lhs. */
11849	if (class_realloc)
11850	{
11851	stmtblock_t alloc, re_alloc;
11852	tree class_han, re, size;
11853
11854	if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
11855	old_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl: tmp), block);
11856	else
11857	old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
11858
11859	size = gfc_vptr_size_get (vptr);
11860	tmp = lse->expr;
11861	class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
11862	? gfc_class_data_get (decl: tmp) : tmp;
11863
11864	if (!POINTER_TYPE_P (TREE_TYPE (class_han)))
11865	class_han = gfc_build_addr_expr (NULL_TREE, class_han);
11866
11867	/* Allocate block. */
11868	gfc_init_block (&alloc);
11869	gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
11870
11871	/* Reallocate if dynamic types are different. */
11872	gfc_init_block (&re_alloc);
11873	re = build_call_expr_loc (input_location,
11874	builtin_decl_explicit (fncode: BUILT_IN_REALLOC), 2,
11875	fold_convert (pvoid_type_node, class_han),
11876	size);
11877	tmp = fold_build2_loc (input_location, NE_EXPR,
11878	logical_type_node, vptr, old_vptr);
11879	re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
11880	tmp, re, build_empty_stmt (input_location));
11881	gfc_add_expr_to_block (&re_alloc, re);
11882
11883	tree realloc_expr = lhs->ts.type == BT_CLASS ?
11884	gfc_finish_block (&re_alloc) :
11885	build_empty_stmt (input_location);
11886
11887	/* Allocate if _data is NULL, reallocate otherwise. */
11888	tmp = fold_build2_loc (input_location, EQ_EXPR,
11889	logical_type_node, class_han,
11890	build_int_cst (prvoid_type_node, 0));
11891	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
11892	gfc_unlikely (tmp,
11893	PRED_FORTRAN_FAIL_ALLOC),
11894	gfc_finish_block (&alloc),
11895	realloc_expr);
11896	gfc_add_expr_to_block (&lse->pre, tmp);
11897	}
11898
11899	fcn = gfc_vptr_copy_get (vptr);
11900
11901	tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
11902	? gfc_class_data_get (decl: rse->expr) : rse->expr;
11903	if (use_vptr_copy)
11904	{
11905	if (!POINTER_TYPE_P (TREE_TYPE (tmp))
11906	|| INDIRECT_REF_P (tmp)
11907	|| (rhs->ts.type == BT_DERIVED
11908	&& rhs->ts.u.derived->attr.unlimited_polymorphic
11909	&& !rhs->ts.u.derived->attr.pointer
11910	&& !rhs->ts.u.derived->attr.allocatable)
11911	|| (UNLIMITED_POLY (rhs)
11912	&& !CLASS_DATA (rhs)->attr.pointer
11913	&& !CLASS_DATA (rhs)->attr.allocatable))
11914	vec_safe_push (v&: args, obj: gfc_build_addr_expr (NULL_TREE, tmp));
11915	else
11916	vec_safe_push (v&: args, obj: tmp);
11917	tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
11918	? gfc_class_data_get (decl: lse->expr) : lse->expr;
11919	if (!POINTER_TYPE_P (TREE_TYPE (tmp))
11920	|| INDIRECT_REF_P (tmp)
11921	|| (lhs->ts.type == BT_DERIVED
11922	&& lhs->ts.u.derived->attr.unlimited_polymorphic
11923	&& !lhs->ts.u.derived->attr.pointer
11924	&& !lhs->ts.u.derived->attr.allocatable)
11925	|| (UNLIMITED_POLY (lhs)
11926	&& !CLASS_DATA (lhs)->attr.pointer
11927	&& !CLASS_DATA (lhs)->attr.allocatable))
11928	vec_safe_push (v&: args, obj: gfc_build_addr_expr (NULL_TREE, tmp));
11929	else
11930	vec_safe_push (v&: args, obj: tmp);
11931
11932	stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
11933
11934	if (to_len != NULL_TREE && !integer_zerop (from_len))
11935	{
11936	tree extcopy;
11937	vec_safe_push (v&: args, obj: from_len);
11938	vec_safe_push (v&: args, obj: to_len);
11939	extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
11940
11941	tmp = fold_build2_loc (input_location, GT_EXPR,
11942	logical_type_node, from_len,
11943	build_zero_cst (TREE_TYPE (from_len)));
11944	return fold_build3_loc (input_location, COND_EXPR,
11945	void_type_node, tmp,
11946	extcopy, stdcopy);
11947	}
11948	else
11949	return stdcopy;
11950	}
11951	else
11952	{
11953	tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
11954	? gfc_class_data_get (decl: lse->expr) : lse->expr;
11955	stmtblock_t tblock;
11956	gfc_init_block (&tblock);
11957	if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
11958	tmp = gfc_build_addr_expr (NULL_TREE, tmp);
11959	if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
11960	rhst = gfc_build_addr_expr (NULL_TREE, rhst);
11961	/* When coming from a ptr_copy lhs and rhs are swapped. */
11962	gfc_add_modify_loc (input_location, &tblock, rhst,
11963	fold_convert (TREE_TYPE (rhst), tmp));
11964	return gfc_finish_block (&tblock);
11965	}
11966	}
11967
11968
11969	/* Subroutine of gfc_trans_assignment that actually scalarizes the
11970	assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
11971	init_flag indicates initialization expressions and dealloc that no
11972	deallocate prior assignment is needed (if in doubt, set true).
11973	When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
11974	routine instead of a pointer assignment. Alias resolution is only done,
11975	when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
11976	where it is known, that newly allocated memory on the lhs can never be
11977	an alias of the rhs. */
11978
11979	static tree
11980	gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
11981	bool dealloc, bool use_vptr_copy, bool may_alias)
11982	{
11983	gfc_se lse;
11984	gfc_se rse;
11985	gfc_ss *lss;
11986	gfc_ss *lss_section;
11987	gfc_ss *rss;
11988	gfc_loopinfo loop;
11989	tree tmp;
11990	stmtblock_t block;
11991	stmtblock_t body;
11992	bool final_expr;
11993	bool l_is_temp;
11994	bool scalar_to_array;
11995	tree string_length;
11996	int n;
11997	bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
11998	symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
11999	bool is_poly_assign;
12000	bool realloc_flag;
12001
12002	/* Assignment of the form lhs = rhs. */
12003	gfc_start_block (&block);
12004
12005	gfc_init_se (se: &lse, NULL);
12006	gfc_init_se (se: &rse, NULL);
12007
12008	/* Walk the lhs. */
12009	lss = gfc_walk_expr (expr1);
12010	if (gfc_is_reallocatable_lhs (expr1))
12011	{
12012	lss->no_bounds_check = 1;
12013	if (!(expr2->expr_type == EXPR_FUNCTION
12014	&& expr2->value.function.isym != NULL
12015	&& !(expr2->value.function.isym->elemental
12016	|| expr2->value.function.isym->conversion)))
12017	lss->is_alloc_lhs = 1;
12018	}
12019	else
12020	lss->no_bounds_check = expr1->no_bounds_check;
12021
12022	rss = NULL;
12023
12024	if (expr2->expr_type != EXPR_VARIABLE
12025	&& expr2->expr_type != EXPR_CONSTANT
12026	&& (expr2->ts.type == BT_CLASS || gfc_may_be_finalized (expr2->ts)))
12027	{
12028	expr2->must_finalize = 1;
12029	/* F2008 4.5.6.3 para 5: If an executable construct references a
12030	structure constructor or array constructor, the entity created by
12031	the constructor is finalized after execution of the innermost
12032	executable construct containing the reference.
12033	These finalizations were later deleted by the Combined Techical
12034	Corrigenda 1 TO 4 for fortran 2008 (f08/0011). */
12035	if (gfc_notification_std (GFC_STD_F2018_DEL)
12036	&& (expr2->expr_type == EXPR_STRUCTURE
12037	|| expr2->expr_type == EXPR_ARRAY))
12038	expr2->must_finalize = 0;
12039	}
12040
12041
12042	/* Checking whether a class assignment is desired is quite complicated and
12043	needed at two locations, so do it once only before the information is
12044	needed. */
12045	lhs_attr = gfc_expr_attr (expr1);
12046
12047	is_poly_assign = (use_vptr_copy || lhs_attr.pointer
12048	|| (lhs_attr.allocatable && !lhs_attr.dimension))
12049	&& (expr1->ts.type == BT_CLASS
12050	|| gfc_is_class_array_ref (expr1, NULL)
12051	|| gfc_is_class_scalar_expr (expr1)
12052	|| gfc_is_class_array_ref (expr2, NULL)
12053	|| gfc_is_class_scalar_expr (expr2))
12054	&& lhs_attr.flavor != FL_PROCEDURE;
12055
12056	realloc_flag = flag_realloc_lhs
12057	&& gfc_is_reallocatable_lhs (expr1)
12058	&& expr2->rank
12059	&& !is_runtime_conformable (expr1, expr2);
12060
12061	/* Only analyze the expressions for coarray properties, when in coarray-lib
12062	mode. Avoid false-positive uninitialized diagnostics with initializing
12063	the codimension flag unconditionally. */
12064	lhs_caf_attr.codimension = false;
12065	rhs_caf_attr.codimension = false;
12066	if (flag_coarray == GFC_FCOARRAY_LIB)
12067	{
12068	lhs_caf_attr = gfc_caf_attr (expr1, i: false, r: &lhs_refs_comp);
12069	rhs_caf_attr = gfc_caf_attr (expr2, i: false, r: &rhs_refs_comp);
12070	}
12071
12072	if (lss != gfc_ss_terminator)
12073	{
12074	/* The assignment needs scalarization. */
12075	lss_section = lss;
12076
12077	/* Find a non-scalar SS from the lhs. */
12078	while (lss_section != gfc_ss_terminator
12079	&& lss_section->info->type != GFC_SS_SECTION)
12080	lss_section = lss_section->next;
12081
12082	gcc_assert (lss_section != gfc_ss_terminator);
12083
12084	/* Initialize the scalarizer. */
12085	gfc_init_loopinfo (&loop);
12086
12087	/* Walk the rhs. */
12088	rss = gfc_walk_expr (expr2);
12089	if (rss == gfc_ss_terminator)
12090	/* The rhs is scalar. Add a ss for the expression. */
12091	rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
12092	/* When doing a class assign, then the handle to the rhs needs to be a
12093	pointer to allow for polymorphism. */
12094	if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
12095	rss->info->type = GFC_SS_REFERENCE;
12096
12097	rss->no_bounds_check = expr2->no_bounds_check;
12098	/* Associate the SS with the loop. */
12099	gfc_add_ss_to_loop (&loop, lss);
12100	gfc_add_ss_to_loop (&loop, rss);
12101
12102	/* Calculate the bounds of the scalarization. */
12103	gfc_conv_ss_startstride (&loop);
12104	/* Enable loop reversal. */
12105	for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
12106	loop.reverse[n] = GFC_ENABLE_REVERSE;
12107	/* Resolve any data dependencies in the statement. */
12108	if (may_alias)
12109	gfc_conv_resolve_dependencies (&loop, lss, rss);
12110	/* Setup the scalarizing loops. */
12111	gfc_conv_loop_setup (&loop, &expr2->where);
12112
12113	/* Setup the gfc_se structures. */
12114	gfc_copy_loopinfo_to_se (&lse, &loop);
12115	gfc_copy_loopinfo_to_se (&rse, &loop);
12116
12117	rse.ss = rss;
12118	gfc_mark_ss_chain_used (rss, 1);
12119	if (loop.temp_ss == NULL)
12120	{
12121	lse.ss = lss;
12122	gfc_mark_ss_chain_used (lss, 1);
12123	}
12124	else
12125	{
12126	lse.ss = loop.temp_ss;
12127	gfc_mark_ss_chain_used (lss, 3);
12128	gfc_mark_ss_chain_used (loop.temp_ss, 3);
12129	}
12130
12131	/* Allow the scalarizer to workshare array assignments. */
12132	if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
12133	== OMPWS_WORKSHARE_FLAG
12134	&& loop.temp_ss == NULL)
12135	{
12136	maybe_workshare = true;
12137	ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
12138	}
12139
12140	/* Start the scalarized loop body. */
12141	gfc_start_scalarized_body (&loop, &body);
12142	}
12143	else
12144	gfc_init_block (&body);
12145
12146	l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
12147
12148	/* Translate the expression. */
12149	rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
12150	&& lhs_caf_attr.codimension;
12151	gfc_conv_expr (se: &rse, expr: expr2);
12152
12153	/* Deal with the case of a scalar class function assigned to a derived type. */
12154	if (gfc_is_alloc_class_scalar_function (expr2)
12155	&& expr1->ts.type == BT_DERIVED)
12156	{
12157	rse.expr = gfc_class_data_get (decl: rse.expr);
12158	rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
12159	}
12160
12161	/* Stabilize a string length for temporaries. */
12162	if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
12163	&& !(VAR_P (rse.string_length)
12164	|| TREE_CODE (rse.string_length) == PARM_DECL
12165	|| INDIRECT_REF_P (rse.string_length)))
12166	string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
12167	else if (expr2->ts.type == BT_CHARACTER)
12168	{
12169	if (expr1->ts.deferred
12170	&& gfc_expr_attr (expr1).allocatable
12171	&& gfc_check_dependency (expr1, expr2, true))
12172	rse.string_length =
12173	gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
12174	string_length = rse.string_length;
12175	}
12176	else
12177	string_length = NULL_TREE;
12178
12179	if (l_is_temp)
12180	{
12181	gfc_conv_tmp_array_ref (se: &lse);
12182	if (expr2->ts.type == BT_CHARACTER)
12183	lse.string_length = string_length;
12184	}
12185	else
12186	{
12187	gfc_conv_expr (se: &lse, expr: expr1);
12188	if (gfc_option.rtcheck & GFC_RTCHECK_MEM
12189	&& !init_flag
12190	&& gfc_expr_attr (expr1).allocatable
12191	&& expr1->rank
12192	&& !expr2->rank)
12193	{
12194	tree cond;
12195	const char* msg;
12196
12197	tmp = INDIRECT_REF_P (lse.expr)
12198	? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
12199	STRIP_NOPS (tmp);
12200
12201	/* We should only get array references here. */
12202	gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
12203	|| TREE_CODE (tmp) == ARRAY_REF);
12204
12205	/* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
12206	or the array itself(ARRAY_REF). */
12207	tmp = TREE_OPERAND (tmp, 0);
12208
12209	/* Provide the address of the array. */
12210	if (TREE_CODE (lse.expr) == ARRAY_REF)
12211	tmp = gfc_build_addr_expr (NULL_TREE, tmp);
12212
12213	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
12214	tmp, build_int_cst (TREE_TYPE (tmp), 0));
12215	msg = _("Assignment of scalar to unallocated array");
12216	gfc_trans_runtime_check (true, false, cond, &loop.pre,
12217	&expr1->where, msg);
12218	}
12219
12220	/* Deallocate the lhs parameterized components if required. */
12221	if (dealloc && expr2->expr_type == EXPR_FUNCTION
12222	&& !expr1->symtree->n.sym->attr.associate_var)
12223	{
12224	if (expr1->ts.type == BT_DERIVED
12225	&& expr1->ts.u.derived
12226	&& expr1->ts.u.derived->attr.pdt_type)
12227	{
12228	tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
12229	expr1->rank);
12230	gfc_add_expr_to_block (&lse.pre, tmp);
12231	}
12232	else if (expr1->ts.type == BT_CLASS
12233	&& CLASS_DATA (expr1)->ts.u.derived
12234	&& CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
12235	{
12236	tmp = gfc_class_data_get (decl: lse.expr);
12237	tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
12238	tmp, expr1->rank);
12239	gfc_add_expr_to_block (&lse.pre, tmp);
12240	}
12241	}
12242	}
12243
12244	/* Assignments of scalar derived types with allocatable components
12245	to arrays must be done with a deep copy and the rhs temporary
12246	must have its components deallocated afterwards. */
12247	scalar_to_array = (expr2->ts.type == BT_DERIVED
12248	&& expr2->ts.u.derived->attr.alloc_comp
12249	&& !gfc_expr_is_variable (expr: expr2)
12250	&& expr1->rank && !expr2->rank);
12251	scalar_to_array |= (expr1->ts.type == BT_DERIVED
12252	&& expr1->rank
12253	&& expr1->ts.u.derived->attr.alloc_comp
12254	&& gfc_is_alloc_class_scalar_function (expr2));
12255	if (scalar_to_array && dealloc)
12256	{
12257	tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
12258	gfc_prepend_expr_to_block (&loop.post, tmp);
12259	}
12260
12261	/* When assigning a character function result to a deferred-length variable,
12262	the function call must happen before the (re)allocation of the lhs -
12263	otherwise the character length of the result is not known.
12264	NOTE 1: This relies on having the exact dependence of the length type
12265	parameter available to the caller; gfortran saves it in the .mod files.
12266	NOTE 2: Vector array references generate an index temporary that must
12267	not go outside the loop. Otherwise, variables should not generate
12268	a pre block.
12269	NOTE 3: The concatenation operation generates a temporary pointer,
12270	whose allocation must go to the innermost loop.
12271	NOTE 4: Elemental functions may generate a temporary, too. */
12272	if (flag_realloc_lhs
12273	&& expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
12274	&& !(lss != gfc_ss_terminator
12275	&& rss != gfc_ss_terminator
12276	&& ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
12277	|| (expr2->expr_type == EXPR_FUNCTION
12278	&& expr2->value.function.esym != NULL
12279	&& expr2->value.function.esym->attr.elemental)
12280	|| (expr2->expr_type == EXPR_FUNCTION
12281	&& expr2->value.function.isym != NULL
12282	&& expr2->value.function.isym->elemental)
12283	|| (expr2->expr_type == EXPR_OP
12284	&& expr2->value.op.op == INTRINSIC_CONCAT))))
12285	gfc_add_block_to_block (&block, &rse.pre);
12286
12287	/* Nullify the allocatable components corresponding to those of the lhs
12288	derived type, so that the finalization of the function result does not
12289	affect the lhs of the assignment. Prepend is used to ensure that the
12290	nullification occurs before the call to the finalizer. In the case of
12291	a scalar to array assignment, this is done in gfc_trans_scalar_assign
12292	as part of the deep copy. */
12293	if (!scalar_to_array && expr1->ts.type == BT_DERIVED
12294	&& (gfc_is_class_array_function (expr2)
12295	|| gfc_is_alloc_class_scalar_function (expr2)))
12296	{
12297	tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
12298	gfc_prepend_expr_to_block (&rse.post, tmp);
12299	if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
12300	gfc_add_block_to_block (&loop.post, &rse.post);
12301	}
12302
12303	tmp = NULL_TREE;
12304
12305	if (is_poly_assign)
12306	{
12307	tmp = trans_class_assignment (block: &body, lhs: expr1, rhs: expr2, lse: &lse, rse: &rse,
12308	use_vptr_copy: use_vptr_copy || (lhs_attr.allocatable
12309	&& !lhs_attr.dimension),
12310	class_realloc: !realloc_flag && flag_realloc_lhs
12311	&& !lhs_attr.pointer);
12312	if (expr2->expr_type == EXPR_FUNCTION
12313	&& expr2->ts.type == BT_DERIVED
12314	&& expr2->ts.u.derived->attr.alloc_comp)
12315	{
12316	tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived,
12317	rse.expr, expr2->rank);
12318	if (lss == gfc_ss_terminator)
12319	gfc_add_expr_to_block (&rse.post, tmp2);
12320	else
12321	gfc_add_expr_to_block (&loop.post, tmp2);
12322	}
12323
12324	expr1->must_finalize = 0;
12325	}
12326	else if (flag_coarray == GFC_FCOARRAY_LIB
12327	&& lhs_caf_attr.codimension && rhs_caf_attr.codimension
12328	&& ((lhs_caf_attr.allocatable && lhs_refs_comp)
12329	|| (rhs_caf_attr.allocatable && rhs_refs_comp)))
12330	{
12331	/* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
12332	allocatable component, because those need to be accessed via the
12333	caf-runtime. No need to check for coindexes here, because resolve
12334	has rewritten those already. */
12335	gfc_code code;
12336	gfc_actual_arglist a1, a2;
12337	/* Clear the structures to prevent accessing garbage. */
12338	memset (s: &code, c: '\0', n: sizeof (gfc_code));
12339	memset (s: &a1, c: '\0', n: sizeof (gfc_actual_arglist));
12340	memset (s: &a2, c: '\0', n: sizeof (gfc_actual_arglist));
12341	a1.expr = expr1;
12342	a1.next = &a2;
12343	a2.expr = expr2;
12344	a2.next = NULL;
12345	code.ext.actual = &a1;
12346	code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
12347	tmp = gfc_conv_intrinsic_subroutine (&code);
12348	}
12349	else if (!is_poly_assign && expr2->must_finalize
12350	&& expr1->ts.type == BT_CLASS
12351	&& expr2->ts.type == BT_CLASS)
12352	{
12353	/* This case comes about when the scalarizer provides array element
12354	references. Use the vptr copy function, since this does a deep
12355	copy of allocatable components, without which the finalizer call
12356	will deallocate the components. */
12357	tmp = gfc_get_vptr_from_expr (expr: rse.expr);
12358	if (tmp != NULL_TREE)
12359	{
12360	tree fcn = gfc_vptr_copy_get (vptr: tmp);
12361	if (POINTER_TYPE_P (TREE_TYPE (fcn)))
12362	fcn = build_fold_indirect_ref_loc (input_location, fcn);
12363	tmp = build_call_expr_loc (input_location,
12364	fcn, 2,
12365	gfc_build_addr_expr (NULL, rse.expr),
12366	gfc_build_addr_expr (NULL, lse.expr));
12367	}
12368	}
12369
12370	/* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
12371	after evaluation of the rhs and before reallocation. */
12372	final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag);
12373	if (final_expr && !(expr2->expr_type == EXPR_VARIABLE
12374	&& expr2->symtree->n.sym->attr.artificial))
12375	{
12376	if (lss == gfc_ss_terminator)
12377	{
12378	gfc_add_block_to_block (&block, &rse.pre);
12379	gfc_add_block_to_block (&block, &lse.finalblock);
12380	}
12381	else
12382	{
12383	gfc_add_block_to_block (&body, &rse.pre);
12384	gfc_add_block_to_block (&loop.code[expr1->rank - 1],
12385	&lse.finalblock);
12386	}
12387	}
12388	else
12389	gfc_add_block_to_block (&body, &rse.pre);
12390
12391	/* If nothing else works, do it the old fashioned way! */
12392	if (tmp == NULL_TREE)
12393	tmp = gfc_trans_scalar_assign (lse: &lse, rse: &rse, ts: expr1->ts,
12394	deep_copy: gfc_expr_is_variable (expr: expr2)
12395	|| scalar_to_array
12396	|| expr2->expr_type == EXPR_ARRAY,
12397	dealloc: !(l_is_temp || init_flag) && dealloc,
12398	in_coarray: expr1->symtree->n.sym->attr.codimension);
12399
12400
12401	/* Add the lse pre block to the body */
12402	gfc_add_block_to_block (&body, &lse.pre);
12403	gfc_add_expr_to_block (&body, tmp);
12404
12405	/* Add the post blocks to the body. */
12406	if (!l_is_temp)
12407	{
12408	gfc_add_block_to_block (&rse.finalblock, &rse.post);
12409	gfc_add_block_to_block (&body, &rse.finalblock);
12410	}
12411	else
12412	gfc_add_block_to_block (&body, &rse.post);
12413
12414	gfc_add_block_to_block (&body, &lse.post);
12415
12416	if (lss == gfc_ss_terminator)
12417	{
12418	/* F2003: Add the code for reallocation on assignment. */
12419	if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr: expr1)
12420	&& !is_poly_assign)
12421	alloc_scalar_allocatable_for_assignment (block: &block, string_length,
12422	expr1, expr2);
12423
12424	/* Use the scalar assignment as is. */
12425	gfc_add_block_to_block (&block, &body);
12426	}
12427	else
12428	{
12429	gcc_assert (lse.ss == gfc_ss_terminator
12430	&& rse.ss == gfc_ss_terminator);
12431
12432	if (l_is_temp)
12433	{
12434	gfc_trans_scalarized_loop_boundary (&loop, &body);
12435
12436	/* We need to copy the temporary to the actual lhs. */
12437	gfc_init_se (se: &lse, NULL);
12438	gfc_init_se (se: &rse, NULL);
12439	gfc_copy_loopinfo_to_se (&lse, &loop);
12440	gfc_copy_loopinfo_to_se (&rse, &loop);
12441
12442	rse.ss = loop.temp_ss;
12443	lse.ss = lss;
12444
12445	gfc_conv_tmp_array_ref (se: &rse);
12446	gfc_conv_expr (se: &lse, expr: expr1);
12447
12448	gcc_assert (lse.ss == gfc_ss_terminator
12449	&& rse.ss == gfc_ss_terminator);
12450
12451	if (expr2->ts.type == BT_CHARACTER)
12452	rse.string_length = string_length;
12453
12454	tmp = gfc_trans_scalar_assign (lse: &lse, rse: &rse, ts: expr1->ts,
12455	deep_copy: false, dealloc);
12456	gfc_add_expr_to_block (&body, tmp);
12457	}
12458
12459	/* F2003: Allocate or reallocate lhs of allocatable array. */
12460	if (realloc_flag)
12461	{
12462	realloc_lhs_warning (type: expr1->ts.type, array: true, where: &expr1->where);
12463	ompws_flags &= ~OMPWS_SCALARIZER_WS;
12464	tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
12465	if (tmp != NULL_TREE)
12466	gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
12467	}
12468
12469	if (maybe_workshare)
12470	ompws_flags &= ~OMPWS_SCALARIZER_BODY;
12471
12472	/* Generate the copying loops. */
12473	gfc_trans_scalarizing_loops (&loop, &body);
12474
12475	/* Wrap the whole thing up. */
12476	gfc_add_block_to_block (&block, &loop.pre);
12477	gfc_add_block_to_block (&block, &loop.post);
12478
12479	gfc_cleanup_loop (&loop);
12480	}
12481
12482	return gfc_finish_block (&block);
12483	}
12484
12485
12486	/* Check whether EXPR is a copyable array. */
12487
12488	static bool
12489	copyable_array_p (gfc_expr * expr)
12490	{
12491	if (expr->expr_type != EXPR_VARIABLE)
12492	return false;
12493
12494	/* First check it's an array. */
12495	if (expr->rank < 1 || !expr->ref || expr->ref->next)
12496	return false;
12497
12498	if (!gfc_full_array_ref_p (expr->ref, NULL))
12499	return false;
12500
12501	/* Next check that it's of a simple enough type. */
12502	switch (expr->ts.type)
12503	{
12504	case BT_INTEGER:
12505	case BT_REAL:
12506	case BT_COMPLEX:
12507	case BT_LOGICAL:
12508	return true;
12509
12510	case BT_CHARACTER:
12511	return false;
12512
12513	case_bt_struct:
12514	return !expr->ts.u.derived->attr.alloc_comp;
12515
12516	default:
12517	break;
12518	}
12519
12520	return false;
12521	}
12522
12523	/* Translate an assignment. */
12524
12525	tree
12526	gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
12527	bool dealloc, bool use_vptr_copy, bool may_alias)
12528	{
12529	tree tmp;
12530
12531	/* Special case a single function returning an array. */
12532	if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
12533	{
12534	tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
12535	if (tmp)
12536	return tmp;
12537	}
12538
12539	/* Special case assigning an array to zero. */
12540	if (copyable_array_p (expr: expr1)
12541	&& is_zero_initializer_p (expr: expr2))
12542	{
12543	tmp = gfc_trans_zero_assign (expr: expr1);
12544	if (tmp)
12545	return tmp;
12546	}
12547
12548	/* Special case copying one array to another. */
12549	if (copyable_array_p (expr: expr1)
12550	&& copyable_array_p (expr: expr2)
12551	&& gfc_compare_types (&expr1->ts, &expr2->ts)
12552	&& !gfc_check_dependency (expr1, expr2, 0))
12553	{
12554	tmp = gfc_trans_array_copy (expr1, expr2);
12555	if (tmp)
12556	return tmp;
12557	}
12558
12559	/* Special case initializing an array from a constant array constructor. */
12560	if (copyable_array_p (expr: expr1)
12561	&& expr2->expr_type == EXPR_ARRAY
12562	&& gfc_compare_types (&expr1->ts, &expr2->ts))
12563	{
12564	tmp = gfc_trans_array_constructor_copy (expr1, expr2);
12565	if (tmp)
12566	return tmp;
12567	}
12568
12569	if (UNLIMITED_POLY (expr1) && expr1->rank)
12570	use_vptr_copy = true;
12571
12572	/* Fallback to the scalarizer to generate explicit loops. */
12573	return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
12574	use_vptr_copy, may_alias);
12575	}
12576
12577	tree
12578	gfc_trans_init_assign (gfc_code * code)
12579	{
12580	return gfc_trans_assignment (expr1: code->expr1, expr2: code->expr2, init_flag: true, dealloc: false, use_vptr_copy: true);
12581	}
12582
12583	tree
12584	gfc_trans_assign (gfc_code * code)
12585	{
12586	return gfc_trans_assignment (expr1: code->expr1, expr2: code->expr2, init_flag: false, dealloc: true);
12587	}
12588
12589	/* Generate a simple loop for internal use of the form
12590	for (var = begin; var <cond> end; var += step)
12591	body; */
12592	void
12593	gfc_simple_for_loop (stmtblock_t *block, tree var, tree begin, tree end,
12594	enum tree_code cond, tree step, tree body)
12595	{
12596	tree tmp;
12597
12598	/* var = begin. */
12599	gfc_add_modify (block, var, begin);
12600
12601	/* Loop: for (var = begin; var <cond> end; var += step). */
12602	tree label_loop = gfc_build_label_decl (NULL_TREE);
12603	tree label_cond = gfc_build_label_decl (NULL_TREE);
12604	TREE_USED (label_loop) = 1;
12605	TREE_USED (label_cond) = 1;
12606
12607	gfc_add_expr_to_block (block, build1_v (GOTO_EXPR, label_cond));
12608	gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_loop));
12609
12610	/* Loop body. */
12611	gfc_add_expr_to_block (block, body);
12612
12613	/* End of loop body. */
12614	tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, step);
12615	gfc_add_modify (block, var, tmp);
12616	gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_cond));
12617	tmp = fold_build2_loc (input_location, cond, boolean_type_node, var, end);
12618	tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop),
12619	build_empty_stmt (input_location));
12620	gfc_add_expr_to_block (block, tmp);
12621	}
12622